From dafdd94ca381f564b313c451caf101b47df9bf13 Mon Sep 17 00:00:00 2001 From: mvertens Date: Fri, 11 Aug 2023 16:03:44 +0200 Subject: [PATCH 01/71] first commit of refactorization --- src/chemistry/oslo_aero/aero_model.F90 | 9 +- src/physics/cam_oslo/init_aeropt_mod.F90 | 415 +++++++++++ src/physics/cam_oslo/opticsAtConstRh.F90 | 823 +++++++++------------ src/physics/cam_oslo/optinterpol.F90 | 0 src/physics/cam_oslo/update_aeropt_mod.F90 | 820 ++++++++++++++++++++ 5 files changed, 1570 insertions(+), 497 deletions(-) create mode 100644 src/physics/cam_oslo/init_aeropt_mod.F90 mode change 100755 => 100644 src/physics/cam_oslo/optinterpol.F90 create mode 100644 src/physics/cam_oslo/update_aeropt_mod.F90 diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 9504fbb5a6..38a06f8722 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -14,6 +14,7 @@ module aero_model use perf_mod, only: t_startf, t_stopf use camsrfexch, only: cam_in_t, cam_out_t use aerodep_flx, only: aerodep_flx_prescribed + use init_aeropt_mod,only: initaeropt use physics_types, only: physics_state, physics_ptend, physics_ptend_init use physics_buffer, only: physics_buffer_desc use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field @@ -31,6 +32,8 @@ module aero_model , condtend_sub use koagsub, only: coagtend, clcoag use sox_cldaero_mod, only: sox_cldaero_init + + !use modal_aero_data,only: cnst_name_cw, lptr_so4_cw_amode !use modal_aero_data,only: ntot_amode, modename_amode, nspec_max @@ -230,16 +233,14 @@ subroutine aero_model_init( pbuf2d ) call phys_getopts(history_aerosol_out = history_aerosol, & convproc_do_aer_out = convproc_do_aer) -#ifdef OSLO_AERO call constants call initopt call initlogn call initopt_lw #ifdef AEROCOM - call initaeropt + call initaeropt() call initdryp #endif ! aerocom -#endif call initializeCondensation() call oslo_ocean_init() @@ -251,11 +252,9 @@ subroutine aero_model_init( pbuf2d ) call wetdep_init() call modal_aero_deposition_init() - nwetdep = 0 ndrydep = 0 - call inidrydep(rair, gravit) dummy = 'RAM1' call addfld (dummy,horiz_only, 'A','frac','RAM1') diff --git a/src/physics/cam_oslo/init_aeropt_mod.F90 b/src/physics/cam_oslo/init_aeropt_mod.F90 new file mode 100644 index 0000000000..77751892d9 --- /dev/null +++ b/src/physics/cam_oslo/init_aeropt_mod.F90 @@ -0,0 +1,415 @@ +module aeropt_mod + + use shr_kind_mod , only: r8 => shr_kind_r8 + use oslo_control , only: oslo_getopts, dir_string_length + use commondefinitions , only: nmodes, nbmodes + use opttab , only: cate, cat, fac, faq, fbc, rh, fombg, fbcbg + use cam_logfile , only: iulog + + implicit none + private + + real(r8), public :: bep1 (38,10, 6, 16, 6 ) + real(r8), public :: bep2to3 (38,10,16, 6, 2:3 ) + real(r8), public :: bep4 (38,10, 6, 16,6, 6 ) + real(r8), public :: bep5to10(38,10, 6, 6,6, 6, 5:10) + + ! for initaeropt and intaeropt0: + real(r8) , public:: bex440, bax440, bex500, bax500, bax550 + real(r8) , public:: bex670, bax670, bex870, bax870 + real(r8) , public:: bex550lt1, bex550gt1, backscx550 + + public :: initaeropt + private :: set_data + +contains + + subroutine initaeropt() + + !Purpose: To read in the AeroCom look-up tables for aerosol optical properties. + ! The grid for discrete input-values in the look-up tables is defined in opptab. + ! Tabulating the 'aerocomk'-files to save computing time. + ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 + ! Extended for new SOA treatment - Alf Kirkevaag, September 2015. + ! Modified for optimized added masses and mass fractions for + ! concentrations from condensation, coagulation or cloud-processing + ! - Alf Kirkevaag, May 2016. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + + ! local variables + integer :: kcomp, irelh, ictot, ifac, ifbc, ifaq + integer :: ifombg, ifbcbg + integer :: ic, ifil, lin, iv + character(len=dir_string_length) :: aerotab_table_dir + !----------------------------------------------------- + + call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + + open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' , form='formatted',status='old') + open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' , form='formatted',status='old') + open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' , form='formatted',status='old') + open(14,file=trim(aerotab_table_dir)//'/aerocomk5.out' , form='formatted',status='old') + open(15,file=trim(aerotab_table_dir)//'/aerocomk6.out' , form='formatted',status='old') + open(16,file=trim(aerotab_table_dir)//'/aerocomk7.out' , form='formatted',status='old') + open(17,file=trim(aerotab_table_dir)//'/aerocomk8.out' , form='formatted',status='old') + open(18,file=trim(aerotab_table_dir)//'/aerocomk9.out' , form='formatted',status='old') + open(19,file=trim(aerotab_table_dir)//'/aerocomk10.out', form='formatted',status='old') + open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' , form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' , form='formatted',status='old') + + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 11,21 + call checkTableHeader (ifil) + enddo + ! + !------------------------------------------- + ! Mode 0, BC(ax + !------------------------------------------- + ! + ifil = 11 + read (9+ifil,996) kcomp, relh, & + bex440, bax440, bex500, bax500, bax550, bex670, bax670, & + bex870, bax870, bex550lt1, bex550gt1, backscx550 +996 format(I2,f6.3,12e11.4) + + if (bex440<=0.0_r8) then + write(*,*) 'bex440 =', bex440 + write(*,*) 'Error in initialization of bex1' + stop + endif + write(iulog,*)'aerocom mode 0 ok' + ! + !------------------------------------------- + ! New mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) + !------------------------------------------- + ! + ifil = 1 + do lin = 1,5760 ! 10x6x16x6 + call set_data(format_index=997, file_index=20+ifil, bep=bep1, mode1=.true.) + end do ! lin + + do irelh=1,10 + do ifombg=1,6 + do ictot=1,16 + do ifac=1,6 + if(bep1(1,irelh,ifombg,ictot,ifac)<=0.0_r8) then + write(*,*) 'bep1 =', irelh,ifombg, ictot, ifac, bep1(1,irelh,ifombg,ictot,ifac) + write(*,*) 'Error in initialization of bep1' + stop + endif + enddo + enddo + enddo + enddo + write(iulog,*)'aerocom mode 1 ok' + ! + !------------------------------------------- + ! Modes 2 to 3 (BC/OC + condesate from H2SO4 and SOA) + !------------------------------------------- + ! + ! do ifil = 2,3 + do ifil = 2,2 + do lin = 1,960 ! 10x16x6 + call set_data(format_index=994, file_index=9+ifil, bep=bep2to3, mode2to3=.true.) + end do + end do + + ! Prescribed dummy values for unused kcomp=3 + kcomp=3 + do irelh=1,10 + do ictot=1,16 + do ifac=1,6 + do iv=1,38 + bep2to3(iv,irelh,ictot,ifac,kcomp)=1.0_r8 + enddo + enddo + enddo + enddo + + do kcomp=2,3 + do irelh=1,10 + do ictot=1,16 + do ifac=1,6 + if(bep2to3(1,irelh,ictot,ifac,kcomp)<=0.0_r8) then + write(*,*) 'bep2to3 =', irelh, ictot, ifac, bep2to3(1,irelh,ictot,ifac,kcomp) + write(*,*) 'Error in initialization of bep2to3' + stop + endif + enddo + enddo + enddo + enddo + + write(iulog,*)'aerocom mode 2-3 ok' + + ! + !------------------------------------------- + ! Mode 4 (BC&OC + condesate from H2SO4 and SOA + wetphase (NH4)2SO4) + !------------------------------------------- + ! + ifil = 4 + do lin = 1,34560 ! 10x16x6x6x6 + call set_data(format_index=995, file_index=9+ifil, bep=4, mode2to3=.true.) + end do + + do irelh=1,10 + do ifbcbg=1,6 + do ictot=1,16 + do ifac=1,6 + do ifaq=1,6 + if(bep4(1,irelh,ifbcbg,ictot,ifac,ifaq)<=0.0_r8) then + write(*,*) 'bep4 =', irelh, ifbcbg, ictot, ifac, ifaq, bep4(1,irelh,ifbcbg,ictot,ifac,ifaq) + write(*,*) 'Error in initialization of bep4' + stop + endif + enddo + enddo + enddo + enddo + enddo + write(iulog,*)'aerocom mode 4 ok' + ! + !------------------------------------------- + ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.) + !------------------------------------------- + ! + do ifil = 5,10 + do lin = 1,12960 ! 10x6x6x6x6 + call set_data(format_index=993, file_index=9+ifil, bep=4, mode2to3=.true.) + end do + end do + + do kcomp=5,10 + do irelh=1,10 + do ictot=1,6 + do ifac=1,6 + do ifaq=1,6 + if(bep5to10(1,irelh,ictot,ifac,ifbc,ifaq,kcomp)<=0.0_r8) then + write(*,*) 'bep5to10 =', kcomp, irelh, ictot, ifac, ifbc, ifaq, & + bep5to10(1,irelh,ictot,ifac,ifbc,ifaq,kcomp) + write(*,*) 'Error in initialization of bep5to10' + stop + endif + enddo + enddo + enddo + enddo + enddo + write(iulog,*)'aerocom mode 5-10 ok' + + do ifil=10,21 + close (ifil) + end do + + end subroutine initaeropt + + subroutine set_data(this, format_index, file_index, bep, mode1, mode2to3, mode4, mode5to10) + + class(optical_properties_type) :: this + integer , intent(in) :: format_index + integer , intent(in) :: file_index + real(r8) , intent(inout) :: bep(:,:,:,:,:) + logical, optional, intent(in) :: mode1 + logical, optional, intent(in) :: mode2to3 + logical, optional, intent(in) :: mode4 + logical, optional, intent(in) :: mode5to10 + + ! local variables + real(r8) :: catot, relh, frbcbg, frac, fabc, fraq + integer :: kcomp, irelh, ictot, ifac, ifbc, ifaq + integer :: ifombg, ifbcbg + real(r8) :: bext440, babs440, bext500, babs500, babs550 + real(r8) :: bext670, babs670, bext870, babs870 + real(r8) :: bebg440, babg440, bebg500, babg500, babg550 + real(r8) :: bebg670, babg670, bebg870, babg870 + real(r8) :: bebc440, babc440, bebc500, babc500, babc550 + real(r8) :: bebc670, babc670, bebc870, babc870 + real(r8) :: beoc440, baoc440, beoc500, baoc500, baoc550 + real(r8) :: beoc670, baoc670, beoc870, baoc870 + real(r8) :: besu440, basu440, besu500, basu500, basu550 + real(r8) :: besu670, basu670, besu870, basu870 + real(r8) :: bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1 + real(r8) :: beoc550lt1, beoc550gt1, besu550lt1, besu550gt1 + real(r8) :: backscat550 + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 + !----------------------------------------------------- + + if (format_index /= 993 .and. & + format_index /= 994 .and. & + format_index /= 995 .and. & + format_index /= 996 .and. & + format_index /= 997) then + write(*,*) 'Error in format index' + stop + end if + + read (file_index,format_index) kcomp, relh, frombg, catot, frac, & + bext440, bext500, bext670, bext870, & + bebg440, bebg500, bebg670, bebg870, & + bebc440, bebc500, bebc670, bebc870, & + beoc440, beoc500, beoc670, beoc870, & + besu440, besu500, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backscat550, babg550, babc550, baoc550, basu550 + + if (present(mode1)) then + do ic=1,10 + if(abs(relh-rh(ic)) shr_kind_r8 - use cam_history, only: outfld - use constituents, only: pcnst - use opttab - use const - use aerosoldef - use commondefinitions - use physics_types, only: physics_state - - implicit none - -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) - real(r8), intent(in) :: rhoda(pcols,pver) ! Density of dry air (kg/m^3) - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - integer, intent(in) :: irf - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration - real(r8), intent(in) :: vnbc(pcols,pver) - real(r8), intent(in) :: vaitbc(pcols,pver) - real(r8), intent(in) :: v_soana(pcols,pver) - real(r8), intent(in) :: xfombg(pcols,pver) - integer, intent(in) :: ifombg1(pcols,pver) - real(r8), intent(in) :: xfbcbg(pcols,pver) - integer, intent(in) :: ifbcbg1(pcols,pver) - real(r8), intent(in) :: xfbcbgn(pcols,pver) - integer, intent(in) :: ifbcbgn1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! facm for use in the interpolations - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations - integer, intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - -! -! Output arguments -! - real(r8), intent(out) :: & - bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & - bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & - bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & - bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & - bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & - bebg440(pcols,pver,0:nbmodes), & - bebg500(pcols,pver,0:nbmodes), & - bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & - bebg670(pcols,pver,0:nbmodes), & - bebg870(pcols,pver,0:nbmodes), & - bebc440(pcols,pver,0:nbmodes), & - bebc500(pcols,pver,0:nbmodes), & - bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & - bebc670(pcols,pver,0:nbmodes), & - bebc870(pcols,pver,0:nbmodes), & - beoc440(pcols,pver,0:nbmodes), & - beoc500(pcols,pver,0:nbmodes), & - beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & - beoc670(pcols,pver,0:nbmodes), & - beoc870(pcols,pver,0:nbmodes), & - besu440(pcols,pver,0:nbmodes), & - besu500(pcols,pver,0:nbmodes), & - besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & - besu670(pcols,pver,0:nbmodes), & - besu870(pcols,pver,0:nbmodes), & - bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & - bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & - beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & - bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes) - - real(r8), intent(out) :: & - bext440n(pcols,pver,0:nbmodes), babs440n(pcols,pver,0:nbmodes), & - bext500n(pcols,pver,0:nbmodes), babs500n(pcols,pver,0:nbmodes), & - bext550n(pcols,pver,0:nbmodes), babs550n(pcols,pver,0:nbmodes), & - bext670n(pcols,pver,0:nbmodes), babs670n(pcols,pver,0:nbmodes), & - bext870n(pcols,pver,0:nbmodes), babs870n(pcols,pver,0:nbmodes), & - bebg440n(pcols,pver,0:nbmodes), & - bebg500n(pcols,pver,0:nbmodes), & - bebg550n(pcols,pver,0:nbmodes), babg550n(pcols,pver,0:nbmodes), & - bebg670n(pcols,pver,0:nbmodes), & - bebg870n(pcols,pver,0:nbmodes), & - bebc440n(pcols,pver,0:nbmodes), & - bebc500n(pcols,pver,0:nbmodes), & - bebc550n(pcols,pver,0:nbmodes), babc550n(pcols,pver,0:nbmodes), & - bebc670n(pcols,pver,0:nbmodes), & - bebc870n(pcols,pver,0:nbmodes), & - beoc440n(pcols,pver,0:nbmodes), & - beoc500n(pcols,pver,0:nbmodes), & - beoc550n(pcols,pver,0:nbmodes), baoc550n(pcols,pver,0:nbmodes), & - beoc670n(pcols,pver,0:nbmodes), & - beoc870n(pcols,pver,0:nbmodes), & - besu440n(pcols,pver,0:nbmodes), & - besu500n(pcols,pver,0:nbmodes), & - besu550n(pcols,pver,0:nbmodes), basu550n(pcols,pver,0:nbmodes), & - besu670n(pcols,pver,0:nbmodes), & - besu870n(pcols,pver,0:nbmodes), & - bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & - bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & - beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & - bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & - backsc550n(pcols,pver,0:nbmodes) - -! -!---------------------------Local variables----------------------------- -! - integer i, k, icol, mplus10, irh - integer iloop - - real(r8) deltah - real(r8) dod550rh(pcols), abs550rh(pcols) -! - real(r8) babg440(pcols,pver,0:nbmodes), & - babg500(pcols,pver,0:nbmodes), & - babg670(pcols,pver,0:nbmodes), & - babg870(pcols,pver,0:nbmodes), & - babc440(pcols,pver,0:nbmodes), & - babc500(pcols,pver,0:nbmodes), & - babc670(pcols,pver,0:nbmodes), & - babc870(pcols,pver,0:nbmodes), & - baoc440(pcols,pver,0:nbmodes), & - baoc500(pcols,pver,0:nbmodes), & - baoc670(pcols,pver,0:nbmodes), & - baoc870(pcols,pver,0:nbmodes), & - basu440(pcols,pver,0:nbmodes), & - basu500(pcols,pver,0:nbmodes), & - basu670(pcols,pver,0:nbmodes), & - basu870(pcols,pver,0:nbmodes) - real(r8) ec550rh_aer(pcols,pver), abs550rh_aer(pcols,pver) - real(r8) bebglt1t(pcols,pver), bebclt1t(pcols,pver), & - beoclt1t(pcols,pver), bes4lt1t(pcols,pver) - real(r8) basu550tot(pcols,pver), babc550tot(pcols,pver), baoc550tot(pcols,pver), & - babc550xt(pcols,pver), baoc550xt(pcols,pver), & - ba550x(pcols,pver,nbmp1:nmodes), belt1x(pcols,pver,nbmp1:nmodes) -! Additional AeroCom Phase III output: - real(r8) ec440rh_aer(pcols,pver), abs440rh_aer(pcols,pver), & - ec870rh_aer(pcols,pver), abs870rh_aer(pcols,pver), & - be550lt1_aer(pcols,pver,0:nbmodes), ec550rhlt1_aer(pcols,pver), & - abs550rh_bc(pcols,pver), abs550rh_oc(pcols,pver), & - abs550rh_su(pcols,pver), abs550rh_ss(pcols,pver), & - abs550rh_du(pcols,pver), ec550rhlt1_bc(pcols,pver), & - ec550rhlt1_oc(pcols,pver), ec550rhlt1_su(pcols,pver), & - ec550rhlt1_ss(pcols,pver), ec550rhlt1_du(pcols,pver) -! - real(r8) babg440n(pcols,pver,0:nbmodes), & - babg500n(pcols,pver,0:nbmodes), & - babg670n(pcols,pver,0:nbmodes), & - babg870n(pcols,pver,0:nbmodes), & - babc440n(pcols,pver,0:nbmodes), & - babc500n(pcols,pver,0:nbmodes), & - babc670n(pcols,pver,0:nbmodes), & - babc870n(pcols,pver,0:nbmodes), & - baoc440n(pcols,pver,0:nbmodes), & - baoc500n(pcols,pver,0:nbmodes), & - baoc670n(pcols,pver,0:nbmodes), & - baoc870n(pcols,pver,0:nbmodes), & - basu440n(pcols,pver,0:nbmodes), & - basu500n(pcols,pver,0:nbmodes), & - basu670n(pcols,pver,0:nbmodes), & - basu870n(pcols,pver,0:nbmodes) - - real(r8) bedustlt1(pcols,pver), bedustgt1(pcols,pver), & - besslt1(pcols,pver), bessgt1(pcols,pver) - real(r8) bbclt1xt(pcols,pver), & - boclt1xt(pcols,pver), bocgt1xt(pcols,pver) - - character(len=10) :: modeString - character(len=20) :: varname - - -!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - - belt1x(:,:,:) = 0._r8 - - do iloop=1,1 - -! BC(ax) mode (hydrophobic, so no rhum needed here): - call intaeropt0(lchnk, ncol, Nnatk, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebglt1, bebggt1, bebclt1, bebcgt1, & - beoclt1, beocgt1, bes4lt1, bes4gt1, & - backsc550, babg550, babc550, baoc550, basu550) - -! SO4(Ait), BC(Ait) and OC(Ait) modes: - mplus10=0 - call intaeropt1(lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1,& - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebglt1, bebggt1, bebclt1, bebcgt1, & - beoclt1, beocgt1, bes4lt1, bes4gt1, & - backsc550, babg550, babc550, baoc550, basu550) - mplus10=0 - call intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebglt1, bebggt1, bebclt1, bebcgt1, & - beoclt1, beocgt1, bes4lt1, bes4gt1, & - backsc550, babg550, babc550, baoc550, basu550) - -! BC&OC(Ait) (4), OC&BC(Ait) mode - mplus10=0 - call intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebglt1, bebggt1, bebclt1, bebcgt1, & - beoclt1, beocgt1, bes4lt1, bes4gt1, & - backsc550, babg550, babc550, baoc550, basu550) - -! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call intaeropt5to10(lchnk, ncol, xrh, irh1, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebglt1, bebggt1, bebclt1, bebcgt1, & - beoclt1, beocgt1, bes4lt1, bes4gt1, & - backsc550, babg550, babc550, baoc550, basu550) - -! then to the externally mixed SO4(n), BC(n) and OC(n) modes: - mplus10=1 - call intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - bext440n, bext500n, bext550n, bext670n, bext870n, & - bebg440n, bebg500n, bebg550n, bebg670n, bebg870n, & - bebc440n, bebc500n, bebc550n, bebc670n, bebc870n, & - beoc440n, beoc500n, beoc550n, beoc670n, beoc870n, & - besu440n, besu500n, besu550n, besu670n, besu870n, & - babs440n, babs500n, babs550n, babs670n, babs870n, & - bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & - beoclt1n, beocgt1n, bes4lt1n, bes4gt1n, & - backsc550n, babg550n, babc550n, baoc550n, basu550n) - -! and finally the BC&OC(n) mode: - mplus10=1 - call intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbgn, ifbcbgn1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & - bext440n, bext500n, bext550n, bext670n, bext870n, & - bebg440n, bebg500n, bebg550n, bebg670n, bebg870n, & - bebc440n, bebc500n, bebc550n, bebc670n, bebc870n, & - beoc440n, beoc500n, beoc550n, beoc670n, beoc870n, & - besu440n, besu500n, besu550n, besu670n, besu870n, & - babs440n, babs500n, babs550n, babs670n, babs870n, & - bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & - beoclt1n, beocgt1n, bes4lt1n, bes4gt1n, & - backsc550n, babg550n, babc550n, baoc550n, basu550n) - - end do ! iloop - - -! Initialization - do k=1,pver - do icol=1,ncol - ec550rh_aer(icol,k)=0.0_r8 - abs550rh_aer(icol,k)=0.0_r8 - ec550rhlt1_aer(icol,k)=0.0_r8 - abs550rh_bc(icol,k)=0.0_r8 - abs550rh_oc(icol,k)=0.0_r8 - abs550rh_su(icol,k)=0.0_r8 - abs550rh_ss(icol,k)=0.0_r8 - abs550rh_du(icol,k)=0.0_r8 - ec440rh_aer(icol,k)=0.0_r8 - abs440rh_aer(icol,k)=0.0_r8 - ec870rh_aer(icol,k)=0.0_r8 - abs870rh_aer(icol,k)=0.0_r8 - basu550tot(icol,k)=0.0_r8 - babc550tot(icol,k)=0.0_r8 - baoc550tot(icol,k)=0.0_r8 - bebglt1t(icol,k)=0.0_r8 - bebclt1t(icol,k)=0.0_r8 - beoclt1t(icol,k)=0.0_r8 - bes4lt1t(icol,k)=0.0_r8 - bedustlt1(icol,k)=0.0_r8 - besslt1(icol,k)=0.0_r8 - end do - end do - do icol=1,ncol - dod550rh(icol)=0.0_r8 - abs550rh(icol)=0.0_r8 - end do - -! Calculation of extinction at given RH and absorption for all r and for r<0.5um - do k=1,pver - do icol=1,ncol - - do i=0,10 - ec550rh_aer(icol,k) = ec550rh_aer(icol,k)+Nnatk(icol,k,i)*bext550(icol,k,i) - abs550rh_aer(icol,k) = abs550rh_aer(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i) - ec440rh_aer(icol,k) = ec440rh_aer(icol,k)+Nnatk(icol,k,i)*bext440(icol,k,i) - abs440rh_aer(icol,k) = abs440rh_aer(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i) - ec870rh_aer(icol,k) = ec870rh_aer(icol,k)+Nnatk(icol,k,i)*bext870(icol,k,i) - abs870rh_aer(icol,k) = abs870rh_aer(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i) - basu550tot(icol,k) = basu550tot(icol,k)+Nnatk(icol,k,i)*basu550(icol,k,i) - babc550tot(icol,k) = babc550tot(icol,k)+Nnatk(icol,k,i)*babc550(icol,k,i) - baoc550tot(icol,k) = baoc550tot(icol,k)+Nnatk(icol,k,i)*baoc550(icol,k,i) - bes4lt1t(icol,k) = bes4lt1t(icol,k)+Nnatk(icol,k,i)*bes4lt1(icol,k,i) - bebclt1t(icol,k) = bebclt1t(icol,k)+Nnatk(icol,k,i)*bebclt1(icol,k,i) - beoclt1t(icol,k) = beoclt1t(icol,k)+Nnatk(icol,k,i)*beoclt1(icol,k,i) - enddo - do i=11,14 - ec550rh_aer(icol,k) = ec550rh_aer(icol,k)+Nnatk(icol,k,i)*bext550n(icol,k,i-10) - abs550rh_aer(icol,k) = abs550rh_aer(icol,k)+Nnatk(icol,k,i)*babs550n(icol,k,i-10) - ec440rh_aer(icol,k) = ec440rh_aer(icol,k)+Nnatk(icol,k,i)*bext440n(icol,k,i-10) - abs440rh_aer(icol,k) = abs440rh_aer(icol,k)+Nnatk(icol,k,i)*babs440n(icol,k,i-10) - ec870rh_aer(icol,k) = ec870rh_aer(icol,k)+Nnatk(icol,k,i)*bext870n(icol,k,i-10) - abs870rh_aer(icol,k) = abs870rh_aer(icol,k)+Nnatk(icol,k,i)*babs870n(icol,k,i-10) - ba550x(icol,k,i)=babs550n(icol,k,i-10) - belt1x(icol,k,i)=bebglt1n(icol,k,i-10) - enddo - - do i=6,7 - bedustlt1(icol,k) = bedustlt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) - enddo - do i=8,10 - besslt1(icol,k) = besslt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) - enddo - ec550rhlt1_du(icol,k) = bedustlt1(icol,k) - ec550rhlt1_ss(icol,k) = besslt1(icol,k) - -!soa: *(1-v_soan) for the sulfate volume fraction of mode 11 - bbclt1xt(icol,k) = Nnatk(icol,k,12)*belt1x(icol,k,12) & - + Nnatk(icol,k,14)*belt1x(icol,k,14)*vnbc(icol,k) -!soa + v_soan part of mode 11 for the OC volume fraction of that mode - boclt1xt(icol,k) = Nnatk(icol,k,13)*belt1x(icol,k,13) & - + Nnatk(icol,k,14)*belt1x(icol,k,14)*(1.0_r8-vnbc(icol,k)) - -!soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - ec550rhlt1_su(icol,k) = bes4lt1t(icol,k) & ! condensate - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k))& ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebglt1(icol,k,5) ! background, SO4(Ait75) mode (5) - ec550rhlt1_bc(icol,k) = bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) - + Nnatk(icol,k,4)*bebglt1(icol,k,4)*vaitbc(icol,k) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebglt1(icol,k,0) ! background, BC(ax) mode (0) -!soa + v_soan part of mode 11 for the OC volume fraction of that mode - ec550rhlt1_oc(icol,k) = beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC (13) - + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) - + Nnatk(icol,k,4)*bebglt1(icol,k,4)*(1.0_r8-vaitbc(icol,k))& ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) - - ec550rhlt1_aer(icol,k) = ec550rhlt1_su(icol,k)+ec550rhlt1_bc(icol,k) & - + ec550rhlt1_oc(icol,k) + ec550rhlt1_ss(icol,k)+ec550rhlt1_du(icol,k) - ec550rhlt1_aer(icol,k) = 1.e-3_r8*ec550rhlt1_aer(icol,k) - - abs550rh_du(icol,k) = Nnatk(icol,k,6)*babg550(icol,k,6) & - + Nnatk(icol,k,7)*babg550(icol,k,7) - abs550rh_ss(icol,k) = Nnatk(icol,k,8)*babg550(icol,k,8) & - + Nnatk(icol,k,9)*babg550(icol,k,9) & - + Nnatk(icol,k,10)*babg550(icol,k,10) -!soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - abs550rh_su(icol,k) = basu550tot(icol,k) & ! condensate:w - - + (1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*babg550(icol,k,5) ! background, SO4(Ait75) mode (5) - -!soa: *(1-v_soan) for the sulfate volume fraction - babc550xt(icol,k) = Nnatk(icol,k,12)*ba550x(icol,k,12) & - + Nnatk(icol,k,14)*ba550x(icol,k,14)*vnbc(icol,k) - - baoc550xt(icol,k) = Nnatk(icol,k,13)*ba550x(icol,k,13) & - + Nnatk(icol,k,14)*ba550x(icol,k,14)*(1.0_r8-vnbc(icol,k)) - - abs550rh_bc(icol,k) = babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*babg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc(icol,k)*Nnatk(icol,k,4)*babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*babg550(icol,k,0) ! background, BC(ax) mode (0) - - abs550rh_oc(icol,k) = baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC (13) - + v_soana(icol,k)*Nnatk(icol,k,1)*babg550(icol,k,1) & ! SOA fraction of mode 1 - + Nnatk(icol,k,3)*babg550(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc(icol,k))*Nnatk(icol,k,4)*babg550(icol,k,4) ! background in OC&BC(Ait) mode (4) - - deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) - dod550rh(icol) = dod550rh(icol)+ec550rh_aer(icol,k)*deltah - abs550rh(icol) = abs550rh(icol)+abs550rh_aer(icol,k)*deltah - - ec550rh_aer(icol,k) = 1.e-3_r8*ec550rh_aer(icol,k) - abs550rh_aer(icol,k) = 1.e-3_r8*abs550rh_aer(icol,k) - ec440rh_aer(icol,k) = 1.e-3_r8*ec440rh_aer(icol,k) - abs440rh_aer(icol,k) = 1.e-3_r8*abs440rh_aer(icol,k) - ec870rh_aer(icol,k) = 1.e-3_r8*ec870rh_aer(icol,k) - abs870rh_aer(icol,k) = 1.e-3_r8*abs870rh_aer(icol,k) - - abs550rh_bc(icol,k) = 1.e-3_r8*abs550rh_bc(icol,k) - abs550rh_oc(icol,k) = 1.e-3_r8*abs550rh_oc(icol,k) - abs550rh_su(icol,k) = 1.e-3_r8*abs550rh_su(icol,k) - abs550rh_ss(icol,k) = 1.e-3_r8*abs550rh_ss(icol,k) - abs550rh_du(icol,k) = 1.e-3_r8*abs550rh_du(icol,k) - - enddo - enddo - - if(irf.eq.1) then - - call outfld('ECDRYAER',ec550rh_aer,pcols,lchnk) - call outfld('ABSDRYAE',abs550rh_aer,pcols,lchnk) - call outfld('OD550DRY',dod550rh,pcols,lchnk) ! 2D variable - call outfld('AB550DRY',abs550rh,pcols,lchnk) ! 2D variable - call outfld('ECDRY440',ec440rh_aer,pcols,lchnk) - call outfld('ABSDR440',abs440rh_aer,pcols,lchnk) - call outfld('ECDRY870',ec870rh_aer,pcols,lchnk) - call outfld('ABSDR870',abs870rh_aer,pcols,lchnk) - call outfld('ECDRYLT1',ec550rhlt1_aer,pcols,lchnk) -! Since we do not have enough look-up table info to take abs550rhlt1_aer, -! instead take out abs550rh for each constituent: - call outfld('ABSDRYBC',abs550rh_bc,pcols,lchnk) - call outfld('ABSDRYOC',abs550rh_oc,pcols,lchnk) - call outfld('ABSDRYSU',abs550rh_su,pcols,lchnk) - call outfld('ABSDRYSS',abs550rh_ss,pcols,lchnk) - call outfld('ABSDRYDU',abs550rh_du,pcols,lchnk) - - elseif(irf.ge.2) then ! only happens for AEROCOM_INSITU - - irh=RF(irf) - - modeString=" " - write(modeString,"(I2)"),irh - if(RF(irf).eq.0) modeString="00" - -!- varName = "EC44RH"//trim(modeString) -!- call outfld(varName,ec440rh_aer(:,:),pcols,lchnk) - varName = "EC55RH"//trim(modeString) - call outfld(varName,ec550rh_aer(:,:),pcols,lchnk) -!- varName = "EC87RH"//trim(modeString) -!- call outfld(varName,ec870rh_aer(:,:),pcols,lchnk) - -!- varName = "AB44RH"//trim(modeString) -!- call outfld(varName,abs440rh_aer(:,:),pcols,lchnk) - varName = "AB55RH"//trim(modeString) - call outfld(varName,abs550rh_aer(:,:),pcols,lchnk) -!- varName = "AB87RH"//trim(modeString) -!- call outfld(varName,abs870rh_aer(:,:),pcols,lchnk) - - end if ! irf - -!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - - - return +subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbc, vaitbc, v_soana, & + extinction_coeffs, extinction_coeffsn) + + + ! Extra AeroCom diagnostics requiring table look-ups with constant/fixed RH, + ! i.e. for RH = (/"00","40","55","65","75","85" /) (see opttab.F90) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_history, only: outfld + use constituents, only: pcnst + use opttab + use const + use aerosoldef + use commondefinitions + use physics_types, only: physics_state + use interp_aeropt_mod, only : extinction_coeffs_type + use interp_aeropt_mod, only : intaeropt0, intaeropt1 + + + implicit none + ! + ! Input arguments + ! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) + real(r8), intent(in) :: rhoda(pcols,pver) ! Density of dry air (kg/m^3) + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + integer, intent(in) :: irf + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration + real(r8), intent(in) :: vnbc(pcols,pver) + real(r8), intent(in) :: vaitbc(pcols,pver) + real(r8), intent(in) :: v_soana(pcols,pver) + real(r8), intent(in) :: xfombg(pcols,pver) + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: xfbcbg(pcols,pver) + integer, intent(in) :: ifbcbg1(pcols,pver) + real(r8), intent(in) :: xfbcbgn(pcols,pver) + integer, intent(in) :: ifbcbgn1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! facm for use in the interpolations + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations + integer, intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + type(extinction_coeffs_type) , intent(inout) :: extinction_coeffs + type(extinction_coeffs_type) , intent(inout) :: extinction_coeffsn + ! + !---------------------------Local variables----------------------------- + ! + integer :: i, k, icol, mplus10, irh + integer :: iloop + real(r8) :: deltah + real(r8) :: dod550rh(pcols), abs550rh(pcols) + real(r8) :: ec550rh_aer(pcols,pver) + real(r8) :: abs550rh_aer(pcols,pver) + real(r8) :: bebglt1t(pcols,pver) + real(r8) :: bebclt1t(pcols,pver) + real(r8) :: beoclt1t(pcols,pver) + real(r8) :: bes4lt1t(pcols,pver) + real(r8) :: basu550tot(pcols,pver) + real(r8) :: babc550tot(pcols,pver) + real(r8) :: baoc550tot(pcols,pver) + real(r8) :: babc550xt(pcols,pver) + real(r8) :: baoc550xt(pcols,pver), & + real(r8) :: ba550x(pcols,pver,nbmp1:nmodes) + real(r8) :: belt1x(pcols,pver,nbmp1:nmodes) + ! Additionl AeroCom Phase III output: + real(r8) :: ec440rh_aer(pcols,pver) + real(r8) :: abs440rh_aer(pcols,pver) + real(r8) :: ec870rh_aer(pcols,pver) + real(r8) :: abs870rh_aer(pcols,pver) + real(r8) :: be550lt1_aer(pcols,pver,0:nbmodes) + real(r8) :: ec550rhlt1_aer(pcols,pver) + real(r8) :: abs550rh_bc(pcols,pver) + real(r8) :: abs550rh_oc(pcols,pver) + real(r8) :: abs550rh_su(pcols,pver) + real(r8) :: abs550rh_ss(pcols,pver) + real(r8) :: abs550rh_du(pcols,pver) + real(r8) :: ec550rhlt1_bc(pcols,pver) + real(r8) :: ec550rhlt1_oc(pcols,pver) + real(r8) :: ec550rhlt1_su(pcols,pver) + real(r8) :: ec550rhlt1_ss(pcols,pver) + real(r8) :: ec550rhlt1_du(pcols,pver) + real(r8) :: bedustlt1(pcols,pver) + real(r8) :: bedustgt1(pcols,pver) + real(r8) :: besslt1(pcols,pver) + real(r8) :: bessgt1(pcols,pver) + real(r8) :: bbclt1xt(pcols,pver) + real(r8) :: boclt1xt(pcols,pver) + real(r8) :: bocgt1xt(pcols,pver) + + character(len=10) :: modeString + character(len=20) :: varname + !-------------------------------------------------- + + belt1x(:,:,:) = 0._r8 + + do iloop=1,1 + + ! BC(ax) mode (hydrophobic, so no rhum needed here): + call intaeropt0(lchnk, ncol, Nnatk, extinction_coeffs) + + ! SO4(Ait), BC(Ait) and OC(Ait) modes: + mplus10=0 + call intaeropt1(lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1,& + extinction_coeffs) + + mplus10=0 + call intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + extinction_coeffs) + + ! BC&OC(Ait) (4), OC&BC(Ait) mode + mplus10=0 + call intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & + extinction_coeffs) + + ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call intaeropt5to10(lchnk, ncol, xrh, irh1, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + extinction_coeffs) + + ! then to the externally mixed SO4(n), BC(n) and OC(n) modes: + mplus10=1 + call intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + extinction_coeffsn) + + ! and finally the BC&OC(n) mode: + mplus10=1 + call intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbgn, ifbcbgn1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & + extinction_coeffsn) + + end do ! iloop + + + ! Initialization + do k=1,pver + do icol=1,ncol + ec550rh_aer(icol,k) = 0.0_r8 + abs550rh_aer(icol,k) = 0.0_r8 + ec550rhlt1_aer(icol,k) = 0.0_r8 + abs550rh_bc(icol,k) = 0.0_r8 + abs550rh_oc(icol,k) = 0.0_r8 + abs550rh_su(icol,k) = 0.0_r8 + abs550rh_ss(icol,k) = 0.0_r8 + abs550rh_du(icol,k) = 0.0_r8 + ec440rh_aer(icol,k) = 0.0_r8 + abs440rh_aer(icol,k) = 0.0_r8 + ec870rh_aer(icol,k) = 0.0_r8 + abs870rh_aer(icol,k) = 0.0_r8 + basu550tot(icol,k) = 0.0_r8 + babc550tot(icol,k) = 0.0_r8 + baoc550tot(icol,k) = 0.0_r8 + bebglt1t(icol,k) = 0.0_r8 + bebclt1t(icol,k) = 0.0_r8 + beoclt1t(icol,k) = 0.0_r8 + bes4lt1t(icol,k) = 0.0_r8 + bedustlt1(icol,k) = 0.0_r8 + besslt1(icol,k) = 0.0_r8 + end do + end do + do icol=1,ncol + dod550rh(icol) = 0.0_r8 + abs550rh(icol) = 0.0_r8 + end do + + ! Calculation of extinction at given RH and absorption for all r and for r<0.5um + do k=1,pver + do icol=1,ncol + + do i=0,10 + ec550rh_aer(icol,k) = ec550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext550(icol,k,i) + abs550rh_aer(icol,k) = abs550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i) + ec440rh_aer(icol,k) = ec440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext440(icol,k,i) + abs440rh_aer(icol,k) = abs440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i) + ec870rh_aer(icol,k) = ec870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext870(icol,k,i) + abs870rh_aer(icol,k) = abs870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i) + basu550tot(icol,k) = basu550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%basu550(icol,k,i) + babc550tot(icol,k) = babc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babc550(icol,k,i) + baoc550tot(icol,k) = baoc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%baoc550(icol,k,i) + bes4lt1t(icol,k) = bes4lt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bes4lt1(icol,k,i) + bebclt1t(icol,k) = bebclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebclt1(icol,k,i) + beoclt1t(icol,k) = beoclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%beoclt1(icol,k,i) + enddo + do i=11,14 + ec550rh_aer(icol,k) = ec550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext550(icol,k,i-10) + abs550rh_aer(icol,k) = abs550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs550(icol,k,i-10) + ec440rh_aer(icol,k) = ec440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext440(icol,k,i-10) + abs440rh_aer(icol,k) = abs440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs440(icol,k,i-10) + ec870rh_aer(icol,k) = ec870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext870(icol,k,i-10) + abs870rh_aer(icol,k) = abs870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs870(icol,k,i-10) + ba550x(icol,k,i) = extinction_coeffsn%babs550(icol,k,i-10) + belt1x(icol,k,i) = bebglt1(icol,k,i-10) !??? + enddo + + do i=6,7 + bedustlt1(icol,k) = bedustlt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) + enddo + do i=8,10 + besslt1(icol,k) = besslt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) + enddo + ec550rhlt1_du(icol,k) = bedustlt1(icol,k) + ec550rhlt1_ss(icol,k) = besslt1(icol,k) + + !soa: *(1-v_soan) for the sulfate volume fraction of mode 11 + bbclt1xt(icol,k) = Nnatk(icol,k,12)*belt1x(icol,k,12) & + + Nnatk(icol,k,14)*belt1x(icol,k,14)*vnbc(icol,k) + !soa + v_soan part of mode 11 for the OC volume fraction of that mode + boclt1xt(icol,k) = Nnatk(icol,k,13)*belt1x(icol,k,13) & + + Nnatk(icol,k,14)*belt1x(icol,k,14)*(1.0_r8-vnbc(icol,k)) + + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + ec550rhlt1_su(icol,k) = bes4lt1t(icol,k) & ! condensate + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k))& ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebglt1(icol,k,5) ! background, SO4(Ait75) mode (5) + ec550rhlt1_bc(icol,k) = bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) + + Nnatk(icol,k,4)*bebglt1(icol,k,4)*vaitbc(icol,k) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebglt1(icol,k,0) ! background, BC(ax) mode (0) + !soa + v_soan part of mode 11 for the OC volume fraction of that mode + ec550rhlt1_oc(icol,k) = beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC (13) + + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) + + Nnatk(icol,k,4)*bebglt1(icol,k,4)*(1.0_r8-vaitbc(icol,k))& ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) + + ec550rhlt1_aer(icol,k) = ec550rhlt1_su(icol,k)+ec550rhlt1_bc(icol,k) & + + ec550rhlt1_oc(icol,k) + ec550rhlt1_ss(icol,k)+ec550rhlt1_du(icol,k) + ec550rhlt1_aer(icol,k) = 1.e-3_r8*ec550rhlt1_aer(icol,k) + + abs550rh_du(icol,k) = Nnatk(icol,k,6)*babg550(icol,k,6) & + + Nnatk(icol,k,7)*babg550(icol,k,7) + abs550rh_ss(icol,k) = Nnatk(icol,k,8)*babg550(icol,k,8) & + + Nnatk(icol,k,9)*babg550(icol,k,9) & + + Nnatk(icol,k,10)*babg550(icol,k,10) + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + abs550rh_su(icol,k) = basu550tot(icol,k) & ! condensate:w + + (1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*babg550(icol,k,5) ! background, SO4(Ait75) mode (5) + + !soa: *(1-v_soan) for the sulfate volume fraction + babc550xt(icol,k) = Nnatk(icol,k,12)*ba550x(icol,k,12) & + + Nnatk(icol,k,14)*ba550x(icol,k,14)*vnbc(icol,k) + + baoc550xt(icol,k) = Nnatk(icol,k,13)*ba550x(icol,k,13) & + + Nnatk(icol,k,14)*ba550x(icol,k,14)*(1.0_r8-vnbc(icol,k)) + + abs550rh_bc(icol,k) = babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*babg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc(icol,k)*Nnatk(icol,k,4)*babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*babg550(icol,k,0) ! background, BC(ax) mode (0) + + abs550rh_oc(icol,k) = baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC (13) + + v_soana(icol,k)*Nnatk(icol,k,1)*babg550(icol,k,1) & ! SOA fraction of mode 1 + + Nnatk(icol,k,3)*babg550(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc(icol,k))*Nnatk(icol,k,4)*babg550(icol,k,4) ! background in OC&BC(Ait) mode (4) + + deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) + dod550rh(icol) = dod550rh(icol)+ec550rh_aer(icol,k)*deltah + abs550rh(icol) = abs550rh(icol)+abs550rh_aer(icol,k)*deltah + + ec550rh_aer(icol,k) = 1.e-3_r8*ec550rh_aer(icol,k) + abs550rh_aer(icol,k) = 1.e-3_r8*abs550rh_aer(icol,k) + ec440rh_aer(icol,k) = 1.e-3_r8*ec440rh_aer(icol,k) + abs440rh_aer(icol,k) = 1.e-3_r8*abs440rh_aer(icol,k) + ec870rh_aer(icol,k) = 1.e-3_r8*ec870rh_aer(icol,k) + abs870rh_aer(icol,k) = 1.e-3_r8*abs870rh_aer(icol,k) + + abs550rh_bc(icol,k) = 1.e-3_r8*abs550rh_bc(icol,k) + abs550rh_oc(icol,k) = 1.e-3_r8*abs550rh_oc(icol,k) + abs550rh_su(icol,k) = 1.e-3_r8*abs550rh_su(icol,k) + abs550rh_ss(icol,k) = 1.e-3_r8*abs550rh_ss(icol,k) + abs550rh_du(icol,k) = 1.e-3_r8*abs550rh_du(icol,k) + + enddo + enddo + + if(irf.eq.1) then + + call outfld('ECDRYAER',ec550rh_aer,pcols,lchnk) + call outfld('ABSDRYAE',abs550rh_aer,pcols,lchnk) + call outfld('OD550DRY',dod550rh,pcols,lchnk) ! 2D variable + call outfld('AB550DRY',abs550rh,pcols,lchnk) ! 2D variable + call outfld('ECDRY440',ec440rh_aer,pcols,lchnk) + call outfld('ABSDR440',abs440rh_aer,pcols,lchnk) + call outfld('ECDRY870',ec870rh_aer,pcols,lchnk) + call outfld('ABSDR870',abs870rh_aer,pcols,lchnk) + call outfld('ECDRYLT1',ec550rhlt1_aer,pcols,lchnk) + ! Since we do not have enough look-up table info to take abs550rhlt1_aer, + ! instead take out abs550rh for each constituent: + call outfld('ABSDRYBC',abs550rh_bc,pcols,lchnk) + call outfld('ABSDRYOC',abs550rh_oc,pcols,lchnk) + call outfld('ABSDRYSU',abs550rh_su,pcols,lchnk) + call outfld('ABSDRYSS',abs550rh_ss,pcols,lchnk) + call outfld('ABSDRYDU',abs550rh_du,pcols,lchnk) + + elseif(irf.ge.2) then ! only happens for AEROCOM_INSITU + + irh=RF(irf) + + modeString=" " + write(modeString,"(I2)"),irh + if(RF(irf).eq.0) modeString="00" + + !- varName = "EC44RH"//trim(modeString) + !- call outfld(varName,ec440rh_aer(:,:),pcols,lchnk) + varName = "EC55RH"//trim(modeString) + call outfld(varName,ec550rh_aer(:,:),pcols,lchnk) + !- varName = "EC87RH"//trim(modeString) + !- call outfld(varName,ec870rh_aer(:,:),pcols,lchnk) + + !- varName = "AB44RH"//trim(modeString) + !- call outfld(varName,abs440rh_aer(:,:),pcols,lchnk) + varName = "AB55RH"//trim(modeString) + call outfld(varName,abs550rh_aer(:,:),pcols,lchnk) + !- varName = "AB87RH"//trim(modeString) + !- call outfld(varName,abs870rh_aer(:,:),pcols,lchnk) + + end if ! irf + end subroutine opticsAtConstRh diff --git a/src/physics/cam_oslo/optinterpol.F90 b/src/physics/cam_oslo/optinterpol.F90 old mode 100755 new mode 100644 diff --git a/src/physics/cam_oslo/update_aeropt_mod.F90 b/src/physics/cam_oslo/update_aeropt_mod.F90 new file mode 100644 index 0000000000..751f76df9f --- /dev/null +++ b/src/physics/cam_oslo/update_aeropt_mod.F90 @@ -0,0 +1,820 @@ +module update_aeropt_mod + + use shr_kind_mod , only : r8 => shr_kind_r8 + use ppgrid , only : pcols, pver + use commondefinitions , only : nmodes, nbmodes + use opttab , only : cate, cat, fac, faq, fbc + use aeropt_mod , only : bep1, beg2to3, beb4, beg5to10 + use aeropt_mod , only : bex440, bax440, bex500, bax500, bax550 + use aeropt_mod , only : bex670, bax670, bex870, bax870 + use aeropt_mod , only : bex550lt1, bex550gt1, backscx550 + + implicit none + + type, public :: extinction_coeffs_type + ! Modal total and absorption extiction coefficients (for AeroCom) + ! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). + ! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). + + real(r8), allocatable :: bext440(:,:,:) + real(r8), allocatable :: babs440(:,:,:) + real(r8), allocatable :: bext500(:,:,:) + real(r8), allocatable :: babs500(:,:,:) + real(r8), allocatable :: bext550(:,:,:) + real(r8), allocatable :: babs550(:,:,:) + real(r8), allocatable :: bext670(:,:,:) + real(r8), allocatable :: babs670(:,:,:) + real(r8), allocatable :: bext870(:,:,:) + real(r8), allocatable :: babs870(:,:,:) + real(r8), allocatable :: bebg440(:,:,:) + real(r8), allocatable :: bebg500(:,:,:) + real(r8), allocatable :: bebg550(:,:,:) + real(r8), allocatable :: babg550(:,:,:) + real(r8), allocatable :: bebg670(:,:,:) + real(r8), allocatable :: bebg870(:,:,:) + real(r8), allocatable :: bebc440(:,:,:) + real(r8), allocatable :: bebc500(:,:,:) + real(r8), allocatable :: bebc550(:,:,:) + real(r8), allocatable :: babc550(:,:,:) + real(r8), allocatable :: bebc670(:,:,:) + real(r8), allocatable :: bebc870(:,:,:) + real(r8), allocatable :: beoc440(:,:,:) + real(r8), allocatable :: beoc500(:,:,:) + real(r8), allocatable :: beoc550(:,:,:) + real(r8), allocatable :: baoc550(:,:,:) + real(r8), allocatable :: beoc670(:,:,:) + real(r8), allocatable :: beoc870(:,:,:) + real(r8), allocatable :: besu440(:,:,:) + real(r8), allocatable :: besu500(:,:,:) + real(r8), allocatable :: besu550(:,:,:) + real(r8), allocatable :: basu550(:,:,:) + real(r8), allocatable :: besu670(:,:,:) + real(r8), allocatable :: besu870(:,:,:) + real(r8), allocatable :: bebg550lt1(:,:,:) + real(r8), allocatable :: bebg550gt1(:,:,:) + real(r8), allocatable :: bebc550lt1(:,:,:) + real(r8), allocatable :: bebc550gt1(:,:,:) + real(r8), allocatable :: beoc550lt1(:,:,:) + real(r8), allocatable :: beoc550gt1(:,:,:) + real(r8), allocatable :: besu550lt1(:,:,:) + real(r8), allocatable :: besu550gt1(:,:,:) + real(r8), allocatable :: backsc550(:,:,:) + + contains + + procedure :: allocate_coeffs + procedure :: zero_coeffs + procedure :: update_coeffs + + end type extinction_coeffs_type + + type(extinction_coeffs_type), public :: extinction_coeffs + type(extinction_coeffs_type), public :: extinction_coeffsn + + public :: intaeropt0 + public :: intaeropt1 + public :: intaeropt2to3 + public :: intaeropt4 + public :: intaeropt5to10 + +! ========================================================== +contains +! ========================================================== + + subroutine allocate_coeffs(this) + + class(extinction_coeffs_type) :: this + + allocate(this_coeffs%bext440(pcols,pver,0:nbmodes)) + allocate(this_coeffs%babs440(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bext500(pcols,pver,0:nbmodes)) + allocate(this_coeffs%babs500(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bext550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%babs550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bext670(pcols,pver,0:nbmodes)) + allocate(this_coeffs%babs670(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bext870(pcols,pver,0:nbmodes)) + allocate(this_coeffs%babs870(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebg440(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebg500(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebg550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%babg550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebg670(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebg870(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebc440(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebc500(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebc550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%babc550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebc670(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebc870(pcols,pver,0:nbmodes)) + allocate(this_coeffs%beoc440(pcols,pver,0:nbmodes)) + allocate(this_coeffs%beoc500(pcols,pver,0:nbmodes)) + allocate(this_coeffs%beoc550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%baoc550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%beoc670(pcols,pver,0:nbmodes)) + allocate(this_coeffs%beoc870(pcols,pver,0:nbmodes)) + allocate(this_coeffs%besu440(pcols,pver,0:nbmodes)) + allocate(this_coeffs%besu500(pcols,pver,0:nbmodes)) + allocate(this_coeffs%besu550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%basu550(pcols,pver,0:nbmodes)) + allocate(this_coeffs%besu670(pcols,pver,0:nbmodes)) + allocate(this_coeffs%besu870(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebg550lt1(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebg550gt1(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebc550lt1(pcols,pver,0:nbmodes)) + allocate(this_coeffs%bebc550gt1(pcols,pver,0:nbmodes)) + allocate(this_coeffs%beoc550lt1(pcols,pver,0:nbmodes)) + allocate(this_coeffs%beoc550gt1(pcols,pver,0:nbmodes)) + allocate(this_coeffs%besu550lt1(pcols,pver,0:nbmodes)) + allocate(this_coeffs%besu550gt1(pcols,pver,0:nbmodes)) + allocate(this_coeffs%backsc550(pcols,pver,0:nbmodes)) + + end subroutine allocate_coeffs + + ! ========================================================== + subroutine zero_coeffs(this, kcomp, ncol) + + class(extinction_coeffs_type) :: this + integer , intent(in) :: kcomp + integer , intent(in) :: ncol + + integer :: k + integer :: icol + + ! initialize all output fields to zero + do k=1,pver + do icol=1,ncol + this%bext440(icol,k,kcomp) = 0.0_r8 + this%babs440(icol,k,kcomp) = 0.0_r8 + this%bext500(icol,k,kcomp) = 0.0_r8 + this%babs500(icol,k,kcomp) = 0.0_r8 + this%bext550(icol,k,kcomp) = 0.0_r8 + this%babs550(icol,k,kcomp) = 0.0_r8 + this%bext670(icol,k,kcomp) = 0.0_r8 + this%babs670(icol,k,kcomp) = 0.0_r8 + this%bext870(icol,k,kcomp) = 0.0_r8 + this%babs870(icol,k,kcomp) = 0.0_r8 + this%bebg440(icol,k,kcomp) = 0.0_r8 + this%bebg500(icol,k,kcomp) = 0.0_r8 + this%bebg550(icol,k,kcomp) = 0.0_r8 + this%babg550(icol,k,kcomp) = 0.0_r8 + this%bebg670(icol,k,kcomp) = 0.0_r8 + this%bebg870(icol,k,kcomp) = 0.0_r8 + this%bebc440(icol,k,kcomp) = 0.0_r8 + this%bebc500(icol,k,kcomp) = 0.0_r8 + this%bebc550(icol,k,kcomp) = 0.0_r8 + this%babc550(icol,k,kcomp) = 0.0_r8 + this%bebc670(icol,k,kcomp) = 0.0_r8 + this%bebc870(icol,k,kcomp) = 0.0_r8 + this%beoc440(icol,k,kcomp) = 0.0_r8 + this%beoc500(icol,k,kcomp) = 0.0_r8 + this%beoc550(icol,k,kcomp) = 0.0_r8 + this%baoc550(icol,k,kcomp) = 0.0_r8 + this%beoc670(icol,k,kcomp) = 0.0_r8 + this%beoc870(icol,k,kcomp) = 0.0_r8 + this%besu440(icol,k,kcomp) = 0.0_r8 + this%besu500(icol,k,kcomp) = 0.0_r8 + this%besu550(icol,k,kcomp) = 0.0_r8 + this%basu550(icol,k,kcomp) = 0.0_r8 + this%besu670(icol,k,kcomp) = 0.0_r8 + this%besu870(icol,k,kcomp) = 0.0_r8 + this%bebg550lt1(icol,k,kcomp) = 0.0_r8 + this%bebg550gt1(icol,k,kcomp) = 0.0_r8 + this%bebc550lt1(icol,k,kcomp) = 0.0_r8 + this%bebc550gt1(icol,k,kcomp) = 0.0_r8 + this%beoc550lt1(icol,k,kcomp) = 0.0_r8 + this%beoc550gt1(icol,k,kcomp) = 0.0_r8 + this%besu550lt1(icol,k,kcomp) = 0.0_r8 + this%besu550gt1(icol,k,kcomp) = 0.0_r8 + this%backsc550(icol,k,kcomp) = 0.0_r8 + end do + end do + + end subroutine zero_coeffs + + ! ========================================================== + subroutine update_coeffs(this, icol, k, kcomp) + + class(extinction_coeffs_type) :: this + integer , intent(in) :: icol + integer , intent(in) :: k + integer , intent(in) :: kcomp + real(r8) , intent(in) :: opt(:) + + this%bext440(icol,k,kcomp) = opt(1) + this%bext500(icol,k,kcomp) = opt(2) + this%bext670(icol,k,kcomp) = opt(3) + this%bext870(icol,k,kcomp) = opt(4) + this%bebg440(icol,k,kcomp) = opt(5) + this%bebg500(icol,k,kcomp) = opt(6) + this%bebg670(icol,k,kcomp) = opt(7) + this%bebg870(icol,k,kcomp) = opt(8) + this%bebc440(icol,k,kcomp) = opt(9) + this%bebc500(icol,k,kcomp) = opt(10) + this%bebc670(icol,k,kcomp) = opt(11) + this%bebc870(icol,k,kcomp) = opt(12) + this%beoc440(icol,k,kcomp) = opt(13) + this%beoc500(icol,k,kcomp) = opt(14) + this%beoc670(icol,k,kcomp) = opt(15) + this%beoc870(icol,k,kcomp) = opt(16) + this%besu440(icol,k,kcomp) = opt(17) + this%besu500(icol,k,kcomp) = opt(18) + this%besu670(icol,k,kcomp) = opt(19) + this%besu870(icol,k,kcomp) = opt(20) + this%babs440(icol,k,kcomp) = opt(21) + this%babs500(icol,k,kcomp) = opt(22) + this%babs550(icol,k,kcomp) = opt(23) + this%babs670(icol,k,kcomp) = opt(24) + this%babs870(icol,k,kcomp) = opt(25) + this%bebg550lt1(icol,k,kcomp) = opt(26) + this%bebg550gt1(icol,k,kcomp) = opt(27) + this%bebc550lt1(icol,k,kcomp) = opt(28) + this%bebc550gt1(icol,k,kcomp) = opt(29) + this%beoc550lt1(icol,k,kcomp) = opt(30) + this%beoc550gt1(icol,k,kcomp) = opt(31) + this%besu550lt1(icol,k,kcomp) = opt(32) + this%besu550gt1(icol,k,kcomp) = opt(33) + this%backsc550(icol,k,kcomp) = opt(34) + this%babg550(icol,k,kcomp) = opt(35) + this%babc550(icol,k,kcomp) = opt(36) + this%baoc550(icol,k,kcomp) = opt(37) + this%basu550(icol,k,kcomp) = opt(38) + this%bebg550(icol,k,kcomp) = opt(26)+opt(27) + this%bebc550(icol,k,kcomp) = opt(28)+opt(29) + this%beoc550(icol,k,kcomp) = opt(30)+opt(31) + this%besu550(icol,k,kcomp) = opt(32)+opt(33) + this%bext550(icol,k,kcomp) = bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & + +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) + + end subroutine update_coeffs + + ! ========================================================== + subroutine intaeropt0 (lchnk, ncol, Nnatk, extinction_coeffs) + + ! Arguments + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + type(extinction_coeffs), intent(inout) :: extinction_coeffs + + ! Local variables + integer i, iv, ierr, k, kcomp, icol + + kcomp=0 + extinction_coeffs%zero_coeffs(kcomp, ncol) + + ! BC(ax) mode: update below to non-xero values + do k = 1,pver + do icol = 1,ncol + if(Nnatk(icol,k,kcomp).gt.0) then + bext440(icol,k,kcomp)=bex440 + babs440(icol,k,kcomp)=bax440 + bext500(icol,k,kcomp)=bex500 + babs500(icol,k,kcomp)=bax500 + bext550(icol,k,kcomp)=bex550lt1+bex550gt1 + babs550(icol,k,kcomp)=bax550 + bext670(icol,k,kcomp)=bex670 + babs670(icol,k,kcomp)=bax670 + bext870(icol,k,kcomp)=bex870 + babs870(icol,k,kcomp)=bax870 + bebg440(icol,k,kcomp)=bex440 + bebg500(icol,k,kcomp)=bex500 + bebg550(icol,k,kcomp)=bex550lt1+bex550gt1 + babg550(icol,k,kcomp)=bax550 + bebg670(icol,k,kcomp)=bex670 + bebg870(icol,k,kcomp)=bex870 + bebg550lt1(icol,k,kcomp)=bex550lt1 + bebg550gt1(icol,k,kcomp)=bex550gt1 + backsc550(icol,k,kcomp)=backscx550 + endif + end do ! icol + end do ! k + + end subroutine intaeropt0 + + ! ========================================================== + subroutine intaeropt1 (lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & + extinction_coeffs) + + ! arguments + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer , intent(in) :: irh1(pcols,pver) + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode + integer , intent(in) :: ifombg1(pcols,pver) + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + type(extinction_coeffs) , intent(inout) :: extinction_coeffs + + ! local variables + real(r8) :: a, b, e, eps + integer :: i, iv, ierr, irelh, ifombg, ictot, ifac, kcomp, k, icol, kc10 + ! Temporary storage of often used array elements + integer :: t_irh1, t_irh2, t_ifo1, t_ifo2, t_ict1, t_ict2, t_ifc1, t_ifc2 + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_xrh, t_rh1, t_rh2, t_fombg1, t_fombg2, t_xfombg + real(r8) :: t_xct, t_cat1, t_cat2 + real(r8) :: d2mx(4), dxm1(4), invd(4) + real(r8) :: opt4d(2,2,2,2) + real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) :: opt1, opt2, opt(38) + + parameter :: (e=2.718281828_r8, eps=1.0e-60_r8) + + ! SO4/SOA(Ait) mode: + kcomp = 1 + extinction_coeffs%zero_coeffs(kcomp, ncol) + + if(mplus10 == 0) then + kc10 = kcomp + else + write(*,*) "mplus10=1 is no loger an option for kcomp=1." + stop + endif + + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kc10).gt.0) then + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ifo1 = ifombg1(icol,k) + t_ifo2 = t_ifo1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_fombg1 = fombg(t_ifo1) + t_fombg2 = fombg(t_ifo2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + t_xfombg = xfombg(icol,k) + + ! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fombg2-t_xfombg) + dxm1(2) = (t_xfombg-t_fombg1) + invd(2) = 1.0_r8/(t_fombg2-t_fombg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + + do iv=1,38 ! variable number + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1) = bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2) = bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1) = bep1(iv,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2) = bep1(iv,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1) = bep1(iv,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2) = bep1(iv,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1) = bep1(iv,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2) = bep1(iv,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1) = bep1(iv,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2) = bep1(iv,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1) = bep1(iv,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2) = bep1(iv,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1) = bep1(iv,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2) = bep1(iv,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1) = bep1(iv,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2) = bep1(iv,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) + + ! finally, interpolation in the rh dimension + opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) / (t_rh2-t_rh1) + end do ! iv=1,38 + + ! determin extinction coefficient + extinction_coeffs%update_coeffs(icol, k, kcomp, opt) + + end if + end do ! end of icol loop + end do ! end of k loop + + end subroutine intaeropt1 + + ! ========================================================== + subroutine intaeropt2to3 (lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, extinction_coeffs) + + ! Extended by Alf Kirkevaag to include SOA in September 2015 + + ! Arguments + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer , intent(in) :: irh1(pcols,pver) + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + + ! Local variables + real(r8) :: a, b, e, eps + integer :: i, iv, kcomp, k, icol, kc10 + ! Temporary storage of often used array elements + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 + real(r8) :: t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 + real(r8) :: d2mx(3), dxm1(3), invd(3) + real(r8) :: opt3d(2,2,2) + real(r8) :: opt1, opt2, opt(38) + + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! SO4(Ait), BC(Ait) and OC(Ait) modes: + + do kcomp=2,3 + extinction_coeffs%zero_coeffs(kcomp, ncol) + end do + + kcomp = 2 ! kcomp=3 is no longer used + do k=1,pver + do icol=1,ncol + + if(Nnatk(icol,k,kc10).gt.0) then + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + + ! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + + do iv=1,38 ! variable number + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=bep2to3(iv,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=bep2to3(iv,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=bep2to3(iv,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=bep2to3(iv,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=bep2to3(iv,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=bep2to3(iv,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=bep2to3(iv,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=bep2to3(iv,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, opt1, opt2) + + ! finally, interpolation in the rh dimension + opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + + end do ! iv=1,38 + + ! determine extinction coefficient + extinction_coeffs%update_coeffs(icol, k, kcomp, opt) + + end if ! Nnatk > 0 + end do ! icol + end do ! k + + end subroutine intaeropt2to3 + + ! ========================================================== + subroutine intaeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & + extinction_coeffs) + + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer , intent(in) :: irh1(pcols,pver) + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xfbcbg(pcols,pver) + integer , intent(in) :: ifbcbg1(pcols,pver) + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer , intent(in) :: ifaq1(pcols,pver,nbmodes) + type(extinction_coeffs), intent(inout) :: extinction_coeffs + + ! Local variables + real(r8) :: a, b, e, eps + integer :: i, iv, kcomp, k, icol, kc10 + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 + real(r8) :: t_fbcbg1, t_fbcbg2 + integer :: t_ifb1, t_ifb2 + real(r8) :: t_faq1, t_faq2, t_xfaq + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 + real(r8) :: t_cat1, t_cat2 + real(r8) :: t_xfbcbg + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: opt1, opt2, opt(38) + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! BC&OC(Ait) mode: + kcomp = 4 + extinction_coeffs%zero_coeffs(kcomp, ncol) + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kc10).gt.0) then + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ifb1 = ifbcbg1(icol,k) + t_ifb2 = t_ifb1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xfbcbg = xfbcbg(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fbcbg2-t_xfbcbg) + dxm1(2) = (t_xfbcbg-t_fbcbg1) + invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + do iv=1,38 ! variable number + + opt5d(1,1,1,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) + + ! finally, interpolation in the rh dimension + opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + + end do ! iv=1,38 + + ! determine extinction coefficient + extinction_coeffs%update_coeffs(icol, k, kcomp, opt) + + end if ! Nnatk > 0 + end do ! icol + end do ! k + + end subroutine intaeropt4 + + ! ========================================================== + subroutine intaeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + extinction_coeffs) + + ! Arguments + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer , intent(in) :: irh1(pcols,pver) + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) + integer , intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer , intent(in) :: ifaq1(pcols,pver,nbmodes) + + ! Local variables + real(r8) :: a, b, e, eps + integer :: i, iv, kcomp, k, icol + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 + integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) :: t_faq1, t_faq2, t_xfaq + real(r8) :: t_fbc1, t_fbc2, t_xfbc + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 + real(r8) :: t_cat1, t_cat2 + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: opt1, opt2, opt(38) + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): + + do kcomp=5,10 + ! zero extinction coefficients for this kcomp + extinction_coeffs%zero_coeffs(kcomp, ncol) + + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kcomp).gt.0) then + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + t_ifb1 = ifbc1(icol,k,kcomp) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cat(kcomp,t_ict1) + t_cat2 = cat(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbc1 = fbc(t_ifb1) + t_fbc2 = fbc(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfbc = xfbc(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + d2mx(4) = (t_fbc2-t_xfbc) + dxm1(4) = (t_xfbc-t_fbc1) + invd(4) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + do iv=1,38 ! variable number + opt5d(1,1,1,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) + + ! finally, interpolation in the rh dimension + opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + + end do ! iv=1,38 + + ! determine extinction coefficient + extinction_coeffs%update_coeffs(icol, k, kcomp, opt) + + end if ! Nnatk > 0 + end do ! icol + end do ! k + end do ! kcomp + + end subroutine intaeropt5to10 + +end module update_aeropt_mod + From 878f79e2d96e305ad3fb32e1f4f56b45937d2e2c Mon Sep 17 00:00:00 2001 From: mvertens Date: Sat, 12 Aug 2023 12:54:28 +0200 Subject: [PATCH 02/71] intermediate mods --- src/physics/cam_oslo/aerocopt.h | 8 - src/physics/cam_oslo/aerocopt2.h | 9 - src/physics/cam_oslo/aerodry_mod.F90 | 420 +++++++ src/physics/cam_oslo/aeropt_mod.F90 | 1281 +++++++++++++++++++ src/physics/cam_oslo/init_aeropt_mod.F90 | 608 ++++++---- src/physics/cam_oslo/initaeropt.F90 | 581 --------- src/physics/cam_oslo/initdryp.F90 | 839 ++++++------- src/physics/cam_oslo/intaeropt0.F90 | 207 ---- src/physics/cam_oslo/intaeropt1.F90 | 317 ----- src/physics/cam_oslo/intaeropt2to3.F90 | 299 ----- src/physics/cam_oslo/intaeropt4.F90 | 339 ------ src/physics/cam_oslo/intaeropt5to10.F90 | 334 ----- src/physics/cam_oslo/interp_aeropt_mod.F90 | 1282 ++++++++++++++++++++ src/physics/cam_oslo/update_aeropt_mod.F90 | 138 +-- 14 files changed, 3815 insertions(+), 2847 deletions(-) delete mode 100644 src/physics/cam_oslo/aerocopt.h delete mode 100644 src/physics/cam_oslo/aerocopt2.h create mode 100644 src/physics/cam_oslo/aerodry_mod.F90 create mode 100644 src/physics/cam_oslo/aeropt_mod.F90 delete mode 100644 src/physics/cam_oslo/initaeropt.F90 delete mode 100644 src/physics/cam_oslo/intaeropt0.F90 delete mode 100644 src/physics/cam_oslo/intaeropt1.F90 delete mode 100644 src/physics/cam_oslo/intaeropt2to3.F90 delete mode 100644 src/physics/cam_oslo/intaeropt4.F90 delete mode 100644 src/physics/cam_oslo/intaeropt5to10.F90 create mode 100644 src/physics/cam_oslo/interp_aeropt_mod.F90 diff --git a/src/physics/cam_oslo/aerocopt.h b/src/physics/cam_oslo/aerocopt.h deleted file mode 100644 index bc48cfbe37..0000000000 --- a/src/physics/cam_oslo/aerocopt.h +++ /dev/null @@ -1,8 +0,0 @@ -! For subroutines initaeropt and intaeropt1to3,4,6to10: - - common /aerocopt1/ bep1, bep2to3, bep4, bep5to10 - - real(r8) bep1(38,10,6,16,6) - real(r8) bep2to3(38,10,16,6,2:3) - real(r8) bep4(38,10,6,16,6,6) - real(r8) bep5to10(38,10,6,6,6,6,5:10) diff --git a/src/physics/cam_oslo/aerocopt2.h b/src/physics/cam_oslo/aerocopt2.h deleted file mode 100644 index 7272b9e2d0..0000000000 --- a/src/physics/cam_oslo/aerocopt2.h +++ /dev/null @@ -1,9 +0,0 @@ -! For subroutines initaeropt and intaeropt0: - - common /aerocopt2/ bex440, bax440, bex500, bax500, bax550, & - bex670, bax670, bex870, bax870, & - bex550lt1, bex550gt1, backscx550 - - real(r8) bex440, bax440, bex500, bax500, bax550, & - bex670, bax670, bex870, bax870, & - bex550lt1, bex550gt1, backscx550 diff --git a/src/physics/cam_oslo/aerodry_mod.F90 b/src/physics/cam_oslo/aerodry_mod.F90 new file mode 100644 index 0000000000..bd90052867 --- /dev/null +++ b/src/physics/cam_oslo/aerodry_mod.F90 @@ -0,0 +1,420 @@ +module aero_dry + + use shr_kind_mod, only: r8 => shr_kind_r8 + use oslo_control, only: oslo_getopts, dir_string_length + use commondefinitions, only: nmodes, nbmodes + use opttab, only: cate, cat, fac, faq, fbc, fombg, fbcbg + use cam_logfile, only: iulog + + implicit none + private + + ! For subroutine initdryp and intdrypar: + + real(r8) :: a0cintbg, a0cintbg05, a0cintbg125 + real(r8) :: a0aaeros, a0aaerol, a0vaeros, a0vaerol + real(r8) :: a1var(19,6,16,6) + real(r8) :: a2to3var(19,16,6,2:3) + real(r8) :: a4var(19,6,16,6,6) + real(r8) :: a5to10var(19,6,6,6,6,5:10) + +contains + + subroutine initdryp + + !Purpose: To read in the AeroCom look-up tables for calculation of dry + ! aerosol size and mass distribution properties. The grid for discrete + ! input-values in the look-up tables is defined in opptab. + + ! Tabulating the 'aerodryk'-files to save computing time. Routine + ! originally made by Alf Kirkevaag, and modified for new aerosol + ! schemes in January 2006. + ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, + ! May 2013, and extended for new SOA treatment October 2015. + ! Modified for optimized added masses and mass fractions for + ! concentrations from condensation, coagulation or cloud-processing + ! - Alf Kirkevaag, May 2016. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + + + + integer :: iv, kcomp, ifombg, ifbcbg, ictot, ifac, ifbc, ifaq + integer :: ic, ifil, lin + real(r8) :: frombg, frbcbg, catot, frac, fabc, fraq + real(r8) :: cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125 + real(r8) :: cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125 + real(r8) :: cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 + character(len=dir_string_length) :: aerotab_table_dir + + call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + + open(11,file=trim(aerotab_table_dir)//'/aerodryk2.out' ,form='formatted',status='old') + open(12,file=trim(aerotab_table_dir)//'/aerodryk3.out' ,form='formatted',status='old') + open(13,file=trim(aerotab_table_dir)//'/aerodryk4.out' ,form='formatted',status='old') + open(14,file=trim(aerotab_table_dir)//'/aerodryk5.out' ,form='formatted',status='old') + open(15,file=trim(aerotab_table_dir)//'/aerodryk6.out' ,form='formatted',status='old') + open(16,file=trim(aerotab_table_dir)//'/aerodryk7.out' ,form='formatted',status='old') + open(17,file=trim(aerotab_table_dir)//'/aerodryk8.out' ,form='formatted',status='old') + open(18,file=trim(aerotab_table_dir)//'/aerodryk9.out' ,form='formatted',status='old') + open(19,file=trim(aerotab_table_dir)//'/aerodryk10.out' ,form='formatted',status='old') + open(20,file=trim(aerotab_table_dir)//'/aerodryk0.out' ,form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/aerodryk1.out' ,form='formatted',status='old') + + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 11,21 + call checkTableHeader (ifil) + enddo + ! + ! Mode 0, BC(ax) + ! + ifil = 11 + read(9+ifil,996) kcomp, cintbg, cintbg05, cintbg125, aaeros, aaerol, vaeros, vaerol + + ! no ictot-, ifac-, ifbc- or ifaq-dependency for this mode, + ! since BC(ax) is purely externally mixed + a0cintbg=cintbg + a0cintbg05=cintbg05 + a0cintbg125=cintbg125 + a0aaeros=aaeros + a0aaerol=aaerol + a0vaeros=vaeros + a0vaerol=vaerol + write(iulog,*)'mode 0 ok' + + ! + ! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) + ! + ifil = 1 + do lin = 1,576 ! 6x16x6 + + read(20+ifil,997) kcomp, frombg, catot, frac, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + + do ic=1,6 + if(abs(frombg-fombg(ic)) shr_kind_r8 + use ppgrid , only : pcols, pver + use commondefinitions , only : nmodes, nbmodes + use opttab , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg + use oslo_control , only : oslo_getopts, dir_string_length + use cam_logfile , only : iulog + + implicit none + private + + ! Set by init_aeropt Mode0 + real(r8) :: bex440, bax440 + real(r8) :: bex500, bax500, bax550 + real(r8) :: bex670, bax670, + real(r8) :: bex870, bax870 + real(r8) :: bex550lt1, bex550gt1, backscx550 + + ! Set by init_aeropt Mode1 + real(r8), public :: bep1(38,10,6,16,6) + + ! Set by init_aeropt Mode2to3 + real(r8), public :: bep2to3 (38,10,16,6,2:3) + + ! Set by init_aeropt Mode4 + real(r8), public :: bep4(38,10,6,16,6,6) + + ! Set by init_aeropt Mode5to10 + real(r8), public :: bep5to10(38,10,6,6,6,6,5:10) + + ! Modal total and absorption extiction coefficients (for AeroCom) + ! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). + ! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). + type, public :: extinction_coeffs_type + real(r8) :: bext440(pcols,pver,0:nbmodes) + real(r8) :: babs440(pcols,pver,0:nbmodes) + real(r8) :: bext500(pcols,pver,0:nbmodes) + real(r8) :: babs500(pcols,pver,0:nbmodes) + real(r8) :: bext550(pcols,pver,0:nbmodes) + real(r8) :: babs550(pcols,pver,0:nbmodes) + real(r8) :: bext670(pcols,pver,0:nbmodes) + real(r8) :: babs670(pcols,pver,0:nbmodes) + real(r8) :: bext870(pcols,pver,0:nbmodes) + real(r8) :: babs870(pcols,pver,0:nbmodes) + real(r8) :: bebg440(pcols,pver,0:nbmodes) + real(r8) :: bebg500(pcols,pver,0:nbmodes) + real(r8) :: bebg550(pcols,pver,0:nbmodes) + real(r8) :: babg550(pcols,pver,0:nbmodes) + real(r8) :: bebg670(pcols,pver,0:nbmodes) + real(r8) :: bebg870(pcols,pver,0:nbmodes) + real(r8) :: bebc440(pcols,pver,0:nbmodes) + real(r8) :: bebc500(pcols,pver,0:nbmodes) + real(r8) :: bebc550(pcols,pver,0:nbmodes) + real(r8) :: babc550(pcols,pver,0:nbmodes) + real(r8) :: bebc670(pcols,pver,0:nbmodes) + real(r8) :: bebc870(pcols,pver,0:nbmodes) + real(r8) :: beoc440(pcols,pver,0:nbmodes) + real(r8) :: beoc500(pcols,pver,0:nbmodes) + real(r8) :: beoc550(pcols,pver,0:nbmodes) + real(r8) :: baoc550(pcols,pver,0:nbmodes) + real(r8) :: beoc670(pcols,pver,0:nbmodes) + real(r8) :: beoc870(pcols,pver,0:nbmodes) + real(r8) :: besu440(pcols,pver,0:nbmodes) + real(r8) :: besu500(pcols,pver,0:nbmodes) + real(r8) :: besu550(pcols,pver,0:nbmodes) + real(r8) :: basu550(pcols,pver,0:nbmodes) + real(r8) :: besu670(pcols,pver,0:nbmodes) + real(r8) :: besu870(pcols,pver,0:nbmodes) + real(r8) :: bebg550lt1(pcols,pver,0:nbmodes) + real(r8) :: bebg550gt1(pcols,pver,0:nbmodes) + real(r8) :: bebc550lt1(pcols,pver,0:nbmodes) + real(r8) :: bebc550gt1(pcols,pver,0:nbmodes) + real(r8) :: beoc550lt1(pcols,pver,0:nbmodes) + real(r8) :: beoc550gt1(pcols,pver,0:nbmodes) + real(r8) :: besu550lt1(pcols,pver,0:nbmodes) + real(r8) :: besu550gt1(pcols,pver,0:nbmodes) + real(r8) :: backsc550(pcols,pver,0:nbmodes) + + contains + procedure :: zero_coeffs + procedure :: update_coeffs + end type extinction_coeffs_type + + type(extinction_coeffs_type), public :: extinction_coeffs + type(extinction_coeffs_type), public :: extinction_coeffsn + + public :: init_aeropt + public :: update_aeropt0 + public :: update_aeropt1 + public :: update_aeropt2to3 + public :: update_aeropt4 + public :: update_aeropt5to10 + +! ========================================================== +contains +! ========================================================== + + subroutine init_aeropt + + !Purpose: To read in the AeroCom look-up tables for aerosol optical properties. + ! The grid for discrete input-values in the look-up tables is defined in opptab. + + ! Tabulating the 'aerocomk'-files to save computing time. + ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 + ! Extended for new SOA treatment - Alf Kirkevaag, September 2015. + ! Modified for optimized added masses and mass fractions for + ! concentrations from condensation, coagulation or cloud-processing + ! - Alf Kirkevaag, May 2016. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + + integer :: ic, ifil, lin, iv + integer :: kcomp, irelh, ictot, ifac, ifbc, ifaq + integer :: ifombg, ifbcbg + real(r8) :: catot, relh, frbcbg, frac, fabc, fraq + real(r8) :: bext440, babs440, bext500, babs500, babs550 + real(r8) :: bext670, babs670, bext870, babs870 + real(r8) :: bebg440, babg440, bebg500, babg500, babg550 + real(r8) :: bebg670, babg670, bebg870, babg870 + real(r8) :: bebc440, babc440, bebc500, babc500, babc550 + real(r8) :: bebc670, babc670, bebc870, babc870 + real(r8) :: beoc440, baoc440, beoc500, baoc500, baoc550 + real(r8) :: beoc670, baoc670, beoc870, baoc870 + real(r8) :: besu440, basu440, besu500, basu500, basu550 + real(r8) :: besu670, basu670, besu870, basu870 + real(r8) :: bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1 + real(r8) :: beoc550lt1, beoc550gt1, besu550lt1, besu550gt1 + real(r8) :: backscat550 + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 + character(len=dir_string_length) :: aerotab_table_dir + !----------------------------------------------------------- + + call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + + open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' , form='formatted',status='old') + open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' , form='formatted',status='old') + open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' , form='formatted',status='old') + open(14,file=trim(aerotab_table_dir)//'/aerocomk5.out' , form='formatted',status='old') + open(15,file=trim(aerotab_table_dir)//'/aerocomk6.out' , form='formatted',status='old') + open(16,file=trim(aerotab_table_dir)//'/aerocomk7.out' , form='formatted',status='old') + open(17,file=trim(aerotab_table_dir)//'/aerocomk8.out' , form='formatted',status='old') + open(18,file=trim(aerotab_table_dir)//'/aerocomk9.out' , form='formatted',status='old') + open(19,file=trim(aerotab_table_dir)//'/aerocomk10.out', form='formatted',status='old') + open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' , form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' , form='formatted',status='old') + + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 11,21 + call checkTableHeader (ifil) + enddo + ! + !------------------------------------------- + ! Mode 0, BC(ax + !------------------------------------------- + ! + read(20,'(I2,f6.3,12e11.4)') & + kcomp, relh, & + bex440, bax440, bex500, bax500, bax550, bex670, bax670, & + bex870, bax870, bex550lt1, bex550gt1, backscx550 + + if(bex440<=0.0_r8) then + write(*,*) 'bex440 =', bex440 + write(*,*) 'Error in initialization of bex1' + stop + endif + write(iulog,*)'aerocom mode 0 ok' + ! + !------------------------------------------- + ! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) + !------------------------------------------- + ! + do lin = 1,5760 ! 10x6x16x6 + read(21,'(I2,f6.3,3e10.3,38e10.3)') & + kcomp, relh, frombg, catot, frac, & + bext440, bext500, bext670, bext870, & + bebg440, bebg500, bebg670, bebg870, & + bebc440, bebc500, bebc670, bebc870, & + beoc440, beoc500, beoc670, beoc870, & + besu440, besu500, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backscat550, babg550, babc550, baoc550, basu550 + + do ic=1,10 + if(abs(relh-rh(ic)) 0 + end do ! icol + end do ! k + + end subroutine update_aeropt2to3 + + ! ========================================================== + subroutine update_aeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & + extinction_coeffs) + + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer , intent(in) :: irh1(pcols,pver) + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xfbcbg(pcols,pver) + integer , intent(in) :: ifbcbg1(pcols,pver) + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer , intent(in) :: ifaq1(pcols,pver,nbmodes) + type(extinction_coeffs), intent(inout) :: extinction_coeffs + + ! Local variables + real(r8) :: a, b, e, eps + integer :: i, iv, kcomp, k, icol, kc10 + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 + real(r8) :: t_fbcbg1, t_fbcbg2 + integer :: t_ifb1, t_ifb2 + real(r8) :: t_faq1, t_faq2, t_xfaq + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 + real(r8) :: t_cat1, t_cat2 + real(r8) :: t_xfbcbg + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: opt1, opt2, opt(38) + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! BC&OC(Ait) mode: + kcomp = 4 + extinction_coeffs%zero_coeffs(kcomp, ncol) + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kc10).gt.0) then + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ifb1 = ifbcbg1(icol,k) + t_ifb2 = t_ifb1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xfbcbg = xfbcbg(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fbcbg2-t_xfbcbg) + dxm1(2) = (t_xfbcbg-t_fbcbg1) + invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + do iv=1,38 ! variable number + + opt5d(1,1,1,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) + + ! finally, interpolation in the rh dimension + opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + + end do ! iv=1,38 + + ! determine extinction coefficient + extinction_coeffs%update_coeffs(icol, k, kcomp, opt) + + end if ! Nnatk > 0 + end do ! icol + end do ! k + + end subroutine update_aeropt4 + + ! ========================================================== + subroutine update_aeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + extinction_coeffs) + + ! Arguments + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer , intent(in) :: irh1(pcols,pver) + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) + integer , intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer , intent(in) :: ifaq1(pcols,pver,nbmodes) + + ! Local variables + real(r8) :: a, b, e, eps + integer :: i, iv, kcomp, k, icol + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 + integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) :: t_faq1, t_faq2, t_xfaq + real(r8) :: t_fbc1, t_fbc2, t_xfbc + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 + real(r8) :: t_cat1, t_cat2 + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: opt1, opt2, opt(38) + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): + + do kcomp=5,10 + ! zero extinction coefficients for this kcomp + extinction_coeffs%zero_coeffs(kcomp, ncol) + + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kcomp).gt.0) then + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + t_ifb1 = ifbc1(icol,k,kcomp) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cat(kcomp,t_ict1) + t_cat2 = cat(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbc1 = fbc(t_ifb1) + t_fbc2 = fbc(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfbc = xfbc(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + d2mx(4) = (t_fbc2-t_xfbc) + dxm1(4) = (t_xfbc-t_fbc1) + invd(4) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + do iv=1,38 ! variable number + opt5d(1,1,1,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) + + ! finally, interpolation in the rh dimension + opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + + end do ! iv=1,38 + + ! determine extinction coefficient + extinction_coeffs%update_coeffs(icol, k, kcomp, opt) + + end if ! Nnatk > 0 + end do ! icol + end do ! k + end do ! kcomp + + end subroutine update_aeropt5to10 + + ! ========================================================== + subroutine zero_coeffs(this, kcomp, ncol) + + class(extinction_coeffs_type) :: this + integer , intent(in) :: kcomp + integer , intent(in) :: ncol + + integer :: k + integer :: icol + + ! initialize all output fields to zero + do k=1,pver + do icol=1,ncol + this%bext440(icol,k,kcomp) = 0.0_r8 + this%babs440(icol,k,kcomp) = 0.0_r8 + this%bext500(icol,k,kcomp) = 0.0_r8 + this%babs500(icol,k,kcomp) = 0.0_r8 + this%bext550(icol,k,kcomp) = 0.0_r8 + this%babs550(icol,k,kcomp) = 0.0_r8 + this%bext670(icol,k,kcomp) = 0.0_r8 + this%babs670(icol,k,kcomp) = 0.0_r8 + this%bext870(icol,k,kcomp) = 0.0_r8 + this%babs870(icol,k,kcomp) = 0.0_r8 + this%bebg440(icol,k,kcomp) = 0.0_r8 + this%bebg500(icol,k,kcomp) = 0.0_r8 + this%bebg550(icol,k,kcomp) = 0.0_r8 + this%babg550(icol,k,kcomp) = 0.0_r8 + this%bebg670(icol,k,kcomp) = 0.0_r8 + this%bebg870(icol,k,kcomp) = 0.0_r8 + this%bebc440(icol,k,kcomp) = 0.0_r8 + this%bebc500(icol,k,kcomp) = 0.0_r8 + this%bebc550(icol,k,kcomp) = 0.0_r8 + this%babc550(icol,k,kcomp) = 0.0_r8 + this%bebc670(icol,k,kcomp) = 0.0_r8 + this%bebc870(icol,k,kcomp) = 0.0_r8 + this%beoc440(icol,k,kcomp) = 0.0_r8 + this%beoc500(icol,k,kcomp) = 0.0_r8 + this%beoc550(icol,k,kcomp) = 0.0_r8 + this%baoc550(icol,k,kcomp) = 0.0_r8 + this%beoc670(icol,k,kcomp) = 0.0_r8 + this%beoc870(icol,k,kcomp) = 0.0_r8 + this%besu440(icol,k,kcomp) = 0.0_r8 + this%besu500(icol,k,kcomp) = 0.0_r8 + this%besu550(icol,k,kcomp) = 0.0_r8 + this%basu550(icol,k,kcomp) = 0.0_r8 + this%besu670(icol,k,kcomp) = 0.0_r8 + this%besu870(icol,k,kcomp) = 0.0_r8 + this%bebg550lt1(icol,k,kcomp) = 0.0_r8 + this%bebg550gt1(icol,k,kcomp) = 0.0_r8 + this%bebc550lt1(icol,k,kcomp) = 0.0_r8 + this%bebc550gt1(icol,k,kcomp) = 0.0_r8 + this%beoc550lt1(icol,k,kcomp) = 0.0_r8 + this%beoc550gt1(icol,k,kcomp) = 0.0_r8 + this%besu550lt1(icol,k,kcomp) = 0.0_r8 + this%besu550gt1(icol,k,kcomp) = 0.0_r8 + this%backsc550(icol,k,kcomp) = 0.0_r8 + end do + end do + + end subroutine zero_coeffs + + ! ========================================================== + subroutine update_coeffs(this, icol, k, kcomp) + + class(extinction_coeffs_type) :: this + integer , intent(in) :: icol + integer , intent(in) :: k + integer , intent(in) :: kcomp + real(r8) , intent(in) :: opt(:) + + this%bext440(icol,k,kcomp) = opt(1) + this%bext500(icol,k,kcomp) = opt(2) + this%bext670(icol,k,kcomp) = opt(3) + this%bext870(icol,k,kcomp) = opt(4) + this%bebg440(icol,k,kcomp) = opt(5) + this%bebg500(icol,k,kcomp) = opt(6) + this%bebg670(icol,k,kcomp) = opt(7) + this%bebg870(icol,k,kcomp) = opt(8) + this%bebc440(icol,k,kcomp) = opt(9) + this%bebc500(icol,k,kcomp) = opt(10) + this%bebc670(icol,k,kcomp) = opt(11) + this%bebc870(icol,k,kcomp) = opt(12) + this%beoc440(icol,k,kcomp) = opt(13) + this%beoc500(icol,k,kcomp) = opt(14) + this%beoc670(icol,k,kcomp) = opt(15) + this%beoc870(icol,k,kcomp) = opt(16) + this%besu440(icol,k,kcomp) = opt(17) + this%besu500(icol,k,kcomp) = opt(18) + this%besu670(icol,k,kcomp) = opt(19) + this%besu870(icol,k,kcomp) = opt(20) + this%babs440(icol,k,kcomp) = opt(21) + this%babs500(icol,k,kcomp) = opt(22) + this%babs550(icol,k,kcomp) = opt(23) + this%babs670(icol,k,kcomp) = opt(24) + this%babs870(icol,k,kcomp) = opt(25) + this%bebg550lt1(icol,k,kcomp) = opt(26) + this%bebg550gt1(icol,k,kcomp) = opt(27) + this%bebc550lt1(icol,k,kcomp) = opt(28) + this%bebc550gt1(icol,k,kcomp) = opt(29) + this%beoc550lt1(icol,k,kcomp) = opt(30) + this%beoc550gt1(icol,k,kcomp) = opt(31) + this%besu550lt1(icol,k,kcomp) = opt(32) + this%besu550gt1(icol,k,kcomp) = opt(33) + this%backsc550(icol,k,kcomp) = opt(34) + this%babg550(icol,k,kcomp) = opt(35) + this%babc550(icol,k,kcomp) = opt(36) + this%baoc550(icol,k,kcomp) = opt(37) + this%basu550(icol,k,kcomp) = opt(38) + this%bebg550(icol,k,kcomp) = opt(26)+opt(27) + this%bebc550(icol,k,kcomp) = opt(28)+opt(29) + this%beoc550(icol,k,kcomp) = opt(30)+opt(31) + this%besu550(icol,k,kcomp) = opt(32)+opt(33) + this%bext550(icol,k,kcomp) = bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & + +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) + end subroutine update_coeffs + +end module aeropt_mod + diff --git a/src/physics/cam_oslo/init_aeropt_mod.F90 b/src/physics/cam_oslo/init_aeropt_mod.F90 index 77751892d9..2e6a634957 100644 --- a/src/physics/cam_oslo/init_aeropt_mod.F90 +++ b/src/physics/cam_oslo/init_aeropt_mod.F90 @@ -1,4 +1,4 @@ -module aeropt_mod +module init_aeropt_mod use shr_kind_mod , only: r8 => shr_kind_r8 use oslo_control , only: oslo_getopts, dir_string_length @@ -9,43 +9,54 @@ module aeropt_mod implicit none private - real(r8), public :: bep1 (38,10, 6, 16, 6 ) - real(r8), public :: bep2to3 (38,10,16, 6, 2:3 ) - real(r8), public :: bep4 (38,10, 6, 16,6, 6 ) - real(r8), public :: bep5to10(38,10, 6, 6,6, 6, 5:10) + real(r8), public :: bep1 (38, 10, 6, 16, 6 ) + real(r8), public :: bep2to3 (38, 10, 16, 6, 2:3 ) + real(r8), public :: bep4 (38, 10, 6, 16, 6, 6) + real(r8), public :: bep5to10(38, 10, 6, 6, 6, 6, 5:10) - ! for initaeropt and intaeropt0: - real(r8) , public:: bex440, bax440, bex500, bax500, bax550 - real(r8) , public:: bex670, bax670, bex870, bax870 - real(r8) , public:: bex550lt1, bex550gt1, backscx550 - - public :: initaeropt - private :: set_data + public :: init_aeropt contains - subroutine initaeropt() + subroutine init_aeropt !Purpose: To read in the AeroCom look-up tables for aerosol optical properties. - ! The grid for discrete input-values in the look-up tables is defined in opptab. - ! Tabulating the 'aerocomk'-files to save computing time. - ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 - ! Extended for new SOA treatment - Alf Kirkevaag, September 2015. - ! Modified for optimized added masses and mass fractions for - ! concentrations from condensation, coagulation or cloud-processing - ! - Alf Kirkevaag, May 2016. - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + ! The grid for discrete input-values in the look-up tables is defined in opptab. + + ! Tabulating the 'aerocomk'-files to save computing time. + ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 + ! Extended for new SOA treatment - Alf Kirkevaag, September 2015. + ! Modified for optimized added masses and mass fractions for + ! concentrations from condensation, coagulation or cloud-processing + ! - Alf Kirkevaag, May 2016. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - ! local variables + integer :: ic, ifil, lin, iv integer :: kcomp, irelh, ictot, ifac, ifbc, ifaq integer :: ifombg, ifbcbg - integer :: ic, ifil, lin, iv + real(r8) :: catot, relh, frbcbg, frac, fabc, fraq + real(r8) :: bext440, babs440, bext500, babs500, babs550 + real(r8) :: bext670, babs670, bext870, babs870 + real(r8) :: bebg440, babg440, bebg500, babg500, babg550 + real(r8) :: bebg670, babg670, bebg870, babg870 + real(r8) :: bebc440, babc440, bebc500, babc500, babc550 + real(r8) :: bebc670, babc670, bebc870, babc870 + real(r8) :: beoc440, baoc440, beoc500, baoc500, baoc550 + real(r8) :: beoc670, baoc670, beoc870, baoc870 + real(r8) :: besu440, basu440, besu500, basu500, basu550 + real(r8) :: besu670, basu670, besu870, basu870 + real(r8) :: bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1 + real(r8) :: beoc550lt1, beoc550gt1, besu550lt1, besu550gt1 + real(r8) :: backscat550 + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 character(len=dir_string_length) :: aerotab_table_dir - !----------------------------------------------------- + !----------------------------------------------------------- call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) - open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' , form='formatted',status='old') open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' , form='formatted',status='old') open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' , form='formatted',status='old') @@ -67,13 +78,12 @@ subroutine initaeropt() ! Mode 0, BC(ax !------------------------------------------- ! - ifil = 11 - read (9+ifil,996) kcomp, relh, & + read(20,'(I2,f6.3,12e11.4)') & + kcomp, relh, & bex440, bax440, bex500, bax500, bax550, bex670, bax670, & bex870, bax870, bex550lt1, bex550gt1, backscx550 -996 format(I2,f6.3,12e11.4) - if (bex440<=0.0_r8) then + if(bex440<=0.0_r8) then write(*,*) 'bex440 =', bex440 write(*,*) 'Error in initialization of bex1' stop @@ -84,9 +94,82 @@ subroutine initaeropt() ! New mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) !------------------------------------------- ! - ifil = 1 do lin = 1,5760 ! 10x6x16x6 - call set_data(format_index=997, file_index=20+ifil, bep=bep1, mode1=.true.) + read(21,'(I2,f6.3,3e10.3,38e10.3)') & + kcomp, relh, frombg, catot, frac, & + bext440, bext500, bext670, bext870, & + bebg440, bebg500, bebg670, bebg870, & + bebc440, bebc500, bebc670, bebc870, & + beoc440, beoc500, beoc670, beoc870, & + besu440, besu500, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backscat550, babg550, babc550, baoc550, basu550 + + do ic=1,10 + if(abs(relh-rh(ic)) shr_kind_r8 - use commondefinitions, only: nmodes, nbmodes - use opttab, only: cate, cat, fac, faq, fbc, rh, fombg, fbcbg - use cam_logfile, only: iulog - - implicit none - -#include -#include - - integer kcomp, irelh, ictot, ifac, ifbc, ifaq - integer ifombg, ifbcbg - integer ic, ifil, lin, iv - real(r8) catot, relh, frombg, frbcbg, frac, fabc, fraq, & - bext440, babs440, bext500, babs500, babs550, & - bext670, babs670, bext870, babs870, & - bebg440, babg440, bebg500, babg500, babg550, & - bebg670, babg670, bebg870, babg870, & - bebc440, babc440, bebc500, babc500, babc550, & - bebc670, babc670, bebc870, babc870, & - beoc440, baoc440, beoc500, baoc500, baoc550, & - beoc670, baoc670, beoc870, baoc870, & - besu440, basu440, besu500, basu500, basu550, & - besu670, basu670, besu870, basu870, & - bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & - beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & - backscat550 - - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - real(r8) :: eps7 = 1.e-7_r8 - - character(len=dir_string_length) :: aerotab_table_dir - - call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' & - ,form='formatted',status='old') - open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' & - ,form='formatted',status='old') - open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' & - ,form='formatted',status='old') - open(14,file=trim(aerotab_table_dir)//'/aerocomk5.out' & - ,form='formatted',status='old') - open(15,file=trim(aerotab_table_dir)//'/aerocomk6.out' & - ,form='formatted',status='old') - open(16,file=trim(aerotab_table_dir)//'/aerocomk7.out' & - ,form='formatted',status='old') - open(17,file=trim(aerotab_table_dir)//'/aerocomk8.out' & - ,form='formatted',status='old') - open(18,file=trim(aerotab_table_dir)//'/aerocomk9.out' & - ,form='formatted',status='old') - open(19,file=trim(aerotab_table_dir)//'/aerocomk10.out' & - ,form='formatted',status='old') - open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' & - ,form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' & - ,form='formatted',status='old') - -! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 11,21 - call checkTableHeader (ifil) - enddo - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! Mode 0, BC(ax -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 11 - - read(9+ifil,996) kcomp, relh, & - bex440, bax440, bex500, bax500, bax550, bex670, bax670, & - bex870, bax870, bex550lt1, bex550gt1, backscx550 - - if(bex440<=0.0_r8) then - write(*,*) 'bex440 =', bex440 - write(*,*) 'Error in initialization of bex1' - stop - endif - - write(iulog,*)'aerocom mode 0 ok' - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! New mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 1 - do lin = 1,5760 ! 10x6x16x6 - - read(20+ifil,997) kcomp, relh, frombg, catot, frac, & - bext440, bext500, bext670, bext870, & - bebg440, bebg500, bebg670, bebg870, & - bebc440, bebc500, bebc670, bebc870, & - beoc440, beoc500, beoc670, beoc870, & - besu440, besu500, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & - beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & - backscat550, babg550, babc550, baoc550, basu550 - - do ic=1,10 - if(abs(relh-rh(ic)) shr_kind_r8 - use oslo_control, only: oslo_getopts, dir_string_length - use commondefinitions, only: nmodes, nbmodes - use opttab, only: cate, cat, fac, faq, fbc, fombg, fbcbg - use cam_logfile, only: iulog - - implicit none - -!Purpose: To read in the AeroCom look-up tables for calculation of dry -! aerosol size and mass distribution properties. The grid for discrete -! input-values in the look-up tables is defined in opptab. - -! Tabulating the 'aerodryk'-files to save computing time. Routine -! originally made by Alf Kirkevaag, and modified for new aerosol -! schemes in January 2006. -! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, -! May 2013, and extended for new SOA treatment October 2015. -! Modified for optimized added masses and mass fractions for -! concentrations from condensation, coagulation or cloud-processing -! - Alf Kirkevaag, May 2016. -! Modified for optimized added masses and mass fractions for concentrations from -! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - - -#include - - integer iv, kcomp, ifombg, ifbcbg, ictot, ifac, ifbc, ifaq - integer ic, ifil, lin - real(r8) frombg, frbcbg, catot, frac, fabc, fraq, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - real(r8) :: eps7 = 1.e-7_r8 - character(len=dir_string_length) :: aerotab_table_dir - - call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - open(11,file=trim(aerotab_table_dir)//'/aerodryk2.out' & - ,form='formatted',status='old') - open(12,file=trim(aerotab_table_dir)//'/aerodryk3.out' & - ,form='formatted',status='old') - open(13,file=trim(aerotab_table_dir)//'/aerodryk4.out' & - ,form='formatted',status='old') - open(14,file=trim(aerotab_table_dir)//'/aerodryk5.out' & - ,form='formatted',status='old') - open(15,file=trim(aerotab_table_dir)//'/aerodryk6.out' & - ,form='formatted',status='old') - open(16,file=trim(aerotab_table_dir)//'/aerodryk7.out' & - ,form='formatted',status='old') - open(17,file=trim(aerotab_table_dir)//'/aerodryk8.out' & - ,form='formatted',status='old') - open(18,file=trim(aerotab_table_dir)//'/aerodryk9.out' & - ,form='formatted',status='old') - open(19,file=trim(aerotab_table_dir)//'/aerodryk10.out' & - ,form='formatted',status='old') - open(20,file=trim(aerotab_table_dir)//'/aerodryk0.out' & - ,form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/aerodryk1.out' & - ,form='formatted',status='old') - -! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 11,21 - call checkTableHeader (ifil) - enddo - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! Mode 0, BC(ax) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 11 - - read(9+ifil,996) kcomp, cintbg, cintbg05, cintbg125, & - aaeros, aaerol, vaeros, vaerol - -! no ictot-, ifac-, ifbc- or ifaq-dependency for this mode, -! since BC(ax) is purely externally mixed - - a0cintbg=cintbg - a0cintbg05=cintbg05 - a0cintbg125=cintbg125 - - a0aaeros=aaeros - a0aaerol=aaerol - a0vaeros=vaeros - a0vaerol=vaerol - - write(iulog,*)'mode 0 ok' - - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 1 - do lin = 1,576 ! 6x16x6 - - read(20+ifil,997) kcomp, frombg, catot, frac, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol - - do ic=1,6 - if(abs(frombg-fombg(ic)) shr_kind_r8 + use oslo_control, only: oslo_getopts, dir_string_length + use commondefinitions, only: nmodes, nbmodes + use opttab, only: cate, cat, fac, faq, fbc, fombg, fbcbg + use cam_logfile, only: iulog + + implicit none + private + + ! For subroutine initdryp and intdrypar: + + real(r8) :: a0cintbg, a0cintbg05, a0cintbg125 + real(r8) :: a0aaeros, a0aaerol, a0vaeros, a0vaerol + real(r8) :: a1var(19,6,16,6) + real(r8) :: a2to3var(19,16,6,2:3) + real(r8) :: a4var(19,6,16,6,6) + real(r8) :: a5to10var(19,6,6,6,6,5:10) + + type, public :: dry_aerosol_size_type + + real(r8) :: cintbg(pcols,pver,0:nbmodes), + real(r8) :: cintbg05(pcols,pver,0:nbmodes) + real(r8) :: cintbg125(pcols,pver,0:nbmodes) + real(r8) :: cintbc(pcols,pver,0:nbmodes) + real(r8) :: cintbc05(pcols,pver,0:nbmodes) + real(r8) :: cintbc125(pcols,pver,0:nbmodes) + real(r8) :: cintoc(pcols,pver,0:nbmodes) + real(r8) :: cintoc05(pcols,pver,0:nbmodes) + real(r8) :: cintoc125(pcols,pver,0:nbmodes) + real(r8) :: cintsc(pcols,pver,0:nbmodes) + real(r8) :: cintsc05(pcols,pver,0:nbmodes) + real(r8) :: cintsc125(pcols,pver,0:nbmodes) + real(r8) :: cintsa(pcols,pver,0:nbmodes) + real(r8) :: cintsa05(pcols,pver,0:nbmodes) + real(r8) :: cintsa125(pcols,pver,0:nbmodes) + real(r8) :: aaeros(pcols,pver,0:nbmodes) + real(r8) :: aaerol(pcols,pver,0:nbmodes) + real(r8) :: vaeros(pcols,pver,0:nbmodes) + real(r8) :: vaerol(pcols,pver,0:nbmodes) + + contains + + procedure :: zero_coeffs + procedure :: update_coeffs + + end type dry_aerosol_size_type + + +contains + + subroutine initdryp( + + ! Purpose: To read in the AeroCom look-up tables for calculation of dry + ! aerosol size and mass distribution properties. The grid for discrete + ! input-values in the look-up tables is defined in opptab. + + ! Tabulating the 'aerodryk'-files to save computing time. Routine + ! originally made by Alf Kirkevaag, and modified for new aerosol + ! schemes in January 2006. + ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, + ! May 2013, and extended for new SOA treatment October 2015. + ! Modified for optimized added masses and mass fractions for + ! concentrations from condensation, coagulation or cloud-processing + ! - Alf Kirkevaag, May 2016. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + + integer :: iv, kcomp, ifombg, ifbcbg, ictot, ifac, ifbc, ifaq + integer :: ic, ifil, lin + real(r8) :: frombg, frbcbg, catot, frac, fabc, fraq + real(r8) :: cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125 + real(r8) :: cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125 + real(r8) :: cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 + character(len=dir_string_length) :: aerotab_table_dir + + call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + + open(11,file=trim(aerotab_table_dir)//'/aerodryk2.out' ,form='formatted',status='old') + open(12,file=trim(aerotab_table_dir)//'/aerodryk3.out' ,form='formatted',status='old') + open(13,file=trim(aerotab_table_dir)//'/aerodryk4.out' ,form='formatted',status='old') + open(14,file=trim(aerotab_table_dir)//'/aerodryk5.out' ,form='formatted',status='old') + open(15,file=trim(aerotab_table_dir)//'/aerodryk6.out' ,form='formatted',status='old') + open(16,file=trim(aerotab_table_dir)//'/aerodryk7.out' ,form='formatted',status='old') + open(17,file=trim(aerotab_table_dir)//'/aerodryk8.out' ,form='formatted',status='old') + open(18,file=trim(aerotab_table_dir)//'/aerodryk9.out' ,form='formatted',status='old') + open(19,file=trim(aerotab_table_dir)//'/aerodryk10.out' ,form='formatted',status='old') + open(20,file=trim(aerotab_table_dir)//'/aerodryk0.out' ,form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/aerodryk1.out' ,form='formatted',status='old') + + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 11,21 + call checkTableHeader (ifil) + enddo - do ic=1,16 -! if(abs(catot-cate(kcomp,ic)) shr_kind_r8 - use opttab, only: cate, cat, fac, faq, fbc - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration -! -! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) -! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). -! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). - - real(r8), intent(out) :: & - bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & - bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & - bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & - bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & - bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & - bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & - bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & - bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & - bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & - bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & - bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & - bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & - bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & - bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & - bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & - beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & - beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & - beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & - beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & - beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & - besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & - besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & - besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & - besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & - besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & - bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & - bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & - beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & - besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - - integer i, iv, ierr, k, kcomp, icol - - kcomp=0 - -! BC(ax) mode: - -! initialize all output fields - do k=1,pver - do icol=1,ncol - bext440(icol,k,kcomp)=0.0_r8 - babs440(icol,k,kcomp)=0.0_r8 - bext500(icol,k,kcomp)=0.0_r8 - babs500(icol,k,kcomp)=0.0_r8 - bext550(icol,k,kcomp)=0.0_r8 - babs550(icol,k,kcomp)=0.0_r8 - bext670(icol,k,kcomp)=0.0_r8 - babs670(icol,k,kcomp)=0.0_r8 - bext870(icol,k,kcomp)=0.0_r8 - babs870(icol,k,kcomp)=0.0_r8 - bebg440(icol,k,kcomp)=0.0_r8 -! babg440(icol,k,kcomp)=0.0_r8 - bebg500(icol,k,kcomp)=0.0_r8 -! babg500(icol,k,kcomp)=0.0_r8 - bebg550(icol,k,kcomp)=0.0_r8 - babg550(icol,k,kcomp)=0.0_r8 - bebg670(icol,k,kcomp)=0.0_r8 -! babg670(icol,k,kcomp)=0.0_r8 - bebg870(icol,k,kcomp)=0.0_r8 -! babg870(icol,k,kcomp)=0.0_r8 - bebc440(icol,k,kcomp)=0.0_r8 -! babc440(icol,k,kcomp)=0.0_r8 - bebc500(icol,k,kcomp)=0.0_r8 -! babc500(icol,k,kcomp)=0.0_r8 - bebc550(icol,k,kcomp)=0.0_r8 - babc550(icol,k,kcomp)=0.0_r8 - bebc670(icol,k,kcomp)=0.0_r8 -! babc670(icol,k,kcomp)=0.0_r8 - bebc870(icol,k,kcomp)=0.0_r8 -! babc870(icol,k,kcomp)=0.0_r8 - beoc440(icol,k,kcomp)=0.0_r8 -! baoc440(icol,k,kcomp)=0.0_r8 - beoc500(icol,k,kcomp)=0.0_r8 -! baoc500(icol,k,kcomp)=0.0_r8 - beoc550(icol,k,kcomp)=0.0_r8 - baoc550(icol,k,kcomp)=0.0_r8 - beoc670(icol,k,kcomp)=0.0_r8 -! baoc670(icol,k,kcomp)=0.0_r8 - beoc870(icol,k,kcomp)=0.0_r8 -! baoc870(icol,k,kcomp)=0.0_r8 - besu440(icol,k,kcomp)=0.0_r8 -! basu440(icol,k,kcomp)=0.0_r8 - besu500(icol,k,kcomp)=0.0_r8 -! basu500(icol,k,kcomp)=0.0_r8 - besu550(icol,k,kcomp)=0.0_r8 - basu550(icol,k,kcomp)=0.0_r8 - besu670(icol,k,kcomp)=0.0_r8 -! basu670(icol,k,kcomp)=0.0_r8 - besu870(icol,k,kcomp)=0.0_r8 -! basu870(icol,k,kcomp)=0.0_r8 - bebg550lt1(icol,k,kcomp)=0.0_r8 - bebg550gt1(icol,k,kcomp)=0.0_r8 - bebc550lt1(icol,k,kcomp)=0.0_r8 - bebc550gt1(icol,k,kcomp)=0.0_r8 - beoc550lt1(icol,k,kcomp)=0.0_r8 - beoc550gt1(icol,k,kcomp)=0.0_r8 - besu550lt1(icol,k,kcomp)=0.0_r8 - besu550gt1(icol,k,kcomp)=0.0_r8 - backsc550(icol,k,kcomp)=0.0_r8 - end do - end do - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kcomp).gt.0) then - - bext440(icol,k,kcomp)=bex440 - babs440(icol,k,kcomp)=bax440 - bext500(icol,k,kcomp)=bex500 - babs500(icol,k,kcomp)=bax500 - bext550(icol,k,kcomp)=bex550lt1+bex550gt1 - babs550(icol,k,kcomp)=bax550 - bext670(icol,k,kcomp)=bex670 - babs670(icol,k,kcomp)=bax670 - bext870(icol,k,kcomp)=bex870 - babs870(icol,k,kcomp)=bax870 - bebg440(icol,k,kcomp)=bex440 -! babg440(icol,k,kcomp)=bax440 - bebg500(icol,k,kcomp)=bex500 -! babg500(icol,k,kcomp)=bax500 - bebg550(icol,k,kcomp)=bex550lt1+bex550gt1 - babg550(icol,k,kcomp)=bax550 - bebg670(icol,k,kcomp)=bex670 -! babg670(icol,k,kcomp)=bax670 - bebg870(icol,k,kcomp)=bex870 -! babg870(icol,k,kcomp)=bax870 - bebc440(icol,k,kcomp)=0.0_r8 -! babc440(icol,k,kcomp)=0.0_r8 - bebc500(icol,k,kcomp)=0.0_r8 -! babc500(icol,k,kcomp)=0.0_r8 - bebc670(icol,k,kcomp)=0.0_r8 -! babc670(icol,k,kcomp)=0.0_r8 - bebc870(icol,k,kcomp)=0.0_r8 -! babc870(icol,k,kcomp)=0.0_r8 - beoc440(icol,k,kcomp)=0.0_r8 -! baoc440(icol,k,kcomp)=0.0_r8 - beoc500(icol,k,kcomp)=0.0_r8 -! baoc500(icol,k,kcomp)=0.0_r8 - beoc670(icol,k,kcomp)=0.0_r8 -! baoc670(icol,k,kcomp)=0.0_r8 - beoc870(icol,k,kcomp)=0.0_r8 -! baoc870(icol,k,kcomp)=0.0_r8 - besu440(icol,k,kcomp)=0.0_r8 -! basu440(icol,k,kcomp)=0.0_r8 - besu500(icol,k,kcomp)=0.0_r8 -! basu500(icol,k,kcomp)=0.0_r8 - besu670(icol,k,kcomp)=0.0_r8 -! basu670(icol,k,kcomp)=0.0_r8 - besu870(icol,k,kcomp)=0.0_r8 -! basu870(icol,k,kcomp)=0.0_r8 - bebg550lt1(icol,k,kcomp)=bex550lt1 - bebg550gt1(icol,k,kcomp)=bex550gt1 - bebc550lt1(icol,k,kcomp)=0.0_r8 - bebc550gt1(icol,k,kcomp)=0.0_r8 - beoc550lt1(icol,k,kcomp)=0.0_r8 - beoc550gt1(icol,k,kcomp)=0.0_r8 - besu550lt1(icol,k,kcomp)=0.0_r8 - besu550gt1(icol,k,kcomp)=0.0_r8 - backsc550(icol,k,kcomp)=backscx550 - - endif - - end do ! icol - end do ! k - - return -end subroutine intaeropt0 - - - - diff --git a/src/physics/cam_oslo/intaeropt1.F90 b/src/physics/cam_oslo/intaeropt1.F90 deleted file mode 100644 index a80a204940..0000000000 --- a/src/physics/cam_oslo/intaeropt1.F90 +++ /dev/null @@ -1,317 +0,0 @@ -subroutine intaeropt1 (lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & - beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & - backsc550, babg550, babc550, baoc550, basu550) - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: cate, fombg, cat, fac, faq, fbc, rh - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode - integer, intent(in) :: ifombg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - -! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) -! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). -! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). -! Rewritten by Alf Kirkevaag September 2015 to a more generalized for for -! interpolations using common subroutines interpol*dim. - - real(r8), intent(out) :: & - bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & - bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & - bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & - bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & - bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & - bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & - bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & - bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & - bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & - bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & - bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & - bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & - bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & - bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & - bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & - beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & - beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & - beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & - beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & - beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & - besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & - besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & - besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & - besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & - besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & - bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & - bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & - beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & - besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - - real(r8) a, b, e, eps - - integer i, iv, ierr, irelh, ifombg, ictot, ifac, kcomp, k, icol, kc10 - -! Temporary storage of often used array elements - integer t_irh1, t_irh2, t_ifo1, t_ifo2, t_ict1, t_ict2, t_ifc1, t_ifc2 - real(r8) t_fac1, t_fac2, t_xfac - real(r8) t_xrh, t_rh1, t_rh2, t_fombg1, t_fombg2, t_xfombg - real(r8) t_xct, t_cat1, t_cat2 - real(r8) d2mx(4), dxm1(4), invd(4) - real(r8) opt4d(2,2,2,2) - real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) opt1, opt2, opt(38) - - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - -! write(*,*) 'Before kcomp-loop' - -! SO4/SOA(Ait) mode: - - do kcomp=1,1 - -! write(*,*) 'kcomp = ', kcomp - -! initialize all output fields Bruk For All istedet? - do k=1,pver - do icol=1,ncol - bext440(icol,k,kcomp)=0.0_r8 - babs440(icol,k,kcomp)=0.0_r8 - bext500(icol,k,kcomp)=0.0_r8 - babs500(icol,k,kcomp)=0.0_r8 - bext550(icol,k,kcomp)=0.0_r8 - babs550(icol,k,kcomp)=0.0_r8 - bext670(icol,k,kcomp)=0.0_r8 - babs670(icol,k,kcomp)=0.0_r8 - bext870(icol,k,kcomp)=0.0_r8 - babs870(icol,k,kcomp)=0.0_r8 - bebg440(icol,k,kcomp)=0.0_r8 -! babg440(icol,k,kcomp)=0.0_r8 - bebg500(icol,k,kcomp)=0.0_r8 -! babg500(icol,k,kcomp)=0.0_r8 - bebg550(icol,k,kcomp)=0.0_r8 - babg550(icol,k,kcomp)=0.0_r8 - bebg670(icol,k,kcomp)=0.0_r8 -! babg670(icol,k,kcomp)=0.0_r8 - bebg870(icol,k,kcomp)=0.0_r8 -! babg870(icol,k,kcomp)=0.0_r8 - bebc440(icol,k,kcomp)=0.0_r8 -! babc440(icol,k,kcomp)=0.0_r8 - bebc500(icol,k,kcomp)=0.0_r8 -! babc500(icol,k,kcomp)=0.0_r8 - bebc550(icol,k,kcomp)=0.0_r8 - babc550(icol,k,kcomp)=0.0_r8 - bebc670(icol,k,kcomp)=0.0_r8 -! babc670(icol,k,kcomp)=0.0_r8 - bebc870(icol,k,kcomp)=0.0_r8 -! babc870(icol,k,kcomp)=0.0_r8 - beoc440(icol,k,kcomp)=0.0_r8 -! baoc440(icol,k,kcomp)=0.0_r8 - beoc500(icol,k,kcomp)=0.0_r8 -! baoc500(icol,k,kcomp)=0.0_r8 - beoc550(icol,k,kcomp)=0.0_r8 - baoc550(icol,k,kcomp)=0.0_r8 - beoc670(icol,k,kcomp)=0.0_r8 -! baoc670(icol,k,kcomp)=0.0_r8 - beoc870(icol,k,kcomp)=0.0_r8 -! baoc870(icol,k,kcomp)=0.0_r8 - besu440(icol,k,kcomp)=0.0_r8 -! basu440(icol,k,kcomp)=0.0_r8 - besu500(icol,k,kcomp)=0.0_r8 -! basu500(icol,k,kcomp)=0.0_r8 - besu550(icol,k,kcomp)=0.0_r8 - basu550(icol,k,kcomp)=0.0_r8 - besu670(icol,k,kcomp)=0.0_r8 -! basu670(icol,k,kcomp)=0.0_r8 - besu870(icol,k,kcomp)=0.0_r8 -! basu870(icol,k,kcomp)=0.0_r8 - bebg550lt1(icol,k,kcomp)=0.0_r8 - bebg550gt1(icol,k,kcomp)=0.0_r8 - bebc550lt1(icol,k,kcomp)=0.0_r8 - bebc550gt1(icol,k,kcomp)=0.0_r8 - beoc550lt1(icol,k,kcomp)=0.0_r8 - beoc550gt1(icol,k,kcomp)=0.0_r8 - besu550lt1(icol,k,kcomp)=0.0_r8 - besu550gt1(icol,k,kcomp)=0.0_r8 - backsc550(icol,k,kcomp)=0.0_r8 - end do - end do - - if(mplus10==0) then - kc10=kcomp - else - write(*,*) "mplus10=1 is no loger an option for kcomp=1." - stop - endif - - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kc10).gt.0) then - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ifo1 = ifombg1(icol,k) - t_ifo2 = t_ifo1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_fombg1 = fombg(t_ifo1) - t_fombg2 = fombg(t_ifo2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - t_xfombg = xfombg(icol,k) - -! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fombg2-t_xfombg) - dxm1(2) = (t_xfombg-t_fombg1) - invd(2) = 1.0_r8/(t_fombg2-t_fombg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - - do iv=1,38 ! variable number - -! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=bep1(iv,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=bep1(iv,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=bep1(iv,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=bep1(iv,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=bep1(iv,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=bep1(iv,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=bep1(iv,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=bep1(iv,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=bep1(iv,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=bep1(iv,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=bep1(iv,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=bep1(iv,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=bep1(iv,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=bep1(iv,t_irh2,t_ifo2,t_ict2,t_ifc2) - -! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) - -! finally, interpolation in the rh dimension - opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) & - /(t_rh2-t_rh1) - -! if(mplus10==1) then -! write(*,*) 'kcomp, iv, opt(iv) =', kcomp, iv, opt(iv) -! write(*,*) 'kc10, Nnatk =', kc10, Nnatk(icol,k,kc10) -! endif - - end do ! iv=1,38 - - bext440(icol,k,kcomp)=opt(1) - bext500(icol,k,kcomp)=opt(2) - bext670(icol,k,kcomp)=opt(3) - bext870(icol,k,kcomp)=opt(4) - bebg440(icol,k,kcomp)=opt(5) - bebg500(icol,k,kcomp)=opt(6) - bebg670(icol,k,kcomp)=opt(7) - bebg870(icol,k,kcomp)=opt(8) - bebc440(icol,k,kcomp)=opt(9) - bebc500(icol,k,kcomp)=opt(10) - bebc670(icol,k,kcomp)=opt(11) - bebc870(icol,k,kcomp)=opt(12) - beoc440(icol,k,kcomp)=opt(13) - beoc500(icol,k,kcomp)=opt(14) - beoc670(icol,k,kcomp)=opt(15) - beoc870(icol,k,kcomp)=opt(16) - besu440(icol,k,kcomp)=opt(17) - besu500(icol,k,kcomp)=opt(18) - besu670(icol,k,kcomp)=opt(19) - besu870(icol,k,kcomp)=opt(20) - babs440(icol,k,kcomp)=opt(21) - babs500(icol,k,kcomp)=opt(22) - babs550(icol,k,kcomp)=opt(23) - babs670(icol,k,kcomp)=opt(24) - babs870(icol,k,kcomp)=opt(25) - bebg550lt1(icol,k,kcomp)=opt(26) - bebg550gt1(icol,k,kcomp)=opt(27) - bebc550lt1(icol,k,kcomp)=opt(28) - bebc550gt1(icol,k,kcomp)=opt(29) - beoc550lt1(icol,k,kcomp)=opt(30) - beoc550gt1(icol,k,kcomp)=opt(31) - besu550lt1(icol,k,kcomp)=opt(32) - besu550gt1(icol,k,kcomp)=opt(33) - backsc550(icol,k,kcomp)=opt(34) - babg550(icol,k,kcomp)=opt(35) - babc550(icol,k,kcomp)=opt(36) - baoc550(icol,k,kcomp)=opt(37) - basu550(icol,k,kcomp)=opt(38) - bebg550(icol,k,kcomp)=opt(26)+opt(27) - bebc550(icol,k,kcomp)=opt(28)+opt(29) - beoc550(icol,k,kcomp)=opt(30)+opt(31) - besu550(icol,k,kcomp)=opt(32)+opt(33) - bext550(icol,k,kcomp)=bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & - +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) - - endif - - end do ! icol - end do ! k - - end do ! kcomp - - return - -end subroutine intaeropt1 - - - - diff --git a/src/physics/cam_oslo/intaeropt2to3.F90 b/src/physics/cam_oslo/intaeropt2to3.F90 deleted file mode 100644 index 20ab80818b..0000000000 --- a/src/physics/cam_oslo/intaeropt2to3.F90 +++ /dev/null @@ -1,299 +0,0 @@ -subroutine intaeropt2to3 (lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & - beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & - backsc550, babg550, babc550, baoc550, basu550) - -! Extended by Alf Kirkevaag to include SOA in September 2015 - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: cate, cat, fac, faq, fbc, rh - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) -! -! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) -!old: for 550nm (1) and 865nm (2), and for r<1um (lt1) and r>1um (gt1). -! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). -! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). -! Rewritten by Alf Kirkevaag September 2015 to a more generalized for for -! interpolations using common subroutines interpol*dim. - - real(r8), intent(out) :: & - bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & - bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & - bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & - bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & - bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & - bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & - bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & - bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & - bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & - bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & - bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & - bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & - bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & - bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & - bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & - beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & - beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & - beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & - beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & - beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & - besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & - besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & - besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & - besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & - besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & - bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & - bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & - beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & - besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - - real(r8) a, b, e, eps - - integer i, iv, kcomp, k, icol, kc10 - -! Temporary storage of often used array elements - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 - real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, & - t_cat1, t_cat2 - real(r8) d2mx(3), dxm1(3), invd(3) - real(r8) opt3d(2,2,2) - real(r8) opt1, opt2, opt(38) - - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - -! write(*,*) 'Before kcomp-loop' - -! SO4(Ait), BC(Ait) and OC(Ait) modes: - - do kcomp=2,3 - -! write(*,*) 'kcomp = ', kcomp - - -! initialize all output fields Bruk For All istedet? - do k=1,pver - do icol=1,ncol - bext440(icol,k,kcomp)=0.0_r8 - babs440(icol,k,kcomp)=0.0_r8 - bext500(icol,k,kcomp)=0.0_r8 - babs500(icol,k,kcomp)=0.0_r8 - bext550(icol,k,kcomp)=0.0_r8 - babs550(icol,k,kcomp)=0.0_r8 - bext670(icol,k,kcomp)=0.0_r8 - babs670(icol,k,kcomp)=0.0_r8 - bext870(icol,k,kcomp)=0.0_r8 - babs870(icol,k,kcomp)=0.0_r8 - bebg440(icol,k,kcomp)=0.0_r8 -! babg440(icol,k,kcomp)=0.0_r8 - bebg500(icol,k,kcomp)=0.0_r8 -! babg500(icol,k,kcomp)=0.0_r8 - bebg550(icol,k,kcomp)=0.0_r8 - babg550(icol,k,kcomp)=0.0_r8 - bebg670(icol,k,kcomp)=0.0_r8 -! babg670(icol,k,kcomp)=0.0_r8 - bebg870(icol,k,kcomp)=0.0_r8 -! babg870(icol,k,kcomp)=0.0_r8 - bebc440(icol,k,kcomp)=0.0_r8 -! babc440(icol,k,kcomp)=0.0_r8 - bebc500(icol,k,kcomp)=0.0_r8 -! babc500(icol,k,kcomp)=0.0_r8 - bebc550(icol,k,kcomp)=0.0_r8 - babc550(icol,k,kcomp)=0.0_r8 - bebc670(icol,k,kcomp)=0.0_r8 -! babc670(icol,k,kcomp)=0.0_r8 - bebc870(icol,k,kcomp)=0.0_r8 -! babc870(icol,k,kcomp)=0.0_r8 - beoc440(icol,k,kcomp)=0.0_r8 -! baoc440(icol,k,kcomp)=0.0_r8 - beoc500(icol,k,kcomp)=0.0_r8 -! baoc500(icol,k,kcomp)=0.0_r8 - beoc550(icol,k,kcomp)=0.0_r8 - baoc550(icol,k,kcomp)=0.0_r8 - beoc670(icol,k,kcomp)=0.0_r8 -! baoc670(icol,k,kcomp)=0.0_r8 - beoc870(icol,k,kcomp)=0.0_r8 -! baoc870(icol,k,kcomp)=0.0_r8 - besu440(icol,k,kcomp)=0.0_r8 -! basu440(icol,k,kcomp)=0.0_r8 - besu500(icol,k,kcomp)=0.0_r8 -! basu500(icol,k,kcomp)=0.0_r8 - besu550(icol,k,kcomp)=0.0_r8 - basu550(icol,k,kcomp)=0.0_r8 - besu670(icol,k,kcomp)=0.0_r8 -! basu670(icol,k,kcomp)=0.0_r8 - besu870(icol,k,kcomp)=0.0_r8 -! basu870(icol,k,kcomp)=0.0_r8 - bebg550lt1(icol,k,kcomp)=0.0_r8 - bebg550gt1(icol,k,kcomp)=0.0_r8 - bebc550lt1(icol,k,kcomp)=0.0_r8 - bebc550gt1(icol,k,kcomp)=0.0_r8 - beoc550lt1(icol,k,kcomp)=0.0_r8 - beoc550gt1(icol,k,kcomp)=0.0_r8 - besu550lt1(icol,k,kcomp)=0.0_r8 - besu550gt1(icol,k,kcomp)=0.0_r8 - backsc550(icol,k,kcomp)=0.0_r8 - end do - end do - - end do ! kcomp - - do kcomp=2,2 ! kcomp=3 is no longer used - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kc10).gt.0) then - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - -! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - - do iv=1,38 ! variable number - -! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=bep2to3(iv,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=bep2to3(iv,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=bep2to3(iv,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=bep2to3(iv,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=bep2to3(iv,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=bep2to3(iv,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=bep2to3(iv,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=bep2to3(iv,t_irh2,t_ict2,t_ifc2,kcomp) - -! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, opt1, opt2) - -! finally, interpolation in the rh dimension - opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) & - /(t_rh2-t_rh1) - - - end do ! iv=1,38 - - bext440(icol,k,kcomp)=opt(1) - bext500(icol,k,kcomp)=opt(2) - bext670(icol,k,kcomp)=opt(3) - bext870(icol,k,kcomp)=opt(4) - bebg440(icol,k,kcomp)=opt(5) - bebg500(icol,k,kcomp)=opt(6) - bebg670(icol,k,kcomp)=opt(7) - bebg870(icol,k,kcomp)=opt(8) - bebc440(icol,k,kcomp)=opt(9) - bebc500(icol,k,kcomp)=opt(10) - bebc670(icol,k,kcomp)=opt(11) - bebc870(icol,k,kcomp)=opt(12) - beoc440(icol,k,kcomp)=opt(13) - beoc500(icol,k,kcomp)=opt(14) - beoc670(icol,k,kcomp)=opt(15) - beoc870(icol,k,kcomp)=opt(16) - besu440(icol,k,kcomp)=opt(17) - besu500(icol,k,kcomp)=opt(18) - besu670(icol,k,kcomp)=opt(19) - besu870(icol,k,kcomp)=opt(20) - babs440(icol,k,kcomp)=opt(21) - babs500(icol,k,kcomp)=opt(22) - babs550(icol,k,kcomp)=opt(23) - babs670(icol,k,kcomp)=opt(24) - babs870(icol,k,kcomp)=opt(25) - bebg550lt1(icol,k,kcomp)=opt(26) - bebg550gt1(icol,k,kcomp)=opt(27) - bebc550lt1(icol,k,kcomp)=opt(28) - bebc550gt1(icol,k,kcomp)=opt(29) - beoc550lt1(icol,k,kcomp)=opt(30) - beoc550gt1(icol,k,kcomp)=opt(31) - besu550lt1(icol,k,kcomp)=opt(32) - besu550gt1(icol,k,kcomp)=opt(33) - backsc550(icol,k,kcomp)=opt(34) - babg550(icol,k,kcomp)=opt(35) - babc550(icol,k,kcomp)=opt(36) - baoc550(icol,k,kcomp)=opt(37) - basu550(icol,k,kcomp)=opt(38) - bebg550(icol,k,kcomp)=opt(26)+opt(27) - bebc550(icol,k,kcomp)=opt(28)+opt(29) - beoc550(icol,k,kcomp)=opt(30)+opt(31) - besu550(icol,k,kcomp)=opt(32)+opt(33) - bext550(icol,k,kcomp)=bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & - +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) - - endif ! Nnatk > 0 - - - end do ! icol - end do ! k - - - end do ! kcomp - - return -end subroutine intaeropt2to3 - - - - diff --git a/src/physics/cam_oslo/intaeropt4.F90 b/src/physics/cam_oslo/intaeropt4.F90 deleted file mode 100644 index 42ab4e583c..0000000000 --- a/src/physics/cam_oslo/intaeropt4.F90 +++ /dev/null @@ -1,339 +0,0 @@ -subroutine intaeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & - beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & - backsc550, babg550, babc550, baoc550, basu550) - - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: fbcbg, cate, cat, fac, faq, fbc, rh - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xfbcbg(pcols,pver) - integer, intent(in) :: ifbcbg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - -! -! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) -! for 550nm (1) and 865nm (2), and for r<1um (lt1) and r>1um (gt1). -! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). -! Rewritten by Alf Kirkevaag September 2015 to a more generalized for for -! interpolations using common subroutines interpol*dim. - - real(r8), intent(out) :: & - bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & - bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & - bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & - bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & - bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & - bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & - bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & - bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & - bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & - bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & - bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & - bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & - bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & - bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & - bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & - beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & - beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & - beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & - beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & - beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & - besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & - besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & - besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & - besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & - besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & - bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & - bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & - beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & - besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - real(r8) a, b, e, eps - - integer i, iv, kcomp, k, icol, kc10 - -! Temporary storage of often used array elements - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 - real(r8) t_fbcbg1, t_fbcbg2 - integer t_ifb1, t_ifb2 - real(r8) t_faq1, t_faq2, t_xfaq - real(r8) t_fac1, t_fac2, t_xfac - real(r8) t_xrh, t_xct, t_rh1, t_rh2 - real(r8) t_cat1, t_cat2 - real(r8) t_xfbcbg - real(r8) d2mx(5), dxm1(5), invd(5) - real(r8) opt5d(2,2,2,2,2) - real(r8) opt1, opt2, opt(38) - - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - -! write(*,*) 'Before kcomp-loop' - -! BC&OC(Ait) mode: - - do kcomp=4,4 - -! write(*,*) 'kcomp = ', kcomp - -! initialize all output fields - do k=1,pver - do icol=1,ncol - bext440(icol,k,kcomp)=0.0_r8 - babs440(icol,k,kcomp)=0.0_r8 - bext500(icol,k,kcomp)=0.0_r8 - babs500(icol,k,kcomp)=0.0_r8 - bext550(icol,k,kcomp)=0.0_r8 - babs550(icol,k,kcomp)=0.0_r8 - bext670(icol,k,kcomp)=0.0_r8 - babs670(icol,k,kcomp)=0.0_r8 - bext870(icol,k,kcomp)=0.0_r8 - babs870(icol,k,kcomp)=0.0_r8 - bebg440(icol,k,kcomp)=0.0_r8 -! babg440(icol,k,kcomp)=0.0_r8 - bebg500(icol,k,kcomp)=0.0_r8 -! babg500(icol,k,kcomp)=0.0_r8 - bebg550(icol,k,kcomp)=0.0_r8 - babg550(icol,k,kcomp)=0.0_r8 - bebg670(icol,k,kcomp)=0.0_r8 -! babg670(icol,k,kcomp)=0.0_r8 - bebg870(icol,k,kcomp)=0.0_r8 -! babg870(icol,k,kcomp)=0.0_r8 - bebc440(icol,k,kcomp)=0.0_r8 -! babc440(icol,k,kcomp)=0.0_r8 - bebc500(icol,k,kcomp)=0.0_r8 -! babc500(icol,k,kcomp)=0.0_r8 - bebc550(icol,k,kcomp)=0.0_r8 - babc550(icol,k,kcomp)=0.0_r8 - bebc670(icol,k,kcomp)=0.0_r8 -! babc670(icol,k,kcomp)=0.0_r8 - bebc870(icol,k,kcomp)=0.0_r8 -! babc870(icol,k,kcomp)=0.0_r8 - beoc440(icol,k,kcomp)=0.0_r8 -! baoc440(icol,k,kcomp)=0.0_r8 - beoc500(icol,k,kcomp)=0.0_r8 -! baoc500(icol,k,kcomp)=0.0_r8 - beoc550(icol,k,kcomp)=0.0_r8 - baoc550(icol,k,kcomp)=0.0_r8 - beoc670(icol,k,kcomp)=0.0_r8 -! baoc670(icol,k,kcomp)=0.0_r8 - beoc870(icol,k,kcomp)=0.0_r8 -! baoc870(icol,k,kcomp)=0.0_r8 - besu440(icol,k,kcomp)=0.0_r8 -! basu440(icol,k,kcomp)=0.0_r8 - besu500(icol,k,kcomp)=0.0_r8 -! basu500(icol,k,kcomp)=0.0_r8 - besu550(icol,k,kcomp)=0.0_r8 - basu550(icol,k,kcomp)=0.0_r8 - besu670(icol,k,kcomp)=0.0_r8 -! basu670(icol,k,kcomp)=0.0_r8 - besu870(icol,k,kcomp)=0.0_r8 -! basu870(icol,k,kcomp)=0.0_r8 - bebg550lt1(icol,k,kcomp)=0.0_r8 - bebg550gt1(icol,k,kcomp)=0.0_r8 - bebc550lt1(icol,k,kcomp)=0.0_r8 - bebc550gt1(icol,k,kcomp)=0.0_r8 - beoc550lt1(icol,k,kcomp)=0.0_r8 - beoc550gt1(icol,k,kcomp)=0.0_r8 - besu550lt1(icol,k,kcomp)=0.0_r8 - besu550gt1(icol,k,kcomp)=0.0_r8 - backsc550(icol,k,kcomp)=0.0_r8 - end do - end do - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kc10).gt.0) then - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ifb1 = ifbcbg1(icol,k) - t_ifb2 = t_ifb1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xfbcbg = xfbcbg(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - -! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fbcbg2-t_xfbcbg) - dxm1(2) = (t_xfbcbg-t_fbcbg1) - invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - do iv=1,38 ! variable number - - opt5d(1,1,1,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - -! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - -! finally, interpolation in the rh dimension - opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) & - /(t_rh2-t_rh1) - -! write(*,*) opt(iv) - - end do ! iv=1,38 - - bext440(icol,k,kcomp)=opt(1) - bext500(icol,k,kcomp)=opt(2) - bext670(icol,k,kcomp)=opt(3) - bext870(icol,k,kcomp)=opt(4) - bebg440(icol,k,kcomp)=opt(5) - bebg500(icol,k,kcomp)=opt(6) - bebg670(icol,k,kcomp)=opt(7) - bebg870(icol,k,kcomp)=opt(8) - bebc440(icol,k,kcomp)=opt(9) - bebc500(icol,k,kcomp)=opt(10) - bebc670(icol,k,kcomp)=opt(11) - bebc870(icol,k,kcomp)=opt(12) - beoc440(icol,k,kcomp)=opt(13) - beoc500(icol,k,kcomp)=opt(14) - beoc670(icol,k,kcomp)=opt(15) - beoc870(icol,k,kcomp)=opt(16) - besu440(icol,k,kcomp)=opt(17) - besu500(icol,k,kcomp)=opt(18) - besu670(icol,k,kcomp)=opt(19) - besu870(icol,k,kcomp)=opt(20) - babs440(icol,k,kcomp)=opt(21) - babs500(icol,k,kcomp)=opt(22) - babs550(icol,k,kcomp)=opt(23) - babs670(icol,k,kcomp)=opt(24) - babs870(icol,k,kcomp)=opt(25) - bebg550lt1(icol,k,kcomp)=opt(26) - bebg550gt1(icol,k,kcomp)=opt(27) - bebc550lt1(icol,k,kcomp)=opt(28) - bebc550gt1(icol,k,kcomp)=opt(29) - beoc550lt1(icol,k,kcomp)=opt(30) - beoc550gt1(icol,k,kcomp)=opt(31) - besu550lt1(icol,k,kcomp)=opt(32) - besu550gt1(icol,k,kcomp)=opt(33) - backsc550(icol,k,kcomp)=opt(34) - babg550(icol,k,kcomp)=opt(35) - babc550(icol,k,kcomp)=opt(36) - baoc550(icol,k,kcomp)=opt(37) - basu550(icol,k,kcomp)=opt(38) - bebg550(icol,k,kcomp)=opt(26)+opt(27) - bebc550(icol,k,kcomp)=opt(28)+opt(29) - beoc550(icol,k,kcomp)=opt(30)+opt(31) - besu550(icol,k,kcomp)=opt(32)+opt(33) - bext550(icol,k,kcomp)=bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & - +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) - - endif - - end do ! icol - end do ! k - - end do ! kcomp - - return - -end subroutine intaeropt4 - - - - diff --git a/src/physics/cam_oslo/intaeropt5to10.F90 b/src/physics/cam_oslo/intaeropt5to10.F90 deleted file mode 100644 index 11226da38d..0000000000 --- a/src/physics/cam_oslo/intaeropt5to10.F90 +++ /dev/null @@ -1,334 +0,0 @@ -subroutine intaeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & - beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & - backsc550, babg550, babc550, baoc550, basu550) - - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: cate, cat, fac, faq, fbc, rh - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) - integer, intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) -! -! Output arguments: Modal total and absorption extiction coefficients (for AeroCom) -! for 550nm (1) and 865nm (2), and for r<1um (lt1) and r>1um (gt1). -! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). -! Rewritten by Alf Kirkevaag September 2015 to a more generalized for for -! interpolations using common subroutines interpol*dim. -! - real(r8), intent(out) :: & - bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & - bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & - bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & - bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & - bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & - bebg440(pcols,pver,0:nbmodes), & ! babg440(pcols,pver,0:nbmodes), & - bebg500(pcols,pver,0:nbmodes), & ! babg500(pcols,pver,0:nbmodes), & - bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & - bebg670(pcols,pver,0:nbmodes), & ! babg670(pcols,pver,0:nbmodes), & - bebg870(pcols,pver,0:nbmodes), & ! babg870(pcols,pver,0:nbmodes), & - bebc440(pcols,pver,0:nbmodes), & ! babc440(pcols,pver,0:nbmodes), & - bebc500(pcols,pver,0:nbmodes), & ! babc500(pcols,pver,0:nbmodes), & - bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & - bebc670(pcols,pver,0:nbmodes), & ! babc670(pcols,pver,0:nbmodes), & - bebc870(pcols,pver,0:nbmodes), & ! babc870(pcols,pver,0:nbmodes), & - beoc440(pcols,pver,0:nbmodes), & ! baoc440(pcols,pver,0:nbmodes), & - beoc500(pcols,pver,0:nbmodes), & ! baoc500(pcols,pver,0:nbmodes), & - beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & - beoc670(pcols,pver,0:nbmodes), & ! baoc670(pcols,pver,0:nbmodes), & - beoc870(pcols,pver,0:nbmodes), & ! baoc870(pcols,pver,0:nbmodes), & - besu440(pcols,pver,0:nbmodes), & ! basu440(pcols,pver,0:nbmodes), & - besu500(pcols,pver,0:nbmodes), & ! basu500(pcols,pver,0:nbmodes), & - besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & - besu670(pcols,pver,0:nbmodes), & ! basu670(pcols,pver,0:nbmodes), & - besu870(pcols,pver,0:nbmodes), & ! basu870(pcols,pver,0:nbmodes), & - bebg550lt1(pcols,pver,0:nbmodes), bebg550gt1(pcols,pver,0:nbmodes), & - bebc550lt1(pcols,pver,0:nbmodes), bebc550gt1(pcols,pver,0:nbmodes), & - beoc550lt1(pcols,pver,0:nbmodes), beoc550gt1(pcols,pver,0:nbmodes), & - besu550lt1(pcols,pver,0:nbmodes), besu550gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - real(r8) a, b, e, eps - - integer i, iv, kcomp, k, icol - -! Temporary storage of often used array elements - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 - integer t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) t_faq1, t_faq2, t_xfaq - real(r8) t_fbc1, t_fbc2, t_xfbc - real(r8) t_fac1, t_fac2, t_xfac - real(r8) t_xrh, t_xct, t_rh1, t_rh2 - real(r8) t_cat1, t_cat2 - real(r8) d2mx(5), dxm1(5), invd(5) - real(r8) opt5d(2,2,2,2,2) - real(r8) opt1, opt2, opt(38) - - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - -! write(*,*) 'Before kcomp-loop' - -! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): - - do kcomp=5,10 - -! write(*,*) 'kcomp = ', kcomp - -! initialize all output fields - do k=1,pver - do icol=1,ncol - bext440(icol,k,kcomp)=0.0_r8 - babs440(icol,k,kcomp)=0.0_r8 - bext500(icol,k,kcomp)=0.0_r8 - babs500(icol,k,kcomp)=0.0_r8 - bext550(icol,k,kcomp)=0.0_r8 - babs550(icol,k,kcomp)=0.0_r8 - bext670(icol,k,kcomp)=0.0_r8 - babs670(icol,k,kcomp)=0.0_r8 - bext870(icol,k,kcomp)=0.0_r8 - babs870(icol,k,kcomp)=0.0_r8 - bebg440(icol,k,kcomp)=0.0_r8 -! babg440(icol,k,kcomp)=0.0_r8 - bebg500(icol,k,kcomp)=0.0_r8 -! babg500(icol,k,kcomp)=0.0_r8 - bebg550(icol,k,kcomp)=0.0_r8 - babg550(icol,k,kcomp)=0.0_r8 - bebg670(icol,k,kcomp)=0.0_r8 -! babg670(icol,k,kcomp)=0.0_r8 - bebg870(icol,k,kcomp)=0.0_r8 -! babg870(icol,k,kcomp)=0.0_r8 - bebc440(icol,k,kcomp)=0.0_r8 -! babc440(icol,k,kcomp)=0.0_r8 - bebc500(icol,k,kcomp)=0.0_r8 -! babc500(icol,k,kcomp)=0.0_r8 - bebc550(icol,k,kcomp)=0.0_r8 - babc550(icol,k,kcomp)=0.0_r8 - bebc670(icol,k,kcomp)=0.0_r8 -! babc670(icol,k,kcomp)=0.0_r8 - bebc870(icol,k,kcomp)=0.0_r8 -! babc870(icol,k,kcomp)=0.0_r8 - beoc440(icol,k,kcomp)=0.0_r8 -! baoc440(icol,k,kcomp)=0.0_r8 - beoc500(icol,k,kcomp)=0.0_r8 -! baoc500(icol,k,kcomp)=0.0_r8 - beoc550(icol,k,kcomp)=0.0_r8 - baoc550(icol,k,kcomp)=0.0_r8 - beoc670(icol,k,kcomp)=0.0_r8 -! baoc670(icol,k,kcomp)=0.0_r8 - beoc870(icol,k,kcomp)=0.0_r8 -! baoc870(icol,k,kcomp)=0.0_r8 - besu440(icol,k,kcomp)=0.0_r8 -! basu440(icol,k,kcomp)=0.0_r8 - besu500(icol,k,kcomp)=0.0_r8 -! basu500(icol,k,kcomp)=0.0_r8 - besu550(icol,k,kcomp)=0.0_r8 - basu550(icol,k,kcomp)=0.0_r8 - besu670(icol,k,kcomp)=0.0_r8 -! basu670(icol,k,kcomp)=0.0_r8 - besu870(icol,k,kcomp)=0.0_r8 -! basu870(icol,k,kcomp)=0.0_r8 - bebg550lt1(icol,k,kcomp)=0.0_r8 - bebg550gt1(icol,k,kcomp)=0.0_r8 - bebc550lt1(icol,k,kcomp)=0.0_r8 - bebc550gt1(icol,k,kcomp)=0.0_r8 - beoc550lt1(icol,k,kcomp)=0.0_r8 - beoc550gt1(icol,k,kcomp)=0.0_r8 - besu550lt1(icol,k,kcomp)=0.0_r8 - besu550gt1(icol,k,kcomp)=0.0_r8 - backsc550(icol,k,kcomp)=0.0_r8 - end do - end do - - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kcomp).gt.0) then - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - t_ifb1 = ifbc1(icol,k,kcomp) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cat(kcomp,t_ict1) - t_cat2 = cat(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbc1 = fbc(t_ifb1) - t_fbc2 = fbc(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfbc = xfbc(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - -! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - d2mx(4) = (t_fbc2-t_xfbc) - dxm1(4) = (t_xfbc-t_fbc1) - invd(4) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - do iv=1,38 ! variable number - - opt5d(1,1,1,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - -! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before opt' - - opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) & - /(t_rh2-t_rh1) - -! write(*,*) opt(iv) - - end do ! iv=1,38 - - bext440(icol,k,kcomp)=opt(1) - bext500(icol,k,kcomp)=opt(2) - bext670(icol,k,kcomp)=opt(3) - bext870(icol,k,kcomp)=opt(4) - bebg440(icol,k,kcomp)=opt(5) - bebg500(icol,k,kcomp)=opt(6) - bebg670(icol,k,kcomp)=opt(7) - bebg870(icol,k,kcomp)=opt(8) - bebc440(icol,k,kcomp)=opt(9) - bebc500(icol,k,kcomp)=opt(10) - bebc670(icol,k,kcomp)=opt(11) - bebc870(icol,k,kcomp)=opt(12) - beoc440(icol,k,kcomp)=opt(13) - beoc500(icol,k,kcomp)=opt(14) - beoc670(icol,k,kcomp)=opt(15) - beoc870(icol,k,kcomp)=opt(16) - besu440(icol,k,kcomp)=opt(17) - besu500(icol,k,kcomp)=opt(18) - besu670(icol,k,kcomp)=opt(19) - besu870(icol,k,kcomp)=opt(20) - babs440(icol,k,kcomp)=opt(21) - babs500(icol,k,kcomp)=opt(22) - babs550(icol,k,kcomp)=opt(23) - babs670(icol,k,kcomp)=opt(24) - babs870(icol,k,kcomp)=opt(25) - bebg550lt1(icol,k,kcomp)=opt(26) - bebg550gt1(icol,k,kcomp)=opt(27) - bebc550lt1(icol,k,kcomp)=opt(28) - bebc550gt1(icol,k,kcomp)=opt(29) - beoc550lt1(icol,k,kcomp)=opt(30) - beoc550gt1(icol,k,kcomp)=opt(31) - besu550lt1(icol,k,kcomp)=opt(32) - besu550gt1(icol,k,kcomp)=opt(33) - backsc550(icol,k,kcomp)=opt(34) - babg550(icol,k,kcomp)=opt(35) - babc550(icol,k,kcomp)=opt(36) - baoc550(icol,k,kcomp)=opt(37) - basu550(icol,k,kcomp)=opt(38) - bebg550(icol,k,kcomp)=opt(26)+opt(27) - bebc550(icol,k,kcomp)=opt(28)+opt(29) - beoc550(icol,k,kcomp)=opt(30)+opt(31) - besu550(icol,k,kcomp)=opt(32)+opt(33) - bext550(icol,k,kcomp)=bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & - +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) - - endif - - - end do ! icol - end do ! k - - end do ! kcomp - - return - -end subroutine intaeropt5to10 - - - - diff --git a/src/physics/cam_oslo/interp_aeropt_mod.F90 b/src/physics/cam_oslo/interp_aeropt_mod.F90 new file mode 100644 index 0000000000..f7e9bec6f7 --- /dev/null +++ b/src/physics/cam_oslo/interp_aeropt_mod.F90 @@ -0,0 +1,1282 @@ +module update_aeropt_mod + + use shr_kind_mod , only : r8 => shr_kind_r8 + use ppgrid , only : pcols, pver + use commondefinitions , only : nmodes, nbmodes + use opttab , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg + use oslo_control , only : oslo_getopts, dir_string_length + use cam_logfile , only : iulog + + implicit none + private + + ! Set by init_aeropt Mode0 + real(r8) :: bex440, bax440 + real(r8) :: bex500, bax500, bax550 + real(r8) :: bex670, bax670, + real(r8) :: bex870, bax870 + real(r8) :: bex550lt1, bex550gt1, backscx550 + + ! Set by init_aeropt Mode1 + real(r8), public :: bep1(38,10,6,16,6) + + ! Set by init_aeropt Mode2to3 + real(r8), public :: bep2to3 (38,10,16,6,2:3) + + ! Set by init_aeropt Mode4 + real(r8), public :: bep4(38,10,6,16,6,6) + + ! Set by init_aeropt Mode5to10 + real(r8), public :: bep5to10(38,10,6,6,6,6,5:10) + + + ! Modal total and absorption extiction coefficients (for AeroCom) + ! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). + ! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). + type, public :: extinction_coeffs_type + real(r8) :: bext440(pcols,pver,0:nbmodes) + real(r8) :: babs440(pcols,pver,0:nbmodes) + real(r8) :: bext500(pcols,pver,0:nbmodes) + real(r8) :: babs500(pcols,pver,0:nbmodes) + real(r8) :: bext550(pcols,pver,0:nbmodes) + real(r8) :: babs550(pcols,pver,0:nbmodes) + real(r8) :: bext670(pcols,pver,0:nbmodes) + real(r8) :: babs670(pcols,pver,0:nbmodes) + real(r8) :: bext870(pcols,pver,0:nbmodes) + real(r8) :: babs870(pcols,pver,0:nbmodes) + real(r8) :: bebg440(pcols,pver,0:nbmodes) + real(r8) :: bebg500(pcols,pver,0:nbmodes) + real(r8) :: bebg550(pcols,pver,0:nbmodes) + real(r8) :: babg550(pcols,pver,0:nbmodes) + real(r8) :: bebg670(pcols,pver,0:nbmodes) + real(r8) :: bebg870(pcols,pver,0:nbmodes) + real(r8) :: bebc440(pcols,pver,0:nbmodes) + real(r8) :: bebc500(pcols,pver,0:nbmodes) + real(r8) :: bebc550(pcols,pver,0:nbmodes) + real(r8) :: babc550(pcols,pver,0:nbmodes) + real(r8) :: bebc670(pcols,pver,0:nbmodes) + real(r8) :: bebc870(pcols,pver,0:nbmodes) + real(r8) :: beoc440(pcols,pver,0:nbmodes) + real(r8) :: beoc500(pcols,pver,0:nbmodes) + real(r8) :: beoc550(pcols,pver,0:nbmodes) + real(r8) :: baoc550(pcols,pver,0:nbmodes) + real(r8) :: beoc670(pcols,pver,0:nbmodes) + real(r8) :: beoc870(pcols,pver,0:nbmodes) + real(r8) :: besu440(pcols,pver,0:nbmodes) + real(r8) :: besu500(pcols,pver,0:nbmodes) + real(r8) :: besu550(pcols,pver,0:nbmodes) + real(r8) :: basu550(pcols,pver,0:nbmodes) + real(r8) :: besu670(pcols,pver,0:nbmodes) + real(r8) :: besu870(pcols,pver,0:nbmodes) + real(r8) :: bebg550lt1(pcols,pver,0:nbmodes) + real(r8) :: bebg550gt1(pcols,pver,0:nbmodes) + real(r8) :: bebc550lt1(pcols,pver,0:nbmodes) + real(r8) :: bebc550gt1(pcols,pver,0:nbmodes) + real(r8) :: beoc550lt1(pcols,pver,0:nbmodes) + real(r8) :: beoc550gt1(pcols,pver,0:nbmodes) + real(r8) :: besu550lt1(pcols,pver,0:nbmodes) + real(r8) :: besu550gt1(pcols,pver,0:nbmodes) + real(r8) :: backsc550(pcols,pver,0:nbmodes) + + contains + procedure :: zero_coeffs + procedure :: update_coeffs + end type extinction_coeffs_type + + type(extinction_coeffs_type), public :: extinction_coeffs + type(extinction_coeffs_type), public :: extinction_coeffsn + + public :: init_aeropt + public :: update_aeropt0 + public :: update_aeropt1 + public :: update_aeropt2to3 + public :: update_aeropt4 + public :: update_aeropt5to10 + +! ========================================================== +contains +! ========================================================== + + subroutine init_aeropt + + !Purpose: To read in the AeroCom look-up tables for aerosol optical properties. + ! The grid for discrete input-values in the look-up tables is defined in opptab. + + ! Tabulating the 'aerocomk'-files to save computing time. + ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 + ! Extended for new SOA treatment - Alf Kirkevaag, September 2015. + ! Modified for optimized added masses and mass fractions for + ! concentrations from condensation, coagulation or cloud-processing + ! - Alf Kirkevaag, May 2016. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + + integer :: ic, ifil, lin, iv + integer :: kcomp, irelh, ictot, ifac, ifbc, ifaq + integer :: ifombg, ifbcbg + real(r8) :: catot, relh, frbcbg, frac, fabc, fraq + real(r8) :: bext440, babs440, bext500, babs500, babs550 + real(r8) :: bext670, babs670, bext870, babs870 + real(r8) :: bebg440, babg440, bebg500, babg500, babg550 + real(r8) :: bebg670, babg670, bebg870, babg870 + real(r8) :: bebc440, babc440, bebc500, babc500, babc550 + real(r8) :: bebc670, babc670, bebc870, babc870 + real(r8) :: beoc440, baoc440, beoc500, baoc500, baoc550 + real(r8) :: beoc670, baoc670, beoc870, baoc870 + real(r8) :: besu440, basu440, besu500, basu500, basu550 + real(r8) :: besu670, basu670, besu870, basu870 + real(r8) :: bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1 + real(r8) :: beoc550lt1, beoc550gt1, besu550lt1, besu550gt1 + real(r8) :: backscat550 + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 + character(len=dir_string_length) :: aerotab_table_dir + !----------------------------------------------------------- + + call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' , form='formatted',status='old') + open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' , form='formatted',status='old') + open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' , form='formatted',status='old') + open(14,file=trim(aerotab_table_dir)//'/aerocomk5.out' , form='formatted',status='old') + open(15,file=trim(aerotab_table_dir)//'/aerocomk6.out' , form='formatted',status='old') + open(16,file=trim(aerotab_table_dir)//'/aerocomk7.out' , form='formatted',status='old') + open(17,file=trim(aerotab_table_dir)//'/aerocomk8.out' , form='formatted',status='old') + open(18,file=trim(aerotab_table_dir)//'/aerocomk9.out' , form='formatted',status='old') + open(19,file=trim(aerotab_table_dir)//'/aerocomk10.out', form='formatted',status='old') + open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' , form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' , form='formatted',status='old') + + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 11,21 + call checkTableHeader (ifil) + enddo + ! + !------------------------------------------- + ! Mode 0, BC(ax + !------------------------------------------- + ! + read(20,'(I2,f6.3,12e11.4)') & + kcomp, relh, & + bex440, bax440, bex500, bax500, bax550, bex670, bax670, & + bex870, bax870, bex550lt1, bex550gt1, backscx550 + + if(bex440<=0.0_r8) then + write(*,*) 'bex440 =', bex440 + write(*,*) 'Error in initialization of bex1' + stop + endif + write(iulog,*)'aerocom mode 0 ok' + ! + !------------------------------------------- + ! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) + !------------------------------------------- + ! + do lin = 1,5760 ! 10x6x16x6 + read(21,'(I2,f6.3,3e10.3,38e10.3)') & + kcomp, relh, frombg, catot, frac, & + bext440, bext500, bext670, bext870, & + bebg440, bebg500, bebg670, bebg870, & + bebc440, bebc500, bebc670, bebc870, & + beoc440, beoc500, beoc670, beoc870, & + besu440, besu500, besu670, besu870, & + babs440, babs500, babs550, babs670, babs870, & + bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & + beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & + backscat550, babg550, babc550, baoc550, basu550 + + do ic=1,10 + if(abs(relh-rh(ic)) 0 + end do ! icol + end do ! k + + end subroutine update_aeropt2to3 + + ! ========================================================== + subroutine update_aeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & + extinction_coeffs) + + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer , intent(in) :: irh1(pcols,pver) + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xfbcbg(pcols,pver) + integer , intent(in) :: ifbcbg1(pcols,pver) + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer , intent(in) :: ifaq1(pcols,pver,nbmodes) + type(extinction_coeffs), intent(inout) :: extinction_coeffs + + ! Local variables + real(r8) :: a, b, e, eps + integer :: i, iv, kcomp, k, icol, kc10 + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 + real(r8) :: t_fbcbg1, t_fbcbg2 + integer :: t_ifb1, t_ifb2 + real(r8) :: t_faq1, t_faq2, t_xfaq + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 + real(r8) :: t_cat1, t_cat2 + real(r8) :: t_xfbcbg + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: opt1, opt2, opt(38) + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! BC&OC(Ait) mode: + kcomp = 4 + extinction_coeffs%zero_coeffs(kcomp, ncol) + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kc10).gt.0) then + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ifb1 = ifbcbg1(icol,k) + t_ifb2 = t_ifb1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xfbcbg = xfbcbg(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fbcbg2-t_xfbcbg) + dxm1(2) = (t_xfbcbg-t_fbcbg1) + invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + do iv=1,38 ! variable number + + opt5d(1,1,1,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) + + ! finally, interpolation in the rh dimension + opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + + end do ! iv=1,38 + + ! determine extinction coefficient + extinction_coeffs%update_coeffs(icol, k, kcomp, opt) + + end if ! Nnatk > 0 + end do ! icol + end do ! k + + end subroutine update_aeropt4 + + ! ========================================================== + subroutine update_aeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + extinction_coeffs) + + ! Arguments + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer , intent(in) :: irh1(pcols,pver) + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) + integer , intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer , intent(in) :: ifaq1(pcols,pver,nbmodes) + + ! Local variables + real(r8) :: a, b, e, eps + integer :: i, iv, kcomp, k, icol + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 + integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) :: t_faq1, t_faq2, t_xfaq + real(r8) :: t_fbc1, t_fbc2, t_xfbc + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 + real(r8) :: t_cat1, t_cat2 + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: opt1, opt2, opt(38) + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): + + do kcomp=5,10 + ! zero extinction coefficients for this kcomp + extinction_coeffs%zero_coeffs(kcomp, ncol) + + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kcomp).gt.0) then + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + t_ifb1 = ifbc1(icol,k,kcomp) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cat(kcomp,t_ict1) + t_cat2 = cat(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbc1 = fbc(t_ifb1) + t_fbc2 = fbc(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfbc = xfbc(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + d2mx(4) = (t_fbc2-t_xfbc) + dxm1(4) = (t_xfbc-t_fbc1) + invd(4) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + do iv=1,38 ! variable number + opt5d(1,1,1,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) + + ! finally, interpolation in the rh dimension + opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + + end do ! iv=1,38 + + ! determine extinction coefficient + extinction_coeffs%update_coeffs(icol, k, kcomp, opt) + + end if ! Nnatk > 0 + end do ! icol + end do ! k + end do ! kcomp + + end subroutine update_aeropt5to10 + + ! ========================================================== + subroutine zero_coeffs(this, kcomp, ncol) + + class(extinction_coeffs_type) :: this + integer , intent(in) :: kcomp + integer , intent(in) :: ncol + + integer :: k + integer :: icol + + ! initialize all output fields to zero + do k=1,pver + do icol=1,ncol + this%bext440(icol,k,kcomp) = 0.0_r8 + this%babs440(icol,k,kcomp) = 0.0_r8 + this%bext500(icol,k,kcomp) = 0.0_r8 + this%babs500(icol,k,kcomp) = 0.0_r8 + this%bext550(icol,k,kcomp) = 0.0_r8 + this%babs550(icol,k,kcomp) = 0.0_r8 + this%bext670(icol,k,kcomp) = 0.0_r8 + this%babs670(icol,k,kcomp) = 0.0_r8 + this%bext870(icol,k,kcomp) = 0.0_r8 + this%babs870(icol,k,kcomp) = 0.0_r8 + this%bebg440(icol,k,kcomp) = 0.0_r8 + this%bebg500(icol,k,kcomp) = 0.0_r8 + this%bebg550(icol,k,kcomp) = 0.0_r8 + this%babg550(icol,k,kcomp) = 0.0_r8 + this%bebg670(icol,k,kcomp) = 0.0_r8 + this%bebg870(icol,k,kcomp) = 0.0_r8 + this%bebc440(icol,k,kcomp) = 0.0_r8 + this%bebc500(icol,k,kcomp) = 0.0_r8 + this%bebc550(icol,k,kcomp) = 0.0_r8 + this%babc550(icol,k,kcomp) = 0.0_r8 + this%bebc670(icol,k,kcomp) = 0.0_r8 + this%bebc870(icol,k,kcomp) = 0.0_r8 + this%beoc440(icol,k,kcomp) = 0.0_r8 + this%beoc500(icol,k,kcomp) = 0.0_r8 + this%beoc550(icol,k,kcomp) = 0.0_r8 + this%baoc550(icol,k,kcomp) = 0.0_r8 + this%beoc670(icol,k,kcomp) = 0.0_r8 + this%beoc870(icol,k,kcomp) = 0.0_r8 + this%besu440(icol,k,kcomp) = 0.0_r8 + this%besu500(icol,k,kcomp) = 0.0_r8 + this%besu550(icol,k,kcomp) = 0.0_r8 + this%basu550(icol,k,kcomp) = 0.0_r8 + this%besu670(icol,k,kcomp) = 0.0_r8 + this%besu870(icol,k,kcomp) = 0.0_r8 + this%bebg550lt1(icol,k,kcomp) = 0.0_r8 + this%bebg550gt1(icol,k,kcomp) = 0.0_r8 + this%bebc550lt1(icol,k,kcomp) = 0.0_r8 + this%bebc550gt1(icol,k,kcomp) = 0.0_r8 + this%beoc550lt1(icol,k,kcomp) = 0.0_r8 + this%beoc550gt1(icol,k,kcomp) = 0.0_r8 + this%besu550lt1(icol,k,kcomp) = 0.0_r8 + this%besu550gt1(icol,k,kcomp) = 0.0_r8 + this%backsc550(icol,k,kcomp) = 0.0_r8 + end do + end do + + end subroutine zero_coeffs + + ! ========================================================== + subroutine update_coeffs(this, icol, k, kcomp) + + class(extinction_coeffs_type) :: this + integer , intent(in) :: icol + integer , intent(in) :: k + integer , intent(in) :: kcomp + real(r8) , intent(in) :: opt(:) + + this%bext440(icol,k,kcomp) = opt(1) + this%bext500(icol,k,kcomp) = opt(2) + this%bext670(icol,k,kcomp) = opt(3) + this%bext870(icol,k,kcomp) = opt(4) + this%bebg440(icol,k,kcomp) = opt(5) + this%bebg500(icol,k,kcomp) = opt(6) + this%bebg670(icol,k,kcomp) = opt(7) + this%bebg870(icol,k,kcomp) = opt(8) + this%bebc440(icol,k,kcomp) = opt(9) + this%bebc500(icol,k,kcomp) = opt(10) + this%bebc670(icol,k,kcomp) = opt(11) + this%bebc870(icol,k,kcomp) = opt(12) + this%beoc440(icol,k,kcomp) = opt(13) + this%beoc500(icol,k,kcomp) = opt(14) + this%beoc670(icol,k,kcomp) = opt(15) + this%beoc870(icol,k,kcomp) = opt(16) + this%besu440(icol,k,kcomp) = opt(17) + this%besu500(icol,k,kcomp) = opt(18) + this%besu670(icol,k,kcomp) = opt(19) + this%besu870(icol,k,kcomp) = opt(20) + this%babs440(icol,k,kcomp) = opt(21) + this%babs500(icol,k,kcomp) = opt(22) + this%babs550(icol,k,kcomp) = opt(23) + this%babs670(icol,k,kcomp) = opt(24) + this%babs870(icol,k,kcomp) = opt(25) + this%bebg550lt1(icol,k,kcomp) = opt(26) + this%bebg550gt1(icol,k,kcomp) = opt(27) + this%bebc550lt1(icol,k,kcomp) = opt(28) + this%bebc550gt1(icol,k,kcomp) = opt(29) + this%beoc550lt1(icol,k,kcomp) = opt(30) + this%beoc550gt1(icol,k,kcomp) = opt(31) + this%besu550lt1(icol,k,kcomp) = opt(32) + this%besu550gt1(icol,k,kcomp) = opt(33) + this%backsc550(icol,k,kcomp) = opt(34) + this%babg550(icol,k,kcomp) = opt(35) + this%babc550(icol,k,kcomp) = opt(36) + this%baoc550(icol,k,kcomp) = opt(37) + this%basu550(icol,k,kcomp) = opt(38) + this%bebg550(icol,k,kcomp) = opt(26)+opt(27) + this%bebc550(icol,k,kcomp) = opt(28)+opt(29) + this%beoc550(icol,k,kcomp) = opt(30)+opt(31) + this%besu550(icol,k,kcomp) = opt(32)+opt(33) + this%bext550(icol,k,kcomp) = bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & + +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) + + end subroutine update_coeffs + +end module update_aeropt_mod + diff --git a/src/physics/cam_oslo/update_aeropt_mod.F90 b/src/physics/cam_oslo/update_aeropt_mod.F90 index 751f76df9f..57b9004818 100644 --- a/src/physics/cam_oslo/update_aeropt_mod.F90 +++ b/src/physics/cam_oslo/update_aeropt_mod.F90 @@ -16,53 +16,52 @@ module update_aeropt_mod ! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). ! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). - real(r8), allocatable :: bext440(:,:,:) - real(r8), allocatable :: babs440(:,:,:) - real(r8), allocatable :: bext500(:,:,:) - real(r8), allocatable :: babs500(:,:,:) - real(r8), allocatable :: bext550(:,:,:) - real(r8), allocatable :: babs550(:,:,:) - real(r8), allocatable :: bext670(:,:,:) - real(r8), allocatable :: babs670(:,:,:) - real(r8), allocatable :: bext870(:,:,:) - real(r8), allocatable :: babs870(:,:,:) - real(r8), allocatable :: bebg440(:,:,:) - real(r8), allocatable :: bebg500(:,:,:) - real(r8), allocatable :: bebg550(:,:,:) - real(r8), allocatable :: babg550(:,:,:) - real(r8), allocatable :: bebg670(:,:,:) - real(r8), allocatable :: bebg870(:,:,:) - real(r8), allocatable :: bebc440(:,:,:) - real(r8), allocatable :: bebc500(:,:,:) - real(r8), allocatable :: bebc550(:,:,:) - real(r8), allocatable :: babc550(:,:,:) - real(r8), allocatable :: bebc670(:,:,:) - real(r8), allocatable :: bebc870(:,:,:) - real(r8), allocatable :: beoc440(:,:,:) - real(r8), allocatable :: beoc500(:,:,:) - real(r8), allocatable :: beoc550(:,:,:) - real(r8), allocatable :: baoc550(:,:,:) - real(r8), allocatable :: beoc670(:,:,:) - real(r8), allocatable :: beoc870(:,:,:) - real(r8), allocatable :: besu440(:,:,:) - real(r8), allocatable :: besu500(:,:,:) - real(r8), allocatable :: besu550(:,:,:) - real(r8), allocatable :: basu550(:,:,:) - real(r8), allocatable :: besu670(:,:,:) - real(r8), allocatable :: besu870(:,:,:) - real(r8), allocatable :: bebg550lt1(:,:,:) - real(r8), allocatable :: bebg550gt1(:,:,:) - real(r8), allocatable :: bebc550lt1(:,:,:) - real(r8), allocatable :: bebc550gt1(:,:,:) - real(r8), allocatable :: beoc550lt1(:,:,:) - real(r8), allocatable :: beoc550gt1(:,:,:) - real(r8), allocatable :: besu550lt1(:,:,:) - real(r8), allocatable :: besu550gt1(:,:,:) - real(r8), allocatable :: backsc550(:,:,:) + real(r8) :: bext440(pcols,pver,0:nbmodes) + real(r8) :: babs440(pcols,pver,0:nbmodes) + real(r8) :: bext500(pcols,pver,0:nbmodes) + real(r8) :: babs500(pcols,pver,0:nbmodes) + real(r8) :: bext550(pcols,pver,0:nbmodes) + real(r8) :: babs550(pcols,pver,0:nbmodes) + real(r8) :: bext670(pcols,pver,0:nbmodes) + real(r8) :: babs670(pcols,pver,0:nbmodes) + real(r8) :: bext870(pcols,pver,0:nbmodes) + real(r8) :: babs870(pcols,pver,0:nbmodes) + real(r8) :: bebg440(pcols,pver,0:nbmodes) + real(r8) :: bebg500(pcols,pver,0:nbmodes) + real(r8) :: bebg550(pcols,pver,0:nbmodes) + real(r8) :: babg550(pcols,pver,0:nbmodes) + real(r8) :: bebg670(pcols,pver,0:nbmodes) + real(r8) :: bebg870(pcols,pver,0:nbmodes) + real(r8) :: bebc440(pcols,pver,0:nbmodes) + real(r8) :: bebc500(pcols,pver,0:nbmodes) + real(r8) :: bebc550(pcols,pver,0:nbmodes) + real(r8) :: babc550(pcols,pver,0:nbmodes) + real(r8) :: bebc670(pcols,pver,0:nbmodes) + real(r8) :: bebc870(pcols,pver,0:nbmodes) + real(r8) :: beoc440(pcols,pver,0:nbmodes) + real(r8) :: beoc500(pcols,pver,0:nbmodes) + real(r8) :: beoc550(pcols,pver,0:nbmodes) + real(r8) :: baoc550(pcols,pver,0:nbmodes) + real(r8) :: beoc670(pcols,pver,0:nbmodes) + real(r8) :: beoc870(pcols,pver,0:nbmodes) + real(r8) :: besu440(pcols,pver,0:nbmodes) + real(r8) :: besu500(pcols,pver,0:nbmodes) + real(r8) :: besu550(pcols,pver,0:nbmodes) + real(r8) :: basu550(pcols,pver,0:nbmodes) + real(r8) :: besu670(pcols,pver,0:nbmodes) + real(r8) :: besu870(pcols,pver,0:nbmodes) + real(r8) :: bebg550lt1(pcols,pver,0:nbmodes) + real(r8) :: bebg550gt1(pcols,pver,0:nbmodes) + real(r8) :: bebc550lt1(pcols,pver,0:nbmodes) + real(r8) :: bebc550gt1(pcols,pver,0:nbmodes) + real(r8) :: beoc550lt1(pcols,pver,0:nbmodes) + real(r8) :: beoc550gt1(pcols,pver,0:nbmodes) + real(r8) :: besu550lt1(pcols,pver,0:nbmodes) + real(r8) :: besu550gt1(pcols,pver,0:nbmodes) + real(r8) :: backsc550(pcols,pver,0:nbmodes) contains - procedure :: allocate_coeffs procedure :: zero_coeffs procedure :: update_coeffs @@ -81,57 +80,6 @@ module update_aeropt_mod contains ! ========================================================== - subroutine allocate_coeffs(this) - - class(extinction_coeffs_type) :: this - - allocate(this_coeffs%bext440(pcols,pver,0:nbmodes)) - allocate(this_coeffs%babs440(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bext500(pcols,pver,0:nbmodes)) - allocate(this_coeffs%babs500(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bext550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%babs550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bext670(pcols,pver,0:nbmodes)) - allocate(this_coeffs%babs670(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bext870(pcols,pver,0:nbmodes)) - allocate(this_coeffs%babs870(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebg440(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebg500(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebg550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%babg550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebg670(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebg870(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebc440(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebc500(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebc550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%babc550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebc670(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebc870(pcols,pver,0:nbmodes)) - allocate(this_coeffs%beoc440(pcols,pver,0:nbmodes)) - allocate(this_coeffs%beoc500(pcols,pver,0:nbmodes)) - allocate(this_coeffs%beoc550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%baoc550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%beoc670(pcols,pver,0:nbmodes)) - allocate(this_coeffs%beoc870(pcols,pver,0:nbmodes)) - allocate(this_coeffs%besu440(pcols,pver,0:nbmodes)) - allocate(this_coeffs%besu500(pcols,pver,0:nbmodes)) - allocate(this_coeffs%besu550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%basu550(pcols,pver,0:nbmodes)) - allocate(this_coeffs%besu670(pcols,pver,0:nbmodes)) - allocate(this_coeffs%besu870(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebg550lt1(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebg550gt1(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebc550lt1(pcols,pver,0:nbmodes)) - allocate(this_coeffs%bebc550gt1(pcols,pver,0:nbmodes)) - allocate(this_coeffs%beoc550lt1(pcols,pver,0:nbmodes)) - allocate(this_coeffs%beoc550gt1(pcols,pver,0:nbmodes)) - allocate(this_coeffs%besu550lt1(pcols,pver,0:nbmodes)) - allocate(this_coeffs%besu550gt1(pcols,pver,0:nbmodes)) - allocate(this_coeffs%backsc550(pcols,pver,0:nbmodes)) - - end subroutine allocate_coeffs - - ! ========================================================== subroutine zero_coeffs(this, kcomp, ncol) class(extinction_coeffs_type) :: this From 2654ffd21da523a1d35fb164672b4f4a6e9ce90c Mon Sep 17 00:00:00 2001 From: mvertens Date: Sun, 13 Aug 2023 18:19:19 +0200 Subject: [PATCH 03/71] more updates --- src/NorESM/physpkg.F90 | 3 +- src/physics/cam_oslo/aero_to_srf.F90 | 332 -- src/physics/cam_oslo/aerodry.h | 13 - src/physics/cam_oslo/aerodry_mod.F90 | 1063 +++- .../{aeropt_mod.F90 => aeroopt_mod.F90} | 20 +- src/physics/cam_oslo/init_aeropt_mod.F90 | 517 -- src/physics/cam_oslo/initdryp.F90 | 489 -- src/physics/cam_oslo/inputForInterpol.F90 | 183 - src/physics/cam_oslo/intdrypar0.F90 | 148 - src/physics/cam_oslo/intdrypar1.F90 | 274 -- src/physics/cam_oslo/intdrypar2to3.F90 | 221 - src/physics/cam_oslo/intdrypar4.F90 | 278 -- src/physics/cam_oslo/intdrypar5to10.F90 | 241 - src/physics/cam_oslo/interp_aeropt_mod.F90 | 1282 ----- src/physics/cam_oslo/intfrh.F90 | 156 - src/physics/cam_oslo/intfrh_mod.F90 | 140 + src/physics/cam_oslo/lininterpol3dim.F90 | 41 - src/physics/cam_oslo/lininterpol4dim.F90 | 51 - src/physics/cam_oslo/lininterpol5dim.F90 | 69 - src/physics/cam_oslo/opticsAtConstRh.F90 | 38 +- src/physics/cam_oslo/optinterpol.F90 | 3553 +++++++------- src/physics/cam_oslo/opttab.F90 | 929 ++-- src/physics/cam_oslo/pmxsub.F90 | 4270 ++++++++--------- src/physics/cam_oslo/update_aeropt_mod.F90 | 768 --- 24 files changed, 5298 insertions(+), 9781 deletions(-) delete mode 100644 src/physics/cam_oslo/aero_to_srf.F90 delete mode 100644 src/physics/cam_oslo/aerodry.h rename src/physics/cam_oslo/{aeropt_mod.F90 => aeroopt_mod.F90} (99%) delete mode 100644 src/physics/cam_oslo/init_aeropt_mod.F90 delete mode 100644 src/physics/cam_oslo/initdryp.F90 delete mode 100644 src/physics/cam_oslo/inputForInterpol.F90 delete mode 100644 src/physics/cam_oslo/intdrypar0.F90 delete mode 100644 src/physics/cam_oslo/intdrypar1.F90 delete mode 100644 src/physics/cam_oslo/intdrypar2to3.F90 delete mode 100644 src/physics/cam_oslo/intdrypar4.F90 delete mode 100644 src/physics/cam_oslo/intdrypar5to10.F90 delete mode 100644 src/physics/cam_oslo/interp_aeropt_mod.F90 delete mode 100644 src/physics/cam_oslo/intfrh.F90 create mode 100644 src/physics/cam_oslo/intfrh_mod.F90 delete mode 100644 src/physics/cam_oslo/lininterpol3dim.F90 delete mode 100644 src/physics/cam_oslo/lininterpol4dim.F90 delete mode 100644 src/physics/cam_oslo/lininterpol5dim.F90 delete mode 100644 src/physics/cam_oslo/update_aeropt_mod.F90 diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index 7ab42928cb..b54289dd68 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -11,9 +11,7 @@ module physpkg ! Nov 2010 A. Gettelman Put micro/macro physics into separate routines !----------------------------------------------------------------------- -#ifdef OSLO_AERO #include -#endif use shr_kind_mod, only: r8 => shr_kind_r8 use spmd_utils, only: masterproc @@ -35,6 +33,7 @@ module physpkg use perf_mod use cam_logfile, only: iulog use camsrfexch, only: cam_export + use intfrh_mod, only: intfrh use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg use modal_aero_wateruptake, only: modal_aero_wateruptake_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg diff --git a/src/physics/cam_oslo/aero_to_srf.F90 b/src/physics/cam_oslo/aero_to_srf.F90 deleted file mode 100644 index 4dee8566e2..0000000000 --- a/src/physics/cam_oslo/aero_to_srf.F90 +++ /dev/null @@ -1,332 +0,0 @@ -module aero_to_srf - -!------------------------------------------------------------------------------------------------ -! Purpose: -! -! Partition the contributions from modal components of wet and dry -! deposition at the surface into the fields passed to the coupler. -! -! *** N.B. *** Currently only a simple scheme for the 3-mode version -! of MAM has been implemented. -! -! Revision history: -! Feb 2009 M. Flanner, B. Eaton Original version for trop_mam3. -! Sept 2009 � Seland Modified to CAM-Oslo aerosol physics. -! The initialisation part is not used at present time. -!------------------------------------------------------------------------------------------------ - -#include - -use shr_kind_mod, only: r8 => shr_kind_r8 -use camsrfexch, only: cam_out_t -use constituents, only: pcnst, cnst_get_ind -use ppgrid, only: pcols -use aerosoldef -implicit none -private -save - -public :: & - modal_aero_deposition_init, & - set_srf_drydep, & - set_srf_wetdep - -! Private module data -integer :: idx_bc1 = -1 -integer :: idx_pom1 = -1 -integer :: idx_soa1 = -1 -integer :: idx_soa2 = -1 -integer :: idx_dst1 = -1 -integer :: idx_dst3 = -1 -integer :: idx_ncl3 = -1 -integer :: idx_so43 = -1 -integer :: idx_num3 = -1 - -!============================================================================== -contains -!============================================================================== - -subroutine modal_aero_deposition_init() - -! set aerosol indices for re-mapping surface deposition fluxes: -! *_a1 = accumulation mode -! *_a2 = aitken mode -! *_a3 = coarse mode - - ! Currently only trop_mam3 scheme is implemented. -#ifndef MODAL_AERO_3MODE - return -#endif - - call cnst_get_ind('bc_a1', idx_bc1) - call cnst_get_ind('pom_a1', idx_pom1) - call cnst_get_ind('soa_a1', idx_soa1) - call cnst_get_ind('soa_a2', idx_soa2) - call cnst_get_ind('dst_a1', idx_dst1) - call cnst_get_ind('dst_a3', idx_dst3) - call cnst_get_ind('ncl_a3', idx_ncl3) - call cnst_get_ind('so4_a3', idx_so43) - call cnst_get_ind('num_a3', idx_num3) - -end subroutine modal_aero_deposition_init - -!============================================================================== -subroutine set_srf_wetdep(wetdepflx, cam_out) - -! Set surface wet deposition fluxes passed to coupler. - - ! Arguments: -!Does not differentiate between different wet scavenging processes -! real(r8), intent(in) :: aerdepwetis(pcols,pcnst) -! aerosol wet deposition (interstitial) -! aerosol wet deposition (cloud water) - real(r8), intent(in) :: wetdepflx(pcols,pcnst) - - type(cam_out_t), intent(inout) :: cam_out ! cam export state - - ! Local variables: - integer :: i - integer :: ncol ! number of columns -!cak -! Mass fractions of deposited sea-salt modes a2 and a3 which belong to size bins 1-4. -! Particle diameters < 0.1 um and > 20 um are not included (size bins are defined w.r.t. -! particle diameters, confirmed by Mark Flanner) -real(r8), parameter :: fdst1a2 = 5.55e-1_r8 -real(r8), parameter :: fdst2a2 = 4.29e-1_r8 -real(r8), parameter :: fdst3a2 = 1.59e-2_r8 -real(r8), parameter :: fdst4a2 = 1.32e-4_r8 -real(r8), parameter :: fdst1a3 = 4.84e-3_r8 -real(r8), parameter :: fdst2a3 = 1.01e-1_r8 -real(r8), parameter :: fdst3a3 = 2.96e-1_r8 -real(r8), parameter :: fdst4a3 = 5.99e-1_r8 -!with cut-off at 10 um (not recommended by Mark Flanner) as for the optics calculations: -!real(r8), parameter :: fdst4a3 = 3.73e-1_r8 -!cak - !---------------------------------------------------------------------------- - - ! Currently only trop_mam3 scheme is implemented. - ! CAM_OSLO added -#ifdef AEROFFL - return -#endif - - ncol = cam_out%ncol - - ! derive cam_out variables from deposition fluxes - ! note: wet deposition fluxes are negative into surface, - ! dry deposition fluxes are positive into surface. - ! CLM wants positive definite fluxes. -! OS Only bcphi and dst1 is used - do i = 1, ncol - ! black carbon fluxes - cam_out%bcphiwet(i) = - (wetdepflx(i,l_bc_n)+wetdepflx(i,l_bc_ax) & - +wetdepflx(i,l_bc_ni)+wetdepflx(i,l_bc_a) & - +wetdepflx(i,l_bc_ai)+wetdepflx(i,l_bc_ac)) -!(aerdepwetis(i,idx_bc1)+aerdepwetcw(i,idx_bc1)) - - ! organic carbon fluxes -! cam_out%ocphiwet(i) = -(aerdepwetis(i,idx_pom1)+aerdepwetis(i,idx_soa1)+aerdepwetcw(i,idx_pom1)+aerdepwetcw(i,idx_soa1)) -!cak_temp - cam_out%ocphiwet(i) = 0._r8 -! cam_out%ocphiwet(i) = 1.e-20_r8 -!cak_temp - - ! dust fluxes - ! - ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: -! os All dust aerosols -!cak cam_out%dstwet1(i) = -(wetdepflx(i,l_dst_a2)+wetdepflx(i,l_dst_a3)) - cam_out%dstwet1(i) = -(fdst1a2*wetdepflx(i,l_dst_a2)+fdst1a3*wetdepflx(i,l_dst_a3)) -!cak - -!(aerdepwetis(i,idx_dst1)+aerdepwetcw(i,idx_dst1)) - -! ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: -! cam_out%dstwet2(i) = 0._r8 -! cam_out%dstwet3(i) = -(aerdepwetis(i,idx_dst3)+aerdepwetcw(i,idx_dst3)) -! cam_out%dstwet4(i) = 0._r8 - - ! in rare cases, integrated deposition tendency is upward - if (cam_out%bcphiwet(i) .lt. 0._r8) cam_out%bcphiwet(i) = 0._r8 -!t2 if (cam_out%bcphiwet(i) .lt. 0._r8) cam_out%bcphiwet(i) = 1.e-20_r8 -! if (cam_out%bcphiwet(i) .le. 0._r8) cam_out%bcphiwet(i) = 1.e-20_r8 -!feil if (cam_out%dstwet3(i) .lt. 0._r8) cam_out%dstwet3(i) = 0._r8 - if (cam_out%dstwet1(i) .lt. 0._r8) cam_out%dstwet1(i) = 0._r8 -!t2 if (cam_out%dstwet1(i) .lt. 0._r8) cam_out%dstwet1(i) = 1.e-20_r8 -! if (cam_out%dstwet1(i) .le. 0._r8) cam_out%dstwet1(i) = 1.e-20_r8 -!cak_temp - cam_out%dstwet2(i) = -(fdst2a2*wetdepflx(i,l_dst_a2)+fdst2a3*wetdepflx(i,l_dst_a3)) - cam_out%dstwet3(i) = -(fdst3a2*wetdepflx(i,l_dst_a2)+fdst3a3*wetdepflx(i,l_dst_a3)) - cam_out%dstwet4(i) = -(fdst4a2*wetdepflx(i,l_dst_a2)+fdst4a3*wetdepflx(i,l_dst_a3)) - if (cam_out%dstwet2(i).lt.0._r8) cam_out%dstwet2(i) = 0._r8 - if (cam_out%dstwet3(i).lt.0._r8) cam_out%dstwet3(i) = 0._r8 - if (cam_out%dstwet4(i).lt.0._r8) cam_out%dstwet4(i) = 0._r8 -!t2 if (cam_out%dstwet2(i).lt.0._r8) cam_out%dstwet2(i) = 1.e-20_r8 -!t2 if (cam_out%dstwet3(i).lt.0._r8) cam_out%dstwet3(i) = 1.e-20_r8 -!t2 if (cam_out%dstwet4(i).lt.0._r8) cam_out%dstwet4(i) = 1.e-20_r8 -! if (cam_out%dstwet2(i).le.0._r8) cam_out%dstwet2(i) = 1.e-20_r8 -! if (cam_out%dstwet3(i).le.0._r8) cam_out%dstwet3(i) = 1.e-20_r8 -! if (cam_out%dstwet4(i).le.0._r8) cam_out%dstwet4(i) = 1.e-20_r8 -!cak_temp - -!cak_0 -! cam_out%bcphiwet(i) = 1.e-20_r8 -! cam_out%ocphiwet(i) = 1.e-20_r8 -! cam_out%dstwet1(i) = 1.e-20_r8 -! cam_out%dstwet2(i) = 1.e-20_r8 -! cam_out%dstwet3(i) = 1.e-20_r8 -! cam_out%dstwet4(i) = 1.e-20_r8 -! cam_out%bcphiwet(i) = 1.e-7_r8 ! TEST !!! -! cam_out%dstwet1(i) = 1.e-11_r8 -! cam_out%dstwet2(i) = 1.e-10_r8 -! cam_out%dstwet3(i) = 1.e-09_r8 -! cam_out%dstwet4(i) = 1.e-08_r8 -! if(i==ncol) then -! write(*,*) 'bcphiwet = ', cam_out%bcphiwet(i) -! write(*,*) 'dstwet1 = ', cam_out%dstwet1(i) -! write(*,*) 'dstwet2 = ', cam_out%dstwet2(i) -! write(*,*) 'dstwet3 = ', cam_out%dstwet3(i) -! write(*,*) 'dstwet4 = ', cam_out%dstwet4(i) -! endif -!cak_0 - - enddo - -end subroutine set_srf_wetdep - -!============================================================================== - -subroutine set_srf_drydep(sflx, cam_out) - -! Set surface dry deposition fluxes passed to coupler. - - ! Arguments: - real(r8), intent(in) :: sflx(pcols,pcnst) ! aerosol dry deposition (interstitial) - type(cam_out_t), intent(inout) :: cam_out ! cam export state - - ! Local variables: - integer :: i - integer :: ncol ! number of columns -!cak -! Mass fractions of deposited sea-salt modes a2 and a3 which belong to size bins 1-4. -! Particle diameters < 0.1 um and > 20 um are not included (size bins are defined w.r.t. -! particle diameters, confirmed by Mark Flanner) -real(r8), parameter :: fdst1a2 = 5.55e-1_r8 -real(r8), parameter :: fdst2a2 = 4.29e-1_r8 -real(r8), parameter :: fdst3a2 = 1.59e-2_r8 -real(r8), parameter :: fdst4a2 = 1.32e-4_r8 -real(r8), parameter :: fdst1a3 = 4.84e-3_r8 -real(r8), parameter :: fdst2a3 = 1.01e-1_r8 -real(r8), parameter :: fdst3a3 = 2.96e-1_r8 -real(r8), parameter :: fdst4a3 = 5.99e-1_r8 -!with cut-off at 10 um (not recommended by Mark Flanner) as for the optics calculations: -!real(r8), parameter :: fdst4a3 = 3.73e-1_r8 -!cak - !---------------------------------------------------------------------------- - -!cak write(*,*) 'test dry 1' - - ! Currently only trop_mam3 scheme is implemented. -#ifdef AEROFFL - return -#endif - -!cak write(*,*) 'test dry 2' - - ncol = cam_out%ncol - - ! derive cam_out variables from deposition fluxes - ! note: wet deposition fluxes are negative into surface, - ! dry deposition fluxes are positive into surface. - ! CLM wants positive definite fluxes. -!cak: all cam_out fluxes are positive definite here... - do i = 1, ncol - ! black carbon fluxes -!cak_old cam_out%bcphidry(i) = -(sflx(i,l_bc_n)+sflx(i,l_bc_ax) & -!cak_old + sflx(i,l_bc_ni)+sflx(i,l_bc_a)+sflx(i,l_bc_ai)+sflx(i,l_bc_ac)) - cam_out%bcphidry(i) = -(sflx(i,l_bc_ni)+sflx(i,l_bc_a)+sflx(i,l_bc_ai)+sflx(i,l_bc_ac)) -!cak_temp - cam_out%bcphodry(i) = -(sflx(i,l_bc_n)+sflx(i,l_bc_ax)) -!cak_old cam_out%bcphodry(i) = 0._r8 -! cam_out%bcphodry(i) = 1.e-20_r8 -!cak_temp - - ! organic carbon fluxes -! cam_out%ocphidry(i) = aerdepdryis(i,idx_pom1)+aerdepdryis(i,idx_soa1)+aer!depdrycw(i,idx_pom1)+aerdepdrycw(i,idx_soa1) -! cam_out%ocphodry(i) = aerdepdryis(i,idx_soa2)+aerdepdrycw(i,idx_soa2) -!cak_temp - cam_out%ocphidry(i) = 0._r8 - cam_out%ocphodry(i) = 0._r8 -! cam_out%ocphidry(i) = 1.e-20_r8 -! cam_out%ocphodry(i) = 1.e-20_r8 -!cak_temp - - ! dust fluxes - ! - ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: -!cak cam_out%dstdry1(i) = -(sflx(i,l_dst_a2)+sflx(i,l_dst_a3)) - cam_out%dstdry1(i) = -(fdst1a2*sflx(i,l_dst_a2)+fdst1a3*sflx(i,l_dst_a3)) -!cak -!aerdepdryis(i,idx_dst1)+aerdepdrycw(i,idx_dst1) - - ! Two options for partitioning deposition into bins 2-4: - ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: -! cam_out%dstdry2(i) = 0._r8 -! cam_out%dstdry3(i) = aerdepdryis(i,idx_dst3)+aerdepdrycw(i,idx_dst3) -! cam_out%dstdry4(i) = 0._r8 - - ! in rare cases, integrated deposition tendency is upward - if (cam_out%bcphidry(i) .lt. 0._r8) cam_out%bcphidry(i) = 0._r8 -!t2 if (cam_out%bcphidry(i) .lt. 0._r8) cam_out%bcphidry(i) = 1.e-20_r8 -! if (cam_out%bcphidry(i) .le. 0._r8) cam_out%bcphidry(i) = 1.e-20_r8 - if (cam_out%dstdry1(i) .lt. 0._r8) cam_out%dstdry1(i) = 0._r8 -!t2 if (cam_out%dstdry1(i) .lt. 0._r8) cam_out%dstdry1(i) = 1.e-20_r8 -! if (cam_out%dstdry1(i) .le. 0._r8) cam_out%dstdry1(i) = 1.e-20_r8 -!cak_temp -! cam_out%dstdry2(i) = 0._r8 -! cam_out%dstdry3(i) = 0._r8 -! cam_out%dstdry4(i) = 0._r8 - cam_out%dstdry2(i) = -(fdst2a2*sflx(i,l_dst_a2)+fdst2a3*sflx(i,l_dst_a3)) - cam_out%dstdry3(i) = -(fdst3a2*sflx(i,l_dst_a2)+fdst3a3*sflx(i,l_dst_a3)) - cam_out%dstdry4(i) = -(fdst4a2*sflx(i,l_dst_a2)+fdst4a3*sflx(i,l_dst_a3)) - if (cam_out%dstdry2(i).lt.0._r8) cam_out%dstdry2(i) = 0._r8 - if (cam_out%dstdry3(i).lt.0._r8) cam_out%dstdry3(i) = 0._r8 - if (cam_out%dstdry4(i).lt.0._r8) cam_out%dstdry4(i) = 0._r8 -!t2 if (cam_out%dstdry2(i).lt.0._r8) cam_out%dstdry2(i) = 1.e-20_r8 -!t2 if (cam_out%dstdry3(i).lt.0._r8) cam_out%dstdry3(i) = 1.e-20_r8 -!t2 if (cam_out%dstdry4(i).lt.0._r8) cam_out%dstdry4(i) = 1.e-20_r8 -! if (cam_out%dstdry2(i).le.0._r8) cam_out%dstdry2(i) = 1.e-20_r8 -! if (cam_out%dstdry3(i).le.0._r8) cam_out%dstdry3(i) = 1.e-20_r8 -! if (cam_out%dstdry4(i).le.0._r8) cam_out%dstdry4(i) = 1.e-20_r8 -!cak_temp - -!cak_0 -! cam_out%bcphidry(i) = 1.e-20_r8 -! cam_out%bcphodry(i) = 1.e-20_r8 -! cam_out%ocphidry(i) = 1.e-20_r8 -! cam_out%ocphodry(i) = 1.e-20_r8 -! cam_out%dstdry1(i) = 1.e-20_r8 -! cam_out%dstdry2(i) = 1.e-20_r8 -! cam_out%dstdry3(i) = 1.e-20_r8 -! cam_out%dstdry4(i) = 1.e-20_r8 -! cam_out%bcphidry(i) = 1.e-7_r8 ! TEST !!! -! cam_out%dstdry1(i) = 1.e-11_r8 -! cam_out%dstdry2(i) = 1.e-10_r8 -! cam_out%dstdry3(i) = 1.e-09_r8 -! cam_out%dstdry4(i) = 1.e-08_r8 -! if(i==ncol) then -! write(*,*) 'bcphidry = ', cam_out%bcphidry(i) -! write(*,*) 'dstdry1 = ', cam_out%dstdry1(i) -! write(*,*) 'dstdry2 = ', cam_out%dstdry2(i) -! write(*,*) 'dstdry3 = ', cam_out%dstdry3(i) -! write(*,*) 'dstdry4 = ', cam_out%dstdry4(i) -! endif -!cak_0 - - enddo - -end subroutine set_srf_drydep - -!============================================================================== - -end module aero_to_srf diff --git a/src/physics/cam_oslo/aerodry.h b/src/physics/cam_oslo/aerodry.h deleted file mode 100644 index 03ca519713..0000000000 --- a/src/physics/cam_oslo/aerodry.h +++ /dev/null @@ -1,13 +0,0 @@ -! For subroutine initdryp and intdrypar: - - common /dryarr1/ & - a0cintbg, a0cintbg05, a0cintbg125, & - a0aaeros, a0aaerol, a0vaeros, a0vaerol, & - a1var, a2to3var, a4var, a5to10var - - real(r8) a0cintbg, a0cintbg05, a0cintbg125, & - a0aaeros, a0aaerol, a0vaeros, a0vaerol - real(r8) a1var(19,6,16,6) - real(r8) a2to3var(19,16,6,2:3) - real(r8) a4var(19,6,16,6,6) - real(r8) a5to10var(19,6,6,6,6,5:10) diff --git a/src/physics/cam_oslo/aerodry_mod.F90 b/src/physics/cam_oslo/aerodry_mod.F90 index bd90052867..490492bdb7 100644 --- a/src/physics/cam_oslo/aerodry_mod.F90 +++ b/src/physics/cam_oslo/aerodry_mod.F90 @@ -1,50 +1,106 @@ -module aero_dry +module aerdry_mod - use shr_kind_mod, only: r8 => shr_kind_r8 - use oslo_control, only: oslo_getopts, dir_string_length - use commondefinitions, only: nmodes, nbmodes - use opttab, only: cate, cat, fac, faq, fbc, fombg, fbcbg - use cam_logfile, only: iulog + use shr_kind_mod , only: r8 => shr_kind_r8 + use ppgrid , only: pcols, pver + use commondefinitions , only: nmodes, nbmodes + use opttab , only: cate, cat, fac, faq, fbc, fombg, fbcbg + use optinterpol , only: lininterpol3dim, lininterpol4dim, lininterpol5dim + use oslo_control , only: oslo_getopts, dir_string_length + use cam_logfile , only: iulog implicit none private - - ! For subroutine initdryp and intdrypar: - + ! Set by init_dryp Mode0 real(r8) :: a0cintbg, a0cintbg05, a0cintbg125 real(r8) :: a0aaeros, a0aaerol, a0vaeros, a0vaerol + + ! Set by init_dryp Mode1 real(r8) :: a1var(19,6,16,6) + + ! Set by init_dryp Mode2to3 real(r8) :: a2to3var(19,16,6,2:3) + + ! Set by init_dryp Mode4 real(r8) :: a4var(19,6,16,6,6) + + ! Set by init_dryp Mode5 real(r8) :: a5to10var(19,6,6,6,6,5:10) + type, public :: aerodry_prop_type + ! modal mass concentrations (cint), area (aaero) and volume (vaero) + ! (for AeroCom determination of particle effective radii) of each constituent. + ! cint*05 and cint*125 are for r<0.5um and r>1.25um, respectively. + ! aaeros and vaeros are integrated over r<0.5um, and aaerol and vaerol over r>0.5um. + + real(r8) :: cintbg(pcols,pver,0:nbmodes) + real(r8) :: cintbg05(pcols,pver,0:nbmodes) + real(r8) :: cintbg125(pcols,pver,0:nbmodes) + real(r8) :: cintbc(pcols,pver,0:nbmodes) + real(r8) :: cintbc05(pcols,pver,0:nbmodes) + real(r8) :: cintbc125(pcols,pver,0:nbmodes) + real(r8) :: cintoc(pcols,pver,0:nbmodes) + real(r8) :: cintoc05(pcols,pver,0:nbmodes) + real(r8) :: cintoc125(pcols,pver,0:nbmodes) + real(r8) :: cintsc(pcols,pver,0:nbmodes) + real(r8) :: cintsc05(pcols,pver,0:nbmodes) + real(r8) :: cintsc125(pcols,pver,0:nbmodes) + real(r8) :: cintsa(pcols,pver,0:nbmodes) + real(r8) :: cintsa05(pcols,pver,0:nbmodes) + real(r8) :: cintsa125(pcols,pver,0:nbmodes) + real(r8) :: aaeros(pcols,pver,0:nbmodes) + real(r8) :: aaerol(pcols,pver,0:nbmodes), + real(r8) :: vaeros(pcols,pver,0:nbmodes) + real(r8) :: vaerol(pcols,pver,0:nbmodes) + + real(r8) :: aaerosn(pcols,pver,nbmp1:nmodes) + real(r8) :: aaeroln(pcols,pver,nbmp1:nmodes) + real(r8) :: vaerosn(pcols,pver,nbmp1:nmodes) + real(r8) :: vaeroln(pcols,pver,nbmp1:nmodes) + real(r8) :: cknorm(pcols,pver,0:nmodes) + real(r8) :: cknlt05(pcols,pver,0:nmodes) + real(r8) :: ckngt125(pcols,pver,0:nmodes) + + contains + procedure :: initdryp + procedure :: intdrypar0 + procedure :: intdrypar1 + procedure :: intdrypar2to3 + procedure :: intdrypar4 + procedure :: intdrypar5to10 + procedure :: zero + procedure :: update + + end type aerodry_prop_type + + type(aero_prop_type) :: aerodry_prop + + ! ========================================================== contains + ! ========================================================== subroutine initdryp !Purpose: To read in the AeroCom look-up tables for calculation of dry - ! aerosol size and mass distribution properties. The grid for discrete - ! input-values in the look-up tables is defined in opptab. + ! aerosol size and mass distribution properties. The grid for discrete + ! input-values in the look-up tables is defined in opptab. ! Tabulating the 'aerodryk'-files to save computing time. Routine - ! originally made by Alf Kirkevaag, and modified for new aerosol + ! originally made by Alf Kirkevaag, and modified for new aerosol ! schemes in January 2006. - ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, + ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, ! May 2013, and extended for new SOA treatment October 2015. - ! Modified for optimized added masses and mass fractions for - ! concentrations from condensation, coagulation or cloud-processing - ! - Alf Kirkevaag, May 2016. - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - - + ! Modified for optimized added masses and mass fractions for + ! concentrations from condensation, coagulation or cloud-processing + ! - Alf Kirkevaag, May 2016. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. integer :: iv, kcomp, ifombg, ifbcbg, ictot, ifac, ifbc, ifaq integer :: ic, ifil, lin real(r8) :: frombg, frbcbg, catot, frac, fabc, fraq real(r8) :: cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125 real(r8) :: cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125 - real(r8) :: cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol + real(r8) :: cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol real(r8) :: eps2 = 1.e-2_r8 real(r8) :: eps4 = 1.e-4_r8 real(r8) :: eps6 = 1.e-6_r8 @@ -53,6 +109,8 @@ subroutine initdryp call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + open(20,file=trim(aerotab_table_dir)//'/aerodryk0.out' ,form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/aerodryk1.out' ,form='formatted',status='old') open(11,file=trim(aerotab_table_dir)//'/aerodryk2.out' ,form='formatted',status='old') open(12,file=trim(aerotab_table_dir)//'/aerodryk3.out' ,form='formatted',status='old') open(13,file=trim(aerotab_table_dir)//'/aerodryk4.out' ,form='formatted',status='old') @@ -62,39 +120,41 @@ subroutine initdryp open(17,file=trim(aerotab_table_dir)//'/aerodryk8.out' ,form='formatted',status='old') open(18,file=trim(aerotab_table_dir)//'/aerodryk9.out' ,form='formatted',status='old') open(19,file=trim(aerotab_table_dir)//'/aerodryk10.out' ,form='formatted',status='old') - open(20,file=trim(aerotab_table_dir)//'/aerodryk0.out' ,form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/aerodryk1.out' ,form='formatted',status='old') - ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) do ifil = 11,21 call checkTableHeader (ifil) enddo ! + !------------------------------------------- ! Mode 0, BC(ax) + !------------------------------------------- ! ifil = 11 - read(9+ifil,996) kcomp, cintbg, cintbg05, cintbg125, aaeros, aaerol, vaeros, vaerol + + read(20,996) kcomp, cintbg, cintbg05, cintbg125, aaeros, aaerol, vaeros, vaerol ! no ictot-, ifac-, ifbc- or ifaq-dependency for this mode, - ! since BC(ax) is purely externally mixed + ! since BC(ax) is purely externally mixed + a0cintbg=cintbg a0cintbg05=cintbg05 a0cintbg125=cintbg125 + a0aaeros=aaeros a0aaerol=aaerol a0vaeros=vaeros a0vaerol=vaerol write(iulog,*)'mode 0 ok' - ! + !------------------------------------------- ! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) - ! - ifil = 1 - do lin = 1,576 ! 6x16x6 + !------------------------------------------- - read(20+ifil,997) kcomp, frombg, catot, frac, & + do lin = 1,576 ! 6x16x6 + read(21,997) kcomp, frombg, catot, frac, & cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol do ic=1,6 @@ -116,30 +176,32 @@ subroutine initdryp endif end do - ! no ifombg-dependency for this mode, since all catot - !comes from condensate or from wet-phase sulfate - - a1var(1,ifombg,ictot,ifac) =cintbg - a1var(2,ifombg,ictot,ifac) =cintbg05 - a1var(3,ifombg,ictot,ifac) =cintbg125 - a1var(4,ifombg,ictot,ifac) =cintbc - a1var(5,ifombg,ictot,ifac) =cintbc05 - a1var(6,ifombg,ictot,ifac) =cintbc125 - a1var(7,ifombg,ictot,ifac) =cintoc - a1var(8,ifombg,ictot,ifac) =cintoc05 - a1var(9,ifombg,ictot,ifac) =cintoc125 - a1var(10,ifombg,ictot,ifac) =cintsc - a1var(11,ifombg,ictot,ifac) =cintsc05 - a1var(12,ifombg,ictot,ifac) =cintsc125 - a1var(13,ifombg,ictot,ifac) =cintsa - a1var(14,ifombg,ictot,ifac) =cintsa05 - a1var(15,ifombg,ictot,ifac) =cintsa125 - a1var(16,ifombg,ictot,ifac) =aaeros - a1var(17,ifombg,ictot,ifac) =aaerol - a1var(18,ifombg,ictot,ifac) =vaeros - a1var(19,ifombg,ictot,ifac) =vaerol - - if(cintsa 0.0_r8) then + cintbg(icol,k,kcomp) = a0cintbg + cintbg05(icol,k,kcomp) = a0cintbg05 + cintbg125(icol,k,kcomp) = a0cintbg125 + cintbc(icol,k,kcomp) = eps + cintbc05(icol,k,kcomp) = eps + cintbc125(icol,k,kcomp) = eps + cintoc(icol,k,kcomp) = eps + cintoc05(icol,k,kcomp) = eps + cintoc125(icol,k,kcomp) = eps + cintsc(icol,k,kcomp) = eps + cintsc05(icol,k,kcomp) = eps + cintsc125(icol,k,kcomp) = eps + cintsa(icol,k,kcomp) = eps + cintsa05(icol,k,kcomp) = eps + cintsa125(icol,k,kcomp) = eps + aaeros(icol,k,kcomp) = a0aaeros + aaerol(icol,k,kcomp) = a0aaerol + vaeros(icol,k,kcomp) = a0vaeros + vaerol(icol,k,kcomp) = a0vaerol + endif + cknorm(icol,k,kcomp) = a0cintbg + cknlt05(icol,k,kcomp) = a0cintbg05 + ckngt125(icol,k,kcomp)= a0cintbg125 + end do ! icol + end do ! k + + end subroutine intdrypar0 + + ! ========================================================== + subroutine intdrypar1 (this, lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, aero_props) + + ! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) + ! (for AeroCom determination of particle effective radii) of each constituent. cint*05 + ! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are + ! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. + + ! Arguments + class(aero_prop_type) :: this + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode (1) + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + + ! Local variables + real(r8) :: a, b, e, eps + integer :: iv, kcomp, k, icol + integer :: t_ifo1, t_ifo2 + integer :: t_ict1, t_ict2, t_ifc1, t_ifc2 + real(r8) :: t_xct, t_cat1, t_cat2 + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_fombg1, t_fombg2, t_xfombg, t_xfombgn + real(r8) :: d2mx(3), dxm1(3), invd(3) + real(r8) :: opt3d(2,2,2) + real(r8) :: opt1, opt2, opt + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + !--------------------- + ! Mode 1, SO4(Ait): + !--------------------- + kcomp=1 + this%zero(kcomp,ncol) + + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kcomp)>0.0_r8) then + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + t_ifo1 = ifombg1(icol,k) + t_ifo2 = t_ifo1+1 + t_fombg1 = fombg(t_ifo1) + t_fombg2 = fombg(t_ifo2) + t_xfombg = xfombg(icol,k) + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + + ! partial lengths along each dimension (1-3) for interpolation + d2mx(1) = (t_fombg2-t_xfombg) + dxm1(1) = (t_xfombg-t_fombg1) + invd(1) = 1.0_r8/(t_fombg2-t_fombg1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + + do iv=1,19 ! variable number + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=a1var(iv,t_ifo1,t_ict1,t_ifc1) + opt3d(1,1,2)=a1var(iv,t_ifo1,t_ict1,t_ifc2) + opt3d(1,2,1)=a1var(iv,t_ifo1,t_ict2,t_ifc1) + opt3d(1,2,2)=a1var(iv,t_ifo1,t_ict2,t_ifc2) + opt3d(2,1,1)=a1var(iv,t_ifo2,t_ict1,t_ifc1) + opt3d(2,1,2)=a1var(iv,t_ifo2,t_ict1,t_ifc2) + opt3d(2,2,1)=a1var(iv,t_ifo2,t_ict2,t_ifc1) + opt3d(2,2,2)=a1var(iv,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac and cat dimensions + call lininterpol3dim (d2mx, dxm1, invd, opt3d, opt1, opt2) + + ! finally, interpolation in the fombg dimension + opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + ! update the properties + this%update(kcomp, ncol, iv, opt) + + end do ! iv=1,19 + endif + end do ! icol + end do ! k + + + ! Dry parameters for externally mixed mode 11, SO4(n): + kcomp=11 + do k=1,pver + do icol=1,ncol + ! Neither total background concentrations (OM + sulfate) + ! nor areas & volumes depend on fombg: + this%cknorm(icol,k,kcomp) = a1var(1,1,1,1) + this%cknlt05(icol,k,kcomp) = a1var(2,1,1,1) + this%ckngt125(icol,k,kcomp) = a1var(3,1,1,1) + this%aaerosn(icol,k,kcomp) = a1var(16,1,1,1) + this%aaeroln(icol,k,kcomp) = a1var(17,1,1,1) + this%vaerosn(icol,k,kcomp) = a1var(18,1,1,1) + this%vaeroln(icol,k,kcomp) = a1var(19,1,1,1) + end do ! icol + end do ! k + + end subroutine intdrypar1 + + ! ========================================================== + subroutine intdrypar2to3 (this, lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1) + + ! Modal mass concentrations (cint), area (aaero) + ! and volume (vaero) (for AeroCom determination of particle + ! effective radii) of each constituent. cint*05 and cint*125 are + ! for r<0.5um and r>1.25um, respectively. aaeros and vaeros are + ! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. + + ! arguments + class(aero_prop_type) :: this + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + + ! local variables + real(r8) :: a, b, e, eps + integer :: iv, kcomp, k, icol + integer :: t_ict1, t_ict2 + real(r8) :: t_xct, t_cat1, t_cat2 + real(r8) :: t_fac1, t_fac2, t_xfac + integer :: t_ifc1, t_ifc2 + real(r8) :: d2mx(2), dxm1(2), invd(2) + real(r8) :: opt2d(2,2) + real(r8) :: opt1, opt2, opt + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! Modes 1-3, SO4(Ait), BC(Ait) and OC(Ait): + + do kcomp=2,3 + this%zero(kcomp, ncol) + end do ! kcomp + + kcomp = 1 + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kcomp)>0.0_r8) then + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_xct = xct(icol,k,kcomp) + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_xfac = xfac(icol,k,kcomp) + + ! partial lengths along each dimension (1-2) for interpolation + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + + do iv=1,19 ! variable number + + ! end points as basis for multidimentional linear interpolation + opt2d(1,1) = a2to3var(iv,t_ict1,t_ifc1,kcomp) + opt2d(1,2) = a2to3var(iv,t_ict1,t_ifc2,kcomp) + opt2d(2,1) = a2to3var(iv,t_ict2,t_ifc1,kcomp) + opt2d(2,2) = a2to3var(iv,t_ict2,t_ifc2,kcomp) + + ! interpolation in the fac dimension + opt1 = (d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(2) + opt2 = (d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(2) + + ! finally, interpolation in the cat dimension + opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + this%update(kcomp, ncol, iv, opt) + end do + end if + end do + end do + + ! Dry parameters for externally mixed modes modes 12-13, + ! BC(n) and OC(n): + + do kcomp=12,13 ! using dummy initialization for kcomp=3 + do k=1,pver + do icol=1,ncol + this%cknorm(icol,k,kcomp) = a2to3var(1,1,1,kcomp-10) + this%cknlt05(icol,k,kcomp) = a2to3var(2,1,1,kcomp-10) + this%ckngt125(icol,k,kcomp)= a2to3var(3,1,1,kcomp-10) + this%aaerosn(icol,k,kcomp) = a2to3var(16,1,1,kcomp-10) + this%aaeroln(icol,k,kcomp) = a2to3var(17,1,1,kcomp-10) + this%vaerosn(icol,k,kcomp) = a2to3var(18,1,1,kcomp-10) + this%vaeroln(icol,k,kcomp) = a2to3var(19,1,1,kcomp-10) + end do ! icol + end do ! k + end do ! kcomp + + end subroutine intdrypar2to3 + + ! ========================================================== + subroutine intdrypar4 (this, lchnk, ncol, Nnatk, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xct, ict1, xfac, ifac1, xfaq, ifaq1) + + ! Output arguments: Modal mass concentrations (cint), area (aaero) + ! and volume (vaero) (for AeroCom determination of particle + ! effective radii) of each constituent. cint*05 and cint*125 are + ! for r<0.5um and r>1.25um, respectively. aaeros and vaeros are + ! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. + + ! arguments + class(aero_prop_type) :: this + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer , intent(in) :: ifaq1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode (4) + integer , intent(in) :: ifbcbg1(pcols,pver) + real(r8) , intent(in) :: xfbcbgn(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode (14) + integer , intent(in) :: ifbcbgn1(pcols,pver) + + ! local variables + real(r8) :: a, b, e, eps + integer :: iv, kcomp, k, icol + integer :: t_ifb1, t_ifb2 + integer :: t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 + real(r8) :: t_fbcbg1, t_fbcbg2 + real(r8) :: t_faq1, t_faq2, t_xfaq + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_xct, t_cat1, t_cat2 + real(r8) :: t_xfbcbg + real(r8) :: d2mx(4), dxm1(4), invd(4) + real(r8) :: opt4d(2,2,2,2) + real(r8) :: opt1, opt2, opt + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! Mode 4, BC&OC(Ait): + kcomp=4 + this%zero(kcomp, ncol) + + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kcomp)>0.0_r8) then + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + t_ifb1 = ifbcbg1(icol,k) + t_ifb2 = t_ifb1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + t_xfbcbg = xfbcbg(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_fbcbg2-t_xfbcbg) + dxm1(1) = (t_xfbcbg-t_fbcbg1) + invd(1) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + d2mx(4) = (t_faq2-t_xfaq) + dxm1(4) = (t_xfaq-t_faq1) + invd(4) = 1.0_r8/(t_faq2-t_faq1) + + do iv=1,19 ! variable number + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=a4var(iv,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt4d(1,1,1,2)=a4var(iv,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt4d(1,1,2,1)=a4var(iv,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt4d(1,1,2,2)=a4var(iv,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt4d(1,2,1,1)=a4var(iv,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt4d(1,2,1,2)=a4var(iv,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt4d(1,2,2,1)=a4var(iv,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt4d(1,2,2,2)=a4var(iv,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt4d(2,1,1,1)=a4var(iv,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt4d(2,1,1,2)=a4var(iv,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt4d(2,1,2,1)=a4var(iv,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt4d(2,1,2,2)=a4var(iv,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt4d(2,2,1,1)=a4var(iv,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt4d(2,2,1,2)=a4var(iv,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt4d(2,2,2,1)=a4var(iv,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt4d(2,2,2,2)=a4var(iv,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac and cat dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) + + ! finally, interpolation in the fbcbg dimension + opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + this%update(kcomp, ncol, iv, opt) + end do + endif + end do ! icol + end do ! k + + kcomp=14 + do k=1,pver + do icol=1,ncol + + t_ifb1 = ifbcbgn1(icol,k) + t_ifb2 = t_ifb1+1 + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_xfbcbg = xfbcbgn(icol,k) + + d2mx(1) = (t_fbcbg2-t_xfbcbg) + dxm1(1) = (t_xfbcbg-t_fbcbg1) + invd(1) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + + ! Only interpolation in the fbcbg dimension for mode 14 + opt1 = a4var(1,1,1,1,1) + opt2 = a4var(1,2,1,1,1) + cknorm(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + opt1 = a4var(2,1,1,1,1) + opt2 = a4var(2,2,1,1,1) + cknlt05(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + opt1 = a4var(3,1,1,1,1) + opt2 = a4var(3,2,1,1,1) + ckngt125(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + ! (The remaining variables are actually independent of fbcbg, + ! but we follow the same procedure anyway:) + + opt1 = a4var(16,1,1,1,1) + opt2 = a4var(16,2,1,1,1) + aaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + opt1 = a4var(17,1,1,1,1) + opt2 = a4var(17,2,1,1,1) + aaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + opt1 = a4var(18,1,1,1,1) + opt2 = a4var(18,2,1,1,1) + vaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + opt1 = a4var(19,1,1,1,1) + opt2 = a4var(19,2,1,1,1) + vaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + end do ! icol + end do ! k + + end subroutine intdrypar4 + + ! ========================================================== + subroutine intdrypar5to10 (this, lchnk, ncol, Nnatk, xct, ict1, & + xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) + + ! Output arguments: Modal mass concentrations (cint), area (aaero) + ! and volume (vaero) (for AeroCom determination of particle + ! effective radii) of each constituent. cint*05 and cint*125 are + ! for r<0.5um and r>1.25um, respectively. aaeros and vaeros are + ! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. + + ! arguments + class(aero_prop_type) :: this + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer , intent(in) :: ict1(pcols,pver,nmodes) + real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) + integer , intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer , intent(in) :: ifaq1(pcols,pver,nbmodes) + + ! local variables + real(r8) :: a, b, e, eps + integer :: iv, kcomp, k, icol + integer :: t_ict1, t_ict2, t_ifa1, t_ifa2 + integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) :: t_faq1, t_faq2, t_xfaq + real(r8) :: t_fbc1, t_fbc2, t_xfbc + real(r8) :: t_fac1, t_fac2, t_xfac + real(r8) :: t_xct, t_cat1, t_cat2 + real(r8) :: d2mx(4), dxm1(4), invd(4) + real(r8) :: opt4d(2,2,2,2) + real(r8) :: opt1, opt2, opt + parameter (e=2.718281828_r8, eps=1.0e-60_r8) + + ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): + + do kcomp=5,10 + this%zero(kcomp,ncol) + + do k=1,pver + do icol=1,ncol + if(Nnatk(icol,k,kcomp)>0.0_r8) then + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifb1 = ifbc1(icol,k,kcomp) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + t_cat1 = cat(kcomp,t_ict1) + t_cat2 = cat(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbc1 = fbc(t_ifb1) + t_fbc2 = fbc(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfbc = xfbc(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + d2mx(3) = (t_fbc2-t_xfbc) + dxm1(3) = (t_xfbc-t_fbc1) + invd(3) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(4) = (t_faq2-t_xfaq) + dxm1(4) = (t_xfaq-t_faq1) + invd(4) = 1.0_r8/(t_faq2-t_faq1) + !soa + + do iv=1,19 ! variable number + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=a5to10var(iv,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt4d(1,1,1,2)=a5to10var(iv,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt4d(1,1,2,1)=a5to10var(iv,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt4d(1,1,2,2)=a5to10var(iv,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt4d(1,2,1,1)=a5to10var(iv,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt4d(1,2,1,2)=a5to10var(iv,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt4d(1,2,2,1)=a5to10var(iv,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt4d(1,2,2,2)=a5to10var(iv,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt4d(2,1,1,1)=a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt4d(2,1,1,2)=a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt4d(2,1,2,1)=a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt4d(2,1,2,2)=a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt4d(2,2,1,1)=a5to10var(iv,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt4d(2,2,1,2)=a5to10var(iv,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt4d(2,2,2,1)=a5to10var(iv,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt4d(2,2,2,2)=a5to10var(iv,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, and fac and dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) + + ! finally, interpolation in the cat dimension + opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) + + this%update(kcomp, ncol, iv, opt) + + end do + endif + + this%cknorm(icol,k,kcomp) = a5to10var(1,1,1,1,1,kcomp) + this%cknlt05(icol,k,kcomp) = a5to10var(2,1,1,1,1,kcomp) + this%ckngt125(icol,k,kcomp)= a5to10var(3,1,1,1,1,kcomp) + + end do ! icol + end do ! k + end do ! kcomp + + end subroutine intdrypar5to10 + + ! ========================================================== + subroutine zero(this, kcomp, ncol) + + class(aero_prop_type) :: this + integer , intent(in) :: kcomp + integer , intent(in) :: ncol + + integer :: k + integer :: icol + + ! initialize all output fields to zero + do k=1,pver + do icol=1,ncol + this%cintbg(icol,k,kcomp) = 0.0_r8 + this%cintbg05(icol,k,kcomp) = 0.0_r8 + this%cintbg125(icol,k,kcomp) = 0.0_r8 + this%cintbc(icol,k,kcomp) = 0.0_r8 + this%cintbc05(icol,k,kcomp) = 0.0_r8 + this%cintbc125(icol,k,kcomp) = 0.0_r8 + this%cintoc(icol,k,kcomp) = 0.0_r8 + this%cintoc05(icol,k,kcomp) = 0.0_r8 + this%cintoc125(icol,k,kcomp) = 0.0_r8 + this%cintsc(icol,k,kcomp) = 0.0_r8 + this%cintsc05(icol,k,kcomp) = 0.0_r8 + this%cintsc125(icol,k,kcomp) = 0.0_r8 + this%cintsa(icol,k,kcomp) = 0.0_r8 + this%cintsa05(icol,k,kcomp) = 0.0_r8 + this%cintsa125(icol,k,kcomp) = 0.0_r8 + this%aaeros(icol,k,kcomp) = 0.0_r8 + this%aaerol(icol,k,kcomp) = 0.0_r8 + this%vaeros(icol,k,kcomp) = 0.0_r8 + this%vaerol(icol,k,kcomp) = 0.0_r8 + end do + end do + end subroutine zero + + ! ========================================================== + subroutine update(this, kcomp, ncol, iv, opt) + + class(aero_prop_type) :: this + integer , intent(in) :: kcomp + integer , intent(in) :: ncol + integer , intent(in) :: iv + real(r8), intent(in) :: opt + + if(iv==1) then + this%cintbg(icol,k,kcomp)=opt + elseif(iv==2) then + this%cintbg05(icol,k,kcomp)=opt + elseif(iv==3) then + this%cintbg125(icol,k,kcomp)=opt + elseif(iv==4) then + this%cintbc(icol,k,kcomp)=opt + elseif(iv==5) then + this%cintbc05(icol,k,kcomp)=opt + elseif(iv==6) then + this%cintbc125(icol,k,kcomp)=opt + elseif(iv==7) then + this%cintoc(icol,k,kcomp)=opt + elseif(iv==8) then + this%cintoc05(icol,k,kcomp)=opt + elseif(iv==9) then + this%cintoc125(icol,k,kcomp)=opt + elseif(iv==10) then + this%cintsc(icol,k,kcomp)=opt + elseif(iv==11) then + this%cintsc05(icol,k,kcomp)=opt + elseif(iv==12) then + this%cintsc125(icol,k,kcomp)=opt + elseif(iv==13) then + this%cintsa(icol,k,kcomp)=opt + elseif(iv==14) then + this%cintsa05(icol,k,kcomp)=opt + elseif(iv==15) then + this%cintsa125(icol,k,kcomp)=opt + elseif(iv==16) then + this%aaeros(icol,k,kcomp)=opt + elseif(iv==17) then + this%aaerol(icol,k,kcomp)=opt + elseif(iv==18) then + this%vaeros(icol,k,kcomp)=opt + elseif(iv==19) then + this%vaerol(icol,k,kcomp)=opt + endif + + end subroutine update + +end module aerdry_mod diff --git a/src/physics/cam_oslo/aeropt_mod.F90 b/src/physics/cam_oslo/aeroopt_mod.F90 similarity index 99% rename from src/physics/cam_oslo/aeropt_mod.F90 rename to src/physics/cam_oslo/aeroopt_mod.F90 index 923c141740..d3afbe5d69 100644 --- a/src/physics/cam_oslo/aeropt_mod.F90 +++ b/src/physics/cam_oslo/aeroopt_mod.F90 @@ -1,4 +1,4 @@ -module aeropt_mod +module aeroopt_mod use shr_kind_mod , only : r8 => shr_kind_r8 use ppgrid , only : pcols, pver @@ -136,6 +136,8 @@ subroutine init_aeropt call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' , form='formatted',status='old') + open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' , form='formatted',status='old') open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' , form='formatted',status='old') open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' , form='formatted',status='old') open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' , form='formatted',status='old') @@ -145,8 +147,6 @@ subroutine init_aeropt open(17,file=trim(aerotab_table_dir)//'/aerocomk8.out' , form='formatted',status='old') open(18,file=trim(aerotab_table_dir)//'/aerocomk9.out' , form='formatted',status='old') open(19,file=trim(aerotab_table_dir)//'/aerocomk10.out', form='formatted',status='old') - open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' , form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' , form='formatted',status='old') ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) do ifil = 11,21 @@ -594,13 +594,13 @@ subroutine init_aeropt end subroutine init_aeropt ! ========================================================== - subroutine update_aeropt0 (lchnk, ncol, Nnatk, extinction_coeffs) + subroutine intaeropt0 (this, lchnk, ncol, Nnatk) ! Arguments + class(extinction_coeffs), intent(inout) :: this integer , intent(in) :: lchnk ! chunk identifier integer , intent(in) :: ncol ! number of atmospheric columns real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - type(extinction_coeffs), intent(inout) :: extinction_coeffs ! Local variables integer i, iv, ierr, k, kcomp, icol @@ -608,7 +608,7 @@ subroutine update_aeropt0 (lchnk, ncol, Nnatk, extinction_coeffs) kcomp=0 extinction_coeffs%zero_coeffs(kcomp, ncol) - ! BC(ax) mode: update below to non-xero values + ! Mode 0 BC(ax) do k = 1,pver do icol = 1,ncol if(Nnatk(icol,k,kcomp).gt.0) then @@ -754,7 +754,7 @@ subroutine update_aeropt1 (lchnk, ncol, xrh, irh1, mplus10, & opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) / (t_rh2-t_rh1) end do ! iv=1,38 - ! determin extinction coefficient + ! determine extinction coefficient extinction_coeffs%update_coeffs(icol, k, kcomp, opt) end if @@ -1165,8 +1165,8 @@ end subroutine update_aeropt5to10 subroutine zero_coeffs(this, kcomp, ncol) class(extinction_coeffs_type) :: this - integer , intent(in) :: kcomp - integer , intent(in) :: ncol + integer , intent(in) :: kcomp + integer , intent(in) :: ncol integer :: k integer :: icol @@ -1277,5 +1277,5 @@ subroutine update_coeffs(this, icol, k, kcomp) +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) end subroutine update_coeffs -end module aeropt_mod +end module aeroopt_mod diff --git a/src/physics/cam_oslo/init_aeropt_mod.F90 b/src/physics/cam_oslo/init_aeropt_mod.F90 deleted file mode 100644 index 2e6a634957..0000000000 --- a/src/physics/cam_oslo/init_aeropt_mod.F90 +++ /dev/null @@ -1,517 +0,0 @@ -module init_aeropt_mod - - use shr_kind_mod , only: r8 => shr_kind_r8 - use oslo_control , only: oslo_getopts, dir_string_length - use commondefinitions , only: nmodes, nbmodes - use opttab , only: cate, cat, fac, faq, fbc, rh, fombg, fbcbg - use cam_logfile , only: iulog - - implicit none - private - - real(r8), public :: bep1 (38, 10, 6, 16, 6 ) - real(r8), public :: bep2to3 (38, 10, 16, 6, 2:3 ) - real(r8), public :: bep4 (38, 10, 6, 16, 6, 6) - real(r8), public :: bep5to10(38, 10, 6, 6, 6, 6, 5:10) - - public :: init_aeropt - -contains - - subroutine init_aeropt - - !Purpose: To read in the AeroCom look-up tables for aerosol optical properties. - ! The grid for discrete input-values in the look-up tables is defined in opptab. - - ! Tabulating the 'aerocomk'-files to save computing time. - ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 - ! Extended for new SOA treatment - Alf Kirkevaag, September 2015. - ! Modified for optimized added masses and mass fractions for - ! concentrations from condensation, coagulation or cloud-processing - ! - Alf Kirkevaag, May 2016. - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - - integer :: ic, ifil, lin, iv - integer :: kcomp, irelh, ictot, ifac, ifbc, ifaq - integer :: ifombg, ifbcbg - real(r8) :: catot, relh, frbcbg, frac, fabc, fraq - real(r8) :: bext440, babs440, bext500, babs500, babs550 - real(r8) :: bext670, babs670, bext870, babs870 - real(r8) :: bebg440, babg440, bebg500, babg500, babg550 - real(r8) :: bebg670, babg670, bebg870, babg870 - real(r8) :: bebc440, babc440, bebc500, babc500, babc550 - real(r8) :: bebc670, babc670, bebc870, babc870 - real(r8) :: beoc440, baoc440, beoc500, baoc500, baoc550 - real(r8) :: beoc670, baoc670, beoc870, baoc870 - real(r8) :: besu440, basu440, besu500, basu500, basu550 - real(r8) :: besu670, basu670, besu870, basu870 - real(r8) :: bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1 - real(r8) :: beoc550lt1, beoc550gt1, besu550lt1, besu550gt1 - real(r8) :: backscat550 - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - real(r8) :: eps7 = 1.e-7_r8 - character(len=dir_string_length) :: aerotab_table_dir - !----------------------------------------------------------- - - call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) - open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' , form='formatted',status='old') - open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' , form='formatted',status='old') - open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' , form='formatted',status='old') - open(14,file=trim(aerotab_table_dir)//'/aerocomk5.out' , form='formatted',status='old') - open(15,file=trim(aerotab_table_dir)//'/aerocomk6.out' , form='formatted',status='old') - open(16,file=trim(aerotab_table_dir)//'/aerocomk7.out' , form='formatted',status='old') - open(17,file=trim(aerotab_table_dir)//'/aerocomk8.out' , form='formatted',status='old') - open(18,file=trim(aerotab_table_dir)//'/aerocomk9.out' , form='formatted',status='old') - open(19,file=trim(aerotab_table_dir)//'/aerocomk10.out', form='formatted',status='old') - open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' , form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' , form='formatted',status='old') - - ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 11,21 - call checkTableHeader (ifil) - enddo - ! - !------------------------------------------- - ! Mode 0, BC(ax - !------------------------------------------- - ! - read(20,'(I2,f6.3,12e11.4)') & - kcomp, relh, & - bex440, bax440, bex500, bax500, bax550, bex670, bax670, & - bex870, bax870, bex550lt1, bex550gt1, backscx550 - - if(bex440<=0.0_r8) then - write(*,*) 'bex440 =', bex440 - write(*,*) 'Error in initialization of bex1' - stop - endif - write(iulog,*)'aerocom mode 0 ok' - ! - !------------------------------------------- - ! New mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) - !------------------------------------------- - ! - do lin = 1,5760 ! 10x6x16x6 - read(21,'(I2,f6.3,3e10.3,38e10.3)') & - kcomp, relh, frombg, catot, frac, & - bext440, bext500, bext670, bext870, & - bebg440, bebg500, bebg670, bebg870, & - bebc440, bebc500, bebc670, bebc870, & - beoc440, beoc500, beoc670, beoc870, & - besu440, besu500, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & - beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & - backscat550, babg550, babc550, baoc550, basu550 - - do ic=1,10 - if(abs(relh-rh(ic)) shr_kind_r8 - use oslo_control, only: oslo_getopts, dir_string_length - use commondefinitions, only: nmodes, nbmodes - use opttab, only: cate, cat, fac, faq, fbc, fombg, fbcbg - use cam_logfile, only: iulog - - implicit none - private - - ! For subroutine initdryp and intdrypar: - - real(r8) :: a0cintbg, a0cintbg05, a0cintbg125 - real(r8) :: a0aaeros, a0aaerol, a0vaeros, a0vaerol - real(r8) :: a1var(19,6,16,6) - real(r8) :: a2to3var(19,16,6,2:3) - real(r8) :: a4var(19,6,16,6,6) - real(r8) :: a5to10var(19,6,6,6,6,5:10) - - type, public :: dry_aerosol_size_type - - real(r8) :: cintbg(pcols,pver,0:nbmodes), - real(r8) :: cintbg05(pcols,pver,0:nbmodes) - real(r8) :: cintbg125(pcols,pver,0:nbmodes) - real(r8) :: cintbc(pcols,pver,0:nbmodes) - real(r8) :: cintbc05(pcols,pver,0:nbmodes) - real(r8) :: cintbc125(pcols,pver,0:nbmodes) - real(r8) :: cintoc(pcols,pver,0:nbmodes) - real(r8) :: cintoc05(pcols,pver,0:nbmodes) - real(r8) :: cintoc125(pcols,pver,0:nbmodes) - real(r8) :: cintsc(pcols,pver,0:nbmodes) - real(r8) :: cintsc05(pcols,pver,0:nbmodes) - real(r8) :: cintsc125(pcols,pver,0:nbmodes) - real(r8) :: cintsa(pcols,pver,0:nbmodes) - real(r8) :: cintsa05(pcols,pver,0:nbmodes) - real(r8) :: cintsa125(pcols,pver,0:nbmodes) - real(r8) :: aaeros(pcols,pver,0:nbmodes) - real(r8) :: aaerol(pcols,pver,0:nbmodes) - real(r8) :: vaeros(pcols,pver,0:nbmodes) - real(r8) :: vaerol(pcols,pver,0:nbmodes) - - contains - - procedure :: zero_coeffs - procedure :: update_coeffs - - end type dry_aerosol_size_type - - -contains - - subroutine initdryp( - - ! Purpose: To read in the AeroCom look-up tables for calculation of dry - ! aerosol size and mass distribution properties. The grid for discrete - ! input-values in the look-up tables is defined in opptab. - - ! Tabulating the 'aerodryk'-files to save computing time. Routine - ! originally made by Alf Kirkevaag, and modified for new aerosol - ! schemes in January 2006. - ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, - ! May 2013, and extended for new SOA treatment October 2015. - ! Modified for optimized added masses and mass fractions for - ! concentrations from condensation, coagulation or cloud-processing - ! - Alf Kirkevaag, May 2016. - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - - integer :: iv, kcomp, ifombg, ifbcbg, ictot, ifac, ifbc, ifaq - integer :: ic, ifil, lin - real(r8) :: frombg, frbcbg, catot, frac, fabc, fraq - real(r8) :: cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125 - real(r8) :: cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125 - real(r8) :: cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - real(r8) :: eps7 = 1.e-7_r8 - character(len=dir_string_length) :: aerotab_table_dir - - call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) - - open(11,file=trim(aerotab_table_dir)//'/aerodryk2.out' ,form='formatted',status='old') - open(12,file=trim(aerotab_table_dir)//'/aerodryk3.out' ,form='formatted',status='old') - open(13,file=trim(aerotab_table_dir)//'/aerodryk4.out' ,form='formatted',status='old') - open(14,file=trim(aerotab_table_dir)//'/aerodryk5.out' ,form='formatted',status='old') - open(15,file=trim(aerotab_table_dir)//'/aerodryk6.out' ,form='formatted',status='old') - open(16,file=trim(aerotab_table_dir)//'/aerodryk7.out' ,form='formatted',status='old') - open(17,file=trim(aerotab_table_dir)//'/aerodryk8.out' ,form='formatted',status='old') - open(18,file=trim(aerotab_table_dir)//'/aerodryk9.out' ,form='formatted',status='old') - open(19,file=trim(aerotab_table_dir)//'/aerodryk10.out' ,form='formatted',status='old') - open(20,file=trim(aerotab_table_dir)//'/aerodryk0.out' ,form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/aerodryk1.out' ,form='formatted',status='old') - - ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 11,21 - call checkTableHeader (ifil) - enddo - - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! Mode 0, BC(ax) - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 11 - - read (9+ifil,996) kcomp, cintbg, cintbg05, cintbg125, & - aaeros, aaerol, vaeros, vaerol - - ! no ictot-, ifac-, ifbc- or ifaq-dependency for this mode, - ! since BC(ax) is purely externally mixed - - a0cintbg=cintbg - a0cintbg05=cintbg05 - a0cintbg125=cintbg125 - - a0aaeros=aaeros - a0aaerol=aaerol - a0vaeros=vaeros - a0vaerol=vaerol - - write(iulog,*)'mode 0 ok' - - - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 1 - do lin = 1,576 ! 6x16x6 - - read(20+ifil,997) kcomp, frombg, catot, frac, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol - - do ic=1,6 - if(abs(frombg-fombg(ic)) shr_kind_r8 - use opttab, only: fombg, fbcbg, cate, cat, fac, faq, fbc, rh, eps - use commondefinitions, only: nbmodes, nmodes - - implicit none - -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: rhum(pcols,pver) ! level relative humidity (fraction) - real(r8), intent(in) :: f_soana(pcols,pver) ! SOA/(SOA+H2SO4) mass fraction for the background in mode 1 - real(r8), intent(in) :: faitbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 4 - real(r8), intent(in) :: fnbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 14 - real(r8), intent(in) :: focm(pcols,pver,4) ! fraction of added mass which is either SOA condensate or OC coagulate - real(r8), intent(in) :: Cam(pcols,pver,nbmodes) ! added internally mixed SO4+BC+OC concentration for a normalized mode - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration - real(r8), intent(in) :: fcm(pcols,pver,nbmodes) ! fraction of added mass which is either BC or OC/SOA (carbonaceous) - real(r8), intent(in) :: fbcm(pcols,pver,nbmodes) ! fraction of added mass as BC/(BC+OC) - real(r8), intent(in) :: faqm(pcols,pver,nbmodes) ! fraction of added sulfate which is from aqueous phase (ammonium sulfate) - real(r8) :: eps10 = 1.e-10_r8 -! -! Output arguments -! - real(r8), intent(out) :: xrh(pcols,pver) ! rhum for use in the interpolations - integer, intent(out) :: irh1(pcols,pver) - real(r8), intent(out) :: xfombg(pcols,pver) ! f_soana for use in the interpolations (mode 1) - integer, intent(out) :: ifombg1(pcols,pver) - real(r8), intent(out) :: xfbcbg(pcols,pver) ! faitbc for use in the interpolations (mode 4) - integer, intent(out) :: ifbcbg1(pcols,pver) - real(r8), intent(out) :: xfbcbgn(pcols,pver) ! fnbc for use in the interpolations (mode 14) - integer, intent(out) :: ifbcbgn1(pcols,pver) - real(r8), intent(out) :: xct(pcols,pver,nmodes) ! Cam/Nnatk for use in the interpolations - integer, intent(out) :: ict1(pcols,pver,nmodes) - real(r8), intent(out) :: xfac(pcols,pver,nbmodes) ! focm (1-4) or fcm (5-10) for use in the interpolations - integer, intent(out) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(out) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations - integer, intent(out) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(out) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations - integer, intent(out) :: ifaq1(pcols,pver,nbmodes) -! -!---------------------------Local variables----------------------------- -! - integer k, icol, i, irelh -! -!------------------------------------------------------------------------ -! - -! write(*,*) 'Before xrh-loop' - do k=1,pver - do icol=1,ncol - xrh(icol,k) = min(max(rhum(icol,k),rh(1)),rh(10)) - end do - end do - -! write(*,*) 'Before rh-loop' - do irelh=1,9 - do k=1,pver - do icol=1,ncol - if(xrh(icol,k) >= rh(irelh).and. & - xrh(icol,k)<=rh(irelh+1)) then - irh1(icol,k)=irelh - endif - end do - end do - end do -! write(*,*) 'xrh, irh1, irh2 =', xrh(1,26), irh1(1,26), irh2(1,26) - - do k=1,pver - do icol=1,ncol -! find common xfombg, ifombg1 and ifombg2 for use in the interpolation routines - xfombg(icol,k) =min(max(f_soana(icol,k),fombg(1)),fombg(6)) - ifombg1(icol,k)=int(5.0_r8*xfombg(icol,k)-eps10)+1 ! Boer linkes til def. i opttab.F90 - end do - enddo - - do k=1,pver - do icol=1,ncol -! find common xfbcbg, ifbcbg1 and ifbcbg2 for use in the interpolation routines - xfbcbg(icol,k) =min(max(faitbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 - ifbcbg1(icol,k)=min(max(int(4*log10(xfbcbg(icol,k))+6),1),5) -! find common xfbcbgn, ifbcbgn1 and ifbcbgn2 for use in the interpolation routines - xfbcbgn(icol,k) =min(max(fnbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 - ifbcbgn1(icol,k)=min(max(int(4*log10(xfbcbgn(icol,k))+6),1),5) - end do - enddo - - do i=1,4 - do k=1,pver - do icol=1,ncol -! find common xfac, ifac1 and ifac2 for use in the interpolation routines - xfac(icol,k,i) =min(max(focm(icol,k,i),fac(1)),fac(6)) - ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 - end do - enddo - enddo - do i=5,nbmodes - do k=1,pver - do icol=1,ncol -! find common xfac, ifac1 and ifac2 for use in the interpolation routines - xfac(icol,k,i) =min(max(fcm(icol,k,i),fac(1)),fac(6)) - ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 - end do - enddo - enddo - - do i=1,nbmodes - do k=1,pver - do icol=1,ncol -! find common xfbc, ifbc1 and ifbc2 for use in the interpolation routines - xfbc(icol,k,i) =min(max(fbcm(icol,k,i),fbc(1)),fbc(6)) ! Boer linkes til def. i opttab.F90 - ifbc1(icol,k,i)=min(max(int(4*log10(xfbc(icol,k,i))+6),1),5) - end do - enddo - enddo - - do i=1,nbmodes - do k=1,pver - do icol=1,ncol -! find common xfaq, ifaq1 and ifaq2 for use in the interpolation routines - xfaq(icol,k,i) =min(max(faqm(icol,k,i),faq(1)),faq(6)) - ifaq1(icol,k,i)=int(5.0_r8*xfaq(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 - end do - enddo - enddo - -! find common xct, ict1 and ict2 for use in the interpolation routines ! Boer linkes til def. i opttab.F90 - do i=1,4 - do k=1,pver - do icol=1,ncol - xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cate(i,1)),cate(i,16)) - if(i.le.2) then - ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+19.666_r8),1),15) - elseif(i.eq.3) then ! mode not used - xct(icol,k,i)=cate(i,1) - ict1(icol,k,i)=1 - else - ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+13.903_r8),1),15) - endif - end do - end do - end do - - do i=5,10 - do k=1,pver - do icol=1,ncol - xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cat(i,1)),cat(i,6)) - if(i.eq.5) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.824_r8),1),5) - elseif(i.eq.6) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.523_r8),1),5) - elseif(i.eq.7) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) - elseif(i.eq.8) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+5.921_r8),1),5) - elseif(i.eq.9) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.301_r8),1),5) - else - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) - endif - end do - end do - end do - - do i=11,nmodes ! for the externally mixed modes 11-14 (now only 12 and 14) - do k=1,pver - do icol=1,ncol - xct(icol,k,i)=cate(i-10,1) - ict1(icol,k,i)=1 - end do - end do - end do - - return - -end subroutine inputForInterpol diff --git a/src/physics/cam_oslo/intdrypar0.F90 b/src/physics/cam_oslo/intdrypar0.F90 deleted file mode 100644 index 21c416a048..0000000000 --- a/src/physics/cam_oslo/intdrypar0.F90 +++ /dev/null @@ -1,148 +0,0 @@ -subroutine intdrypar0 (lchnk, ncol, Nnatk, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - cknorm,cknlt05,ckngt125) - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: cate, cat, fac, faq, fbc, rh - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration -! -! Input-Output arguments -! - real(r8), intent(inout) :: & - cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) -! -! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) -! (for AeroCom determination of particle effective radii) of each constituent. cint*05 -! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are -! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. -! - real(r8), intent(out) :: & - cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & - cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & - cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & - cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & - cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & - aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & - vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - real(r8) a, b, e, eps - - integer i, ierr, kcomp, k, icol - - parameter (eps=1.0e-60_r8) - -! Mode 0, BC(ax): - - kcomp=0 - -! initialize output fields - do k=1,pver - do icol=1,ncol - cintbg(icol,k,kcomp)=0.0_r8 - cintbg05(icol,k,kcomp)=0.0_r8 - cintbg125(icol,k,kcomp)=0.0_r8 - cintbc(icol,k,kcomp)=0.0_r8 - cintbc05(icol,k,kcomp)=0.0_r8 - cintbc125(icol,k,kcomp)=0.0_r8 - cintoc(icol,k,kcomp)=0.0_r8 - cintoc05(icol,k,kcomp)=0.0_r8 - cintoc125(icol,k,kcomp)=0.0_r8 - cintsc(icol,k,kcomp)=0.0_r8 - cintsc05(icol,k,kcomp)=0.0_r8 - cintsc125(icol,k,kcomp)=0.0_r8 - cintsa(icol,k,kcomp)=0.0_r8 - cintsa05(icol,k,kcomp)=0.0_r8 - cintsa125(icol,k,kcomp)=0.0_r8 - aaeros(icol,k,kcomp)=0.0_r8 - aaerol(icol,k,kcomp)=0.0_r8 - vaeros(icol,k,kcomp)=0.0_r8 - vaerol(icol,k,kcomp)=0.0_r8 - end do - end do - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kcomp)>0.0_r8) then - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - do i=1,19 ! variable number - - if(i==1) then - cintbg(icol,k,kcomp)=a0cintbg - elseif(i==2) then - cintbg05(icol,k,kcomp)=a0cintbg05 - elseif(i==3) then - cintbg125(icol,k,kcomp)=a0cintbg125 - elseif(i==4) then - cintbc(icol,k,kcomp)=eps - elseif(i==5) then - cintbc05(icol,k,kcomp)=eps - elseif(i==6) then - cintbc125(icol,k,kcomp)=eps - elseif(i==7) then - cintoc(icol,k,kcomp)=eps - elseif(i==8) then - cintoc05(icol,k,kcomp)=eps - elseif(i==9) then - cintoc125(icol,k,kcomp)=eps - elseif(i==10) then - cintsc(icol,k,kcomp)=eps - elseif(i==11) then - cintsc05(icol,k,kcomp)=eps - elseif(i==12) then - cintsc125(icol,k,kcomp)=eps - elseif(i==13) then - cintsa(icol,k,kcomp)=eps - elseif(i==14) then - cintsa05(icol,k,kcomp)=eps - elseif(i==15) then - cintsa125(icol,k,kcomp)=eps - elseif(i==16) then - aaeros(icol,k,kcomp)=a0aaeros - elseif(i==17) then - aaerol(icol,k,kcomp)=a0aaerol - elseif(i==18) then - vaeros(icol,k,kcomp)=a0vaeros - elseif(i==19) then - vaerol(icol,k,kcomp)=a0vaerol - endif - - end do ! i=1,19 - - endif - - cknorm(icol,k,kcomp) = a0cintbg - cknlt05(icol,k,kcomp) = a0cintbg05 - ckngt125(icol,k,kcomp)= a0cintbg125 - -! if(k.eq.1.or.k.eq.pver) write(*,*) 'cknorm =', cknorm(icol,k,kcomp) -! if(k.eq.1.or.k.eq.pver) write(*,*) 'cknlt05 =', cknlt05(icol,k,kcomp) -! if(k.eq.1.or.k.eq.pver) write(*,*) 'ckngt125 =', ckngt125(icol,k,kcomp) - - end do ! icol - end do ! k - - - return -end subroutine intdrypar0 - - - - diff --git a/src/physics/cam_oslo/intdrypar1.F90 b/src/physics/cam_oslo/intdrypar1.F90 deleted file mode 100644 index 6265ce4b66..0000000000 --- a/src/physics/cam_oslo/intdrypar1.F90 +++ /dev/null @@ -1,274 +0,0 @@ -subroutine intdrypar1 (lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & - aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) - - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: fombg, cate, cat, fac, faq, nbmp1 - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode (1) - integer, intent(in) :: ifombg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) -! -! Input-Output arguments -! - real(r8), intent(inout) :: & - aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & - vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & - cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) -! -! -! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) -! (for AeroCom determination of particle effective radii) of each constituent. cint*05 -! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are -! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. -! - real(r8), intent(out) :: & - cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & - cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & - cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & - cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & - cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & - aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & - vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - real(r8) a, b, e, eps - - integer iv, kcomp, k, icol - -! Temporary storage of often used array elements - integer t_ifo1, t_ifo2 - integer t_ict1, t_ict2, t_ifc1, t_ifc2 - real(r8) t_xct, t_cat1, t_cat2 - real(r8) t_fac1, t_fac2, t_xfac - real(r8) t_fombg1, t_fombg2, t_xfombg, t_xfombgn - - real(r8) d2mx(3), dxm1(3), invd(3) - real(r8) opt3d(2,2,2) - real(r8) opt1, opt2, opt - - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - -! write(*,*) 'Before kcomp-loop' - -! Mode 1, SO4(Ait): - - kcomp=1 - -! initialize output fields - do k=1,pver - do icol=1,ncol - cintbg(icol,k,kcomp)=0.0_r8 - cintbg05(icol,k,kcomp)=0.0_r8 - cintbg125(icol,k,kcomp)=0.0_r8 - cintbc(icol,k,kcomp)=0.0_r8 - cintbc05(icol,k,kcomp)=0.0_r8 - cintbc125(icol,k,kcomp)=0.0_r8 - cintoc(icol,k,kcomp)=0.0_r8 - cintoc05(icol,k,kcomp)=0.0_r8 - cintoc125(icol,k,kcomp)=0.0_r8 - cintsc(icol,k,kcomp)=0.0_r8 - cintsc05(icol,k,kcomp)=0.0_r8 - cintsc125(icol,k,kcomp)=0.0_r8 - cintsa(icol,k,kcomp)=0.0_r8 - cintsa05(icol,k,kcomp)=0.0_r8 - cintsa125(icol,k,kcomp)=0.0_r8 - aaeros(icol,k,kcomp)=0.0_r8 - aaerol(icol,k,kcomp)=0.0_r8 - vaeros(icol,k,kcomp)=0.0_r8 - vaerol(icol,k,kcomp)=0.0_r8 - end do - end do - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kcomp)>0.0_r8) then - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - t_ifo1 = ifombg1(icol,k) - t_ifo2 = t_ifo1+1 - t_fombg1 = fombg(t_ifo1) - t_fombg2 = fombg(t_ifo2) - t_xfombg = xfombg(icol,k) - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - -! partial lengths along each dimension (1-3) for interpolation - d2mx(1) = (t_fombg2-t_xfombg) - dxm1(1) = (t_xfombg-t_fombg1) - invd(1) = 1.0_r8/(t_fombg2-t_fombg1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - do iv=1,19 ! variable number - -! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=a1var(iv,t_ifo1,t_ict1,t_ifc1) - opt3d(1,1,2)=a1var(iv,t_ifo1,t_ict1,t_ifc2) - opt3d(1,2,1)=a1var(iv,t_ifo1,t_ict2,t_ifc1) - opt3d(1,2,2)=a1var(iv,t_ifo1,t_ict2,t_ifc2) - opt3d(2,1,1)=a1var(iv,t_ifo2,t_ict1,t_ifc1) - opt3d(2,1,2)=a1var(iv,t_ifo2,t_ict1,t_ifc2) - opt3d(2,2,1)=a1var(iv,t_ifo2,t_ict2,t_ifc1) - opt3d(2,2,2)=a1var(iv,t_ifo2,t_ict2,t_ifc2) - -! interpolation in the fac and cat dimensions - call lininterpol3dim (d2mx, dxm1, invd, opt3d, opt1, opt2) - -! finally, interpolation in the fombg dimension - opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - -! if(k.eq.1) write(*,*) 'opt1 =', opt - - -! write(*,*) 'Before array' - - if(iv==1) then - cintbg(icol,k,kcomp)=opt - elseif(iv==2) then - cintbg05(icol,k,kcomp)=opt - elseif(iv==3) then - cintbg125(icol,k,kcomp)=opt - elseif(iv==4) then - cintbc(icol,k,kcomp)=opt - elseif(iv==5) then - cintbc05(icol,k,kcomp)=opt - elseif(iv==6) then - cintbc125(icol,k,kcomp)=opt - elseif(iv==7) then - cintoc(icol,k,kcomp)=opt - elseif(iv==8) then - cintoc05(icol,k,kcomp)=opt - elseif(iv==9) then - cintoc125(icol,k,kcomp)=opt - elseif(iv==10) then - cintsc(icol,k,kcomp)=opt - elseif(iv==11) then - cintsc05(icol,k,kcomp)=opt - elseif(iv==12) then - cintsc125(icol,k,kcomp)=opt - elseif(iv==13) then - cintsa(icol,k,kcomp)=opt - elseif(iv==14) then - cintsa05(icol,k,kcomp)=opt - elseif(iv==15) then - cintsa125(icol,k,kcomp)=opt - elseif(iv==16) then - aaeros(icol,k,kcomp)=opt - elseif(iv==17) then - aaerol(icol,k,kcomp)=opt - elseif(iv==18) then - vaeros(icol,k,kcomp)=opt - elseif(iv==19) then - vaerol(icol,k,kcomp)=opt - endif - - end do ! iv=1,19 - - endif - - end do ! icol - end do ! k - - -! Dry parameters for externally mixed mode 11, -! SO4(n): - - kcomp=11 - - do k=1,pver - do icol=1,ncol - -! xfombgn(icol,k) = min(max(xfombgnin(icol,k),fombg(1)),fombg(6)) -! write(*,*) 'Before fombg-loop', kcomp -! do ifombg=1,5 -! if(xfombgn(icol,k) >= fombg(ifombg).and. & -! xfombgn(icol,k) <= fombg(ifombg+1)) then -! ifombgn1(icol,k)=ifombg -! ifombgn2(icol,k)=ifombg+1 -! endif -! end do ! ifombg -! t_ifo1 = ifombgn1(icol,k) -! t_ifo2 = ifombgn2(icol,k) -! t_fombg1 = fombg(t_ifo1) -! t_fombg2 = fombg(t_ifo2) -! t_xfombg = xfombgn(icol,k) -! d2mx(1) = (t_fombg2-t_xfombg) -! dxm1(1) = (t_xfombg-t_fombg1) -! invd(1) = 1.0_r8/(t_fombg2-t_fombg1) -!! Only interpolation in the fombg dimension for mode 11 -! opt1 = a1var(1,1,1,1) -! opt2 = a1var(1,2,1,1) -! cknorm(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) -! opt1 = a1var(2,1,1,1) -! opt2 = a1var(2,2,1,1) -! cknlt05(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) -! opt1 = a1var(3,1,1,1) -! opt2 = a1var(3,2,1,1) -! ckngt125(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) -!! (The remaining variables are actually independent of fbcbg, -!! but we follow the same procedure anyway:) -! opt1 = a1var(16,1,1,1) -! opt2 = a1var(16,2,1,1) -! aaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) -! opt1 = a1var(17,1,1,1) -! opt2 = a1var(17,2,1,1) -! aaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) -! opt1 = a1var(18,1,1,1) -! opt2 = a1var(18,2,1,1) -! vaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) -! opt1 = a1var(19,1,1,1) -! opt2 = a1var(19,2,1,1) -! vaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) -! -! The procedure above is unnessesary, since neither total background -! concentrations (OM + sulfate) nor areas & volumes depend on fombg: - cknorm(icol,k,kcomp) = a1var(1,1,1,1) - cknlt05(icol,k,kcomp) = a1var(2,1,1,1) - ckngt125(icol,k,kcomp) = a1var(3,1,1,1) - aaerosn(icol,k,kcomp) = a1var(16,1,1,1) - aaeroln(icol,k,kcomp) = a1var(17,1,1,1) - vaerosn(icol,k,kcomp) = a1var(18,1,1,1) - vaeroln(icol,k,kcomp) = a1var(19,1,1,1) - - end do ! icol - end do ! k - - - return -end subroutine intdrypar1 diff --git a/src/physics/cam_oslo/intdrypar2to3.F90 b/src/physics/cam_oslo/intdrypar2to3.F90 deleted file mode 100644 index bf7aebfe4b..0000000000 --- a/src/physics/cam_oslo/intdrypar2to3.F90 +++ /dev/null @@ -1,221 +0,0 @@ -subroutine intdrypar2to3 (lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & - aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: cate, cat, fac, nbmp1 - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) -! -! Input-Output arguments -! - real(r8), intent(inout) :: & - aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & - vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & - cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) -! -! -! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) -! (for AeroCom determination of particle effective radii) of each constituent. cint*05 -! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are -! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. -! - real(r8), intent(out) :: & - cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & - cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & - cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & - cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & - cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & - aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & - vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - real(r8) a, b, e, eps - - integer iv, kcomp, k, icol - -! Temporary storage of often used array elements - integer t_ict1, t_ict2 - real(r8) t_xct, t_cat1, t_cat2 - real(r8) t_fac1, t_fac2, t_xfac - integer t_ifc1, t_ifc2 - real(r8) d2mx(2), dxm1(2), invd(2) - real(r8) opt2d(2,2) - real(r8) opt1, opt2, opt - - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - -! write(*,*) 'Before kcomp-loop' - -! Modes 1-3, SO4(Ait), BC(Ait) and OC(Ait): - - do kcomp=2,3 - -! initialize output fields - do k=1,pver - do icol=1,ncol - cintbg(icol,k,kcomp)=0.0_r8 - cintbg05(icol,k,kcomp)=0.0_r8 - cintbg125(icol,k,kcomp)=0.0_r8 - cintbc(icol,k,kcomp)=0.0_r8 - cintbc05(icol,k,kcomp)=0.0_r8 - cintbc125(icol,k,kcomp)=0.0_r8 - cintoc(icol,k,kcomp)=0.0_r8 - cintoc05(icol,k,kcomp)=0.0_r8 - cintoc125(icol,k,kcomp)=0.0_r8 - cintsc(icol,k,kcomp)=0.0_r8 - cintsc05(icol,k,kcomp)=0.0_r8 - cintsc125(icol,k,kcomp)=0.0_r8 - cintsa(icol,k,kcomp)=0.0_r8 - cintsa05(icol,k,kcomp)=0.0_r8 - cintsa125(icol,k,kcomp)=0.0_r8 - aaeros(icol,k,kcomp)=0.0_r8 - aaerol(icol,k,kcomp)=0.0_r8 - vaeros(icol,k,kcomp)=0.0_r8 - vaerol(icol,k,kcomp)=0.0_r8 - end do - end do - - end do ! kcomp - - do kcomp=2,2 - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kcomp)>0.0_r8) then - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_xct = xct(icol,k,kcomp) - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_xfac = xfac(icol,k,kcomp) - -! partial lengths along each dimension (1-2) for interpolation - d2mx(1) = (t_cat2-t_xct) - dxm1(1) = (t_xct-t_cat1) - invd(1) = 1.0_r8/(t_cat2-t_cat1) - d2mx(2) = (t_fac2-t_xfac) - dxm1(2) = (t_xfac-t_fac1) - invd(2) = 1.0_r8/(t_fac2-t_fac1) - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - do iv=1,19 ! variable number - -! end points as basis for multidimentional linear interpolation - opt2d(1,1)=a2to3var(iv,t_ict1,t_ifc1,kcomp) - opt2d(1,2)=a2to3var(iv,t_ict1,t_ifc2,kcomp) - opt2d(2,1)=a2to3var(iv,t_ict2,t_ifc1,kcomp) - opt2d(2,2)=a2to3var(iv,t_ict2,t_ifc2,kcomp) - -! interpolation in the fac dimension - opt1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(2) - opt2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(2) - -! finally, interpolation in the cat dimension - opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - -! if(k.eq.1) write(*,*) 'opt2to3 =', opt - -! write(*,*) 'Before array' - - if(iv==1) then - cintbg(icol,k,kcomp)=opt - elseif(iv==2) then - cintbg05(icol,k,kcomp)=opt - elseif(iv==3) then - cintbg125(icol,k,kcomp)=opt - elseif(iv==4) then - cintbc(icol,k,kcomp)=opt - elseif(iv==5) then - cintbc05(icol,k,kcomp)=opt - elseif(iv==6) then - cintbc125(icol,k,kcomp)=opt - elseif(iv==7) then - cintoc(icol,k,kcomp)=opt - elseif(iv==8) then - cintoc05(icol,k,kcomp)=opt - elseif(iv==9) then - cintoc125(icol,k,kcomp)=opt - elseif(iv==10) then - cintsc(icol,k,kcomp)=opt - elseif(iv==11) then - cintsc05(icol,k,kcomp)=opt - elseif(iv==12) then - cintsc125(icol,k,kcomp)=opt - elseif(iv==13) then - cintsa(icol,k,kcomp)=opt - elseif(iv==14) then - cintsa05(icol,k,kcomp)=opt - elseif(iv==15) then - cintsa125(icol,k,kcomp)=opt - elseif(iv==16) then - aaeros(icol,k,kcomp)=opt - elseif(iv==17) then - aaerol(icol,k,kcomp)=opt - elseif(iv==18) then - vaeros(icol,k,kcomp)=opt - elseif(iv==19) then - vaerol(icol,k,kcomp)=opt - endif - end do ! iv=1,19 - - endif - - end do ! icol - end do ! k - - end do ! kcomp - -! Dry parameters for externally mixed modes modes 12-13, -! BC(n) and OC(n): - - do kcomp=12,13 ! using dummy initialization for kcomp=3 -! do kcomp=12,12 - - do k=1,pver - do icol=1,ncol - - cknorm(icol,k,kcomp) = a2to3var(1,1,1,kcomp-10) - cknlt05(icol,k,kcomp) = a2to3var(2,1,1,kcomp-10) - ckngt125(icol,k,kcomp)= a2to3var(3,1,1,kcomp-10) - aaerosn(icol,k,kcomp) = a2to3var(16,1,1,kcomp-10) - aaeroln(icol,k,kcomp) = a2to3var(17,1,1,kcomp-10) - vaerosn(icol,k,kcomp) = a2to3var(18,1,1,kcomp-10) - vaeroln(icol,k,kcomp) = a2to3var(19,1,1,kcomp-10) - - end do ! icol - end do ! k - - end do ! kcomp - - - return -end subroutine intdrypar2to3 diff --git a/src/physics/cam_oslo/intdrypar4.F90 b/src/physics/cam_oslo/intdrypar4.F90 deleted file mode 100644 index e8fe8f9f40..0000000000 --- a/src/physics/cam_oslo/intdrypar4.F90 +++ /dev/null @@ -1,278 +0,0 @@ -subroutine intdrypar4 (lchnk, ncol, Nnatk, xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & - xct, ict1, xfac, ifac1, xfaq, ifaq1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & - aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: fbcbg, cate, cat, fac, faq, fbc, nbmp1 - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include - -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode (4) - integer, intent(in) :: ifbcbg1(pcols,pver) - real(r8), intent(in) :: xfbcbgn(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode (14) - integer, intent(in) :: ifbcbgn1(pcols,pver) -! -! Input-Output arguments -! - real(r8), intent(inout) :: & - aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & - vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & - cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) -! -! -! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) -! (for AeroCom determination of particle effective radii) of each constituent. cint*05 -! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are -! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. -! - real(r8), intent(out) :: & - cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & - cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & - cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & - cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & - cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & - aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & - vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - real(r8) a, b, e, eps - - integer iv, kcomp, k, icol - -! Temporary storage of often used array elements - integer t_ifb1, t_ifb2 - integer t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 - real(r8) t_fbcbg1, t_fbcbg2 - real(r8) t_faq1, t_faq2, t_xfaq - real(r8) t_fac1, t_fac2, t_xfac - real(r8) t_xct, t_cat1, t_cat2 - - real(r8) t_xfbcbg - real(r8) d2mx(4), dxm1(4), invd(4) - real(r8) opt4d(2,2,2,2) - real(r8) opt1, opt2, opt - - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - -! write(*,*) 'Before kcomp-loop' - -! Mode 4, BC&OC(Ait): - - kcomp=4 - -! initialize output fields - do k=1,pver - do icol=1,ncol - cintbg(icol,k,kcomp)=0.0_r8 - cintbg05(icol,k,kcomp)=0.0_r8 - cintbg125(icol,k,kcomp)=0.0_r8 - cintbc(icol,k,kcomp)=0.0_r8 - cintbc05(icol,k,kcomp)=0.0_r8 - cintbc125(icol,k,kcomp)=0.0_r8 - cintoc(icol,k,kcomp)=0.0_r8 - cintoc05(icol,k,kcomp)=0.0_r8 - cintoc125(icol,k,kcomp)=0.0_r8 - cintsc(icol,k,kcomp)=0.0_r8 - cintsc05(icol,k,kcomp)=0.0_r8 - cintsc125(icol,k,kcomp)=0.0_r8 - cintsa(icol,k,kcomp)=0.0_r8 - cintsa05(icol,k,kcomp)=0.0_r8 - cintsa125(icol,k,kcomp)=0.0_r8 - aaeros(icol,k,kcomp)=0.0_r8 - aaerol(icol,k,kcomp)=0.0_r8 - vaeros(icol,k,kcomp)=0.0_r8 - vaerol(icol,k,kcomp)=0.0_r8 - end do - end do - - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kcomp)>0.0_r8) then - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - t_ifb1 = ifbcbg1(icol,k) - t_ifb2 = t_ifb1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - t_xfbcbg = xfbcbg(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - -! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_fbcbg2-t_xfbcbg) - dxm1(1) = (t_xfbcbg-t_fbcbg1) - invd(1) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - d2mx(4) = (t_faq2-t_xfaq) - dxm1(4) = (t_xfaq-t_faq1) - invd(4) = 1.0_r8/(t_faq2-t_faq1) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - do iv=1,19 ! variable number - -! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=a4var(iv,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt4d(1,1,1,2)=a4var(iv,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt4d(1,1,2,1)=a4var(iv,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt4d(1,1,2,2)=a4var(iv,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt4d(1,2,1,1)=a4var(iv,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt4d(1,2,1,2)=a4var(iv,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt4d(1,2,2,1)=a4var(iv,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt4d(1,2,2,2)=a4var(iv,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt4d(2,1,1,1)=a4var(iv,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt4d(2,1,1,2)=a4var(iv,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt4d(2,1,2,1)=a4var(iv,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt4d(2,1,2,2)=a4var(iv,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt4d(2,2,1,1)=a4var(iv,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt4d(2,2,1,2)=a4var(iv,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt4d(2,2,2,1)=a4var(iv,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt4d(2,2,2,2)=a4var(iv,t_ifb2,t_ict2,t_ifc2,t_ifa2) - -! interpolation in the faq, fac and cat dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) - -! finally, interpolation in the fbcbg dimension - opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - -! if(k.eq.1) write(*,*) 'opt4 =', opt - -! write(*,*) 'Before array' - - if(iv==1) then - cintbg(icol,k,kcomp)=opt - elseif(iv==2) then - cintbg05(icol,k,kcomp)=opt - elseif(iv==3) then - cintbg125(icol,k,kcomp)=opt - elseif(iv==4) then - cintbc(icol,k,kcomp)=opt - elseif(iv==5) then - cintbc05(icol,k,kcomp)=opt - elseif(iv==6) then - cintbc125(icol,k,kcomp)=opt - elseif(iv==7) then - cintoc(icol,k,kcomp)=opt - elseif(iv==8) then - cintoc05(icol,k,kcomp)=opt - elseif(iv==9) then - cintoc125(icol,k,kcomp)=opt - elseif(iv==10) then - cintsc(icol,k,kcomp)=opt - elseif(iv==11) then - cintsc05(icol,k,kcomp)=opt - elseif(iv==12) then - cintsc125(icol,k,kcomp)=opt - elseif(iv==13) then - cintsa(icol,k,kcomp)=opt - elseif(iv==14) then - cintsa05(icol,k,kcomp)=opt - elseif(iv==15) then - cintsa125(icol,k,kcomp)=opt - elseif(iv==16) then - aaeros(icol,k,kcomp)=opt - elseif(iv==17) then - aaerol(icol,k,kcomp)=opt - elseif(iv==18) then - vaeros(icol,k,kcomp)=opt - elseif(iv==19) then - vaerol(icol,k,kcomp)=opt - endif - - end do ! iv=1,19 - - endif - - end do ! icol - end do ! k - - kcomp=14 - do k=1,pver - do icol=1,ncol - - t_ifb1 = ifbcbgn1(icol,k) - t_ifb2 = t_ifb1+1 - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_xfbcbg = xfbcbgn(icol,k) - - d2mx(1) = (t_fbcbg2-t_xfbcbg) - dxm1(1) = (t_xfbcbg-t_fbcbg1) - invd(1) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - -! Only interpolation in the fbcbg dimension for mode 14 - opt1 = a4var(1,1,1,1,1) - opt2 = a4var(1,2,1,1,1) - cknorm(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - opt1 = a4var(2,1,1,1,1) - opt2 = a4var(2,2,1,1,1) - cknlt05(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - opt1 = a4var(3,1,1,1,1) - opt2 = a4var(3,2,1,1,1) - ckngt125(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - opt1 = a4var(16,1,1,1,1) - opt2 = a4var(16,2,1,1,1) -! (The remaining variables are actually independent of fbcbg, -! but we follow the same procedure anyway:) - aaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - opt1 = a4var(17,1,1,1,1) - opt2 = a4var(17,2,1,1,1) - aaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - opt1 = a4var(18,1,1,1,1) - opt2 = a4var(18,2,1,1,1) - vaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - opt1 = a4var(19,1,1,1,1) - opt2 = a4var(19,2,1,1,1) - vaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - end do ! icol - end do ! k - - return -end subroutine intdrypar4 - - - - diff --git a/src/physics/cam_oslo/intdrypar5to10.F90 b/src/physics/cam_oslo/intdrypar5to10.F90 deleted file mode 100644 index 8ba2a92c0f..0000000000 --- a/src/physics/cam_oslo/intdrypar5to10.F90 +++ /dev/null @@ -1,241 +0,0 @@ -subroutine intdrypar5to10 (lchnk, ncol, Nnatk, xct, ict1, & - xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - cknorm,cknlt05,ckngt125) - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: cate, cat, fac, faq, fbc, rh, nbmp1 - use commondefinitions, only: nmodes, nbmodes - - implicit none - -#include -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) - integer, intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) -! -! Input-Output arguments -! - real(r8), intent(inout) :: & - cknorm(pcols,pver,0:nmodes), cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) -! -! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) -! (for AeroCom determination of particle effective radii) of each constituent. cint*05 -! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are -! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. -! - real(r8), intent(out) :: & - cintbg(pcols,pver,0:nbmodes), cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & - cintbc(pcols,pver,0:nbmodes), cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & - cintoc(pcols,pver,0:nbmodes), cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & - cintsc(pcols,pver,0:nbmodes), cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & - cintsa(pcols,pver,0:nbmodes), cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes), & - aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & - vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) -! -!---------------------------Local variables----------------------------- -! - real(r8) a, b, e, eps - - integer iv, kcomp, k, icol - -! Temporary storage of often used array elements - integer t_ict1, t_ict2, t_ifa1, t_ifa2 - integer t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) t_faq1, t_faq2, t_xfaq - real(r8) t_fbc1, t_fbc2, t_xfbc - real(r8) t_fac1, t_fac2, t_xfac - real(r8) t_xct, t_cat1, t_cat2 - real(r8) d2mx(4), dxm1(4), invd(4) - real(r8) opt4d(2,2,2,2) - real(r8) opt1, opt2, opt - - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - -! write(*,*) 'Before kcomp-loop' - -! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): - - do kcomp=5,10 - -! initialize output fields - do k=1,pver - do icol=1,ncol - cintbg(icol,k,kcomp)=0.0_r8 - cintbg05(icol,k,kcomp)=0.0_r8 - cintbg125(icol,k,kcomp)=0.0_r8 - cintbc(icol,k,kcomp)=0.0_r8 - cintbc05(icol,k,kcomp)=0.0_r8 - cintbc125(icol,k,kcomp)=0.0_r8 - cintoc(icol,k,kcomp)=0.0_r8 - cintoc05(icol,k,kcomp)=0.0_r8 - cintoc125(icol,k,kcomp)=0.0_r8 - cintsc(icol,k,kcomp)=0.0_r8 - cintsc05(icol,k,kcomp)=0.0_r8 - cintsc125(icol,k,kcomp)=0.0_r8 - cintsa(icol,k,kcomp)=0.0_r8 - cintsa05(icol,k,kcomp)=0.0_r8 - cintsa125(icol,k,kcomp)=0.0_r8 - aaeros(icol,k,kcomp)=0.0_r8 - aaerol(icol,k,kcomp)=0.0_r8 - vaeros(icol,k,kcomp)=0.0_r8 - vaerol(icol,k,kcomp)=0.0_r8 - end do - end do - - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kcomp)>0.0_r8) then - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifb1 = ifbc1(icol,k,kcomp) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - t_cat1 = cat(kcomp,t_ict1) - t_cat2 = cat(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbc1 = fbc(t_ifb1) - t_fbc2 = fbc(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfbc = xfbc(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - -! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_cat2-t_xct) - dxm1(1) = (t_xct-t_cat1) - invd(1) = 1.0_r8/(t_cat2-t_cat1) - d2mx(2) = (t_fac2-t_xfac) - dxm1(2) = (t_xfac-t_fac1) - invd(2) = 1.0_r8/(t_fac2-t_fac1) - d2mx(3) = (t_fbc2-t_xfbc) - dxm1(3) = (t_xfbc-t_fbc1) - invd(3) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(4) = (t_faq2-t_xfaq) - dxm1(4) = (t_xfaq-t_faq1) - invd(4) = 1.0_r8/(t_faq2-t_faq1) -!soa - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - do iv=1,19 ! variable number - -! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=a5to10var(iv,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt4d(1,1,1,2)=a5to10var(iv,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt4d(1,1,2,1)=a5to10var(iv,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt4d(1,1,2,2)=a5to10var(iv,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt4d(1,2,1,1)=a5to10var(iv,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt4d(1,2,1,2)=a5to10var(iv,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt4d(1,2,2,1)=a5to10var(iv,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt4d(1,2,2,2)=a5to10var(iv,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt4d(2,1,1,1)=a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt4d(2,1,1,2)=a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt4d(2,1,2,1)=a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt4d(2,1,2,2)=a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt4d(2,2,1,1)=a5to10var(iv,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt4d(2,2,1,2)=a5to10var(iv,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt4d(2,2,2,1)=a5to10var(iv,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt4d(2,2,2,2)=a5to10var(iv,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - -! interpolation in the faq, fbc, and fac and dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) - -! finally, interpolation in the cat dimension - opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - -! if(k.eq.1.and.kcomp.eq.10) then -! write(*,*) 'a5to10var11=', & -! a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp), iv,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp -! write(*,*) 'a5to10var12=',& -! a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp), iv,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp -! endif - - -! write(*,*) 'Before array' - - if(iv==1) then - cintbg(icol,k,kcomp)=opt - elseif(iv==2) then - cintbg05(icol,k,kcomp)=opt - elseif(iv==3) then - cintbg125(icol,k,kcomp)=opt - elseif(iv==4) then - cintbc(icol,k,kcomp)=opt - elseif(iv==5) then - cintbc05(icol,k,kcomp)=opt - elseif(iv==6) then - cintbc125(icol,k,kcomp)=opt - elseif(iv==7) then - cintoc(icol,k,kcomp)=opt - elseif(iv==8) then - cintoc05(icol,k,kcomp)=opt - elseif(iv==9) then - cintoc125(icol,k,kcomp)=opt - elseif(iv==10) then - cintsc(icol,k,kcomp)=opt - elseif(iv==11) then - cintsc05(icol,k,kcomp)=opt - elseif(iv==12) then - cintsc125(icol,k,kcomp)=opt - elseif(iv==13) then - cintsa(icol,k,kcomp)=opt - elseif(iv==14) then - cintsa05(icol,k,kcomp)=opt - elseif(iv==15) then - cintsa125(icol,k,kcomp)=opt - elseif(iv==16) then - aaeros(icol,k,kcomp)=opt - elseif(iv==17) then - aaerol(icol,k,kcomp)=opt - elseif(iv==18) then - vaeros(icol,k,kcomp)=opt - elseif(iv==19) then - vaerol(icol,k,kcomp)=opt - endif - - end do ! iv=1,19 - - endif - - cknorm(icol,k,kcomp) = a5to10var(1,1,1,1,1,kcomp) - cknlt05(icol,k,kcomp) = a5to10var(2,1,1,1,1,kcomp) - ckngt125(icol,k,kcomp)= a5to10var(3,1,1,1,1,kcomp) - - end do ! icol - end do ! k - - end do ! kcomp - - return -end subroutine intdrypar5to10 - - - - diff --git a/src/physics/cam_oslo/interp_aeropt_mod.F90 b/src/physics/cam_oslo/interp_aeropt_mod.F90 deleted file mode 100644 index f7e9bec6f7..0000000000 --- a/src/physics/cam_oslo/interp_aeropt_mod.F90 +++ /dev/null @@ -1,1282 +0,0 @@ -module update_aeropt_mod - - use shr_kind_mod , only : r8 => shr_kind_r8 - use ppgrid , only : pcols, pver - use commondefinitions , only : nmodes, nbmodes - use opttab , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg - use oslo_control , only : oslo_getopts, dir_string_length - use cam_logfile , only : iulog - - implicit none - private - - ! Set by init_aeropt Mode0 - real(r8) :: bex440, bax440 - real(r8) :: bex500, bax500, bax550 - real(r8) :: bex670, bax670, - real(r8) :: bex870, bax870 - real(r8) :: bex550lt1, bex550gt1, backscx550 - - ! Set by init_aeropt Mode1 - real(r8), public :: bep1(38,10,6,16,6) - - ! Set by init_aeropt Mode2to3 - real(r8), public :: bep2to3 (38,10,16,6,2:3) - - ! Set by init_aeropt Mode4 - real(r8), public :: bep4(38,10,6,16,6,6) - - ! Set by init_aeropt Mode5to10 - real(r8), public :: bep5to10(38,10,6,6,6,6,5:10) - - - ! Modal total and absorption extiction coefficients (for AeroCom) - ! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). - ! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). - type, public :: extinction_coeffs_type - real(r8) :: bext440(pcols,pver,0:nbmodes) - real(r8) :: babs440(pcols,pver,0:nbmodes) - real(r8) :: bext500(pcols,pver,0:nbmodes) - real(r8) :: babs500(pcols,pver,0:nbmodes) - real(r8) :: bext550(pcols,pver,0:nbmodes) - real(r8) :: babs550(pcols,pver,0:nbmodes) - real(r8) :: bext670(pcols,pver,0:nbmodes) - real(r8) :: babs670(pcols,pver,0:nbmodes) - real(r8) :: bext870(pcols,pver,0:nbmodes) - real(r8) :: babs870(pcols,pver,0:nbmodes) - real(r8) :: bebg440(pcols,pver,0:nbmodes) - real(r8) :: bebg500(pcols,pver,0:nbmodes) - real(r8) :: bebg550(pcols,pver,0:nbmodes) - real(r8) :: babg550(pcols,pver,0:nbmodes) - real(r8) :: bebg670(pcols,pver,0:nbmodes) - real(r8) :: bebg870(pcols,pver,0:nbmodes) - real(r8) :: bebc440(pcols,pver,0:nbmodes) - real(r8) :: bebc500(pcols,pver,0:nbmodes) - real(r8) :: bebc550(pcols,pver,0:nbmodes) - real(r8) :: babc550(pcols,pver,0:nbmodes) - real(r8) :: bebc670(pcols,pver,0:nbmodes) - real(r8) :: bebc870(pcols,pver,0:nbmodes) - real(r8) :: beoc440(pcols,pver,0:nbmodes) - real(r8) :: beoc500(pcols,pver,0:nbmodes) - real(r8) :: beoc550(pcols,pver,0:nbmodes) - real(r8) :: baoc550(pcols,pver,0:nbmodes) - real(r8) :: beoc670(pcols,pver,0:nbmodes) - real(r8) :: beoc870(pcols,pver,0:nbmodes) - real(r8) :: besu440(pcols,pver,0:nbmodes) - real(r8) :: besu500(pcols,pver,0:nbmodes) - real(r8) :: besu550(pcols,pver,0:nbmodes) - real(r8) :: basu550(pcols,pver,0:nbmodes) - real(r8) :: besu670(pcols,pver,0:nbmodes) - real(r8) :: besu870(pcols,pver,0:nbmodes) - real(r8) :: bebg550lt1(pcols,pver,0:nbmodes) - real(r8) :: bebg550gt1(pcols,pver,0:nbmodes) - real(r8) :: bebc550lt1(pcols,pver,0:nbmodes) - real(r8) :: bebc550gt1(pcols,pver,0:nbmodes) - real(r8) :: beoc550lt1(pcols,pver,0:nbmodes) - real(r8) :: beoc550gt1(pcols,pver,0:nbmodes) - real(r8) :: besu550lt1(pcols,pver,0:nbmodes) - real(r8) :: besu550gt1(pcols,pver,0:nbmodes) - real(r8) :: backsc550(pcols,pver,0:nbmodes) - - contains - procedure :: zero_coeffs - procedure :: update_coeffs - end type extinction_coeffs_type - - type(extinction_coeffs_type), public :: extinction_coeffs - type(extinction_coeffs_type), public :: extinction_coeffsn - - public :: init_aeropt - public :: update_aeropt0 - public :: update_aeropt1 - public :: update_aeropt2to3 - public :: update_aeropt4 - public :: update_aeropt5to10 - -! ========================================================== -contains -! ========================================================== - - subroutine init_aeropt - - !Purpose: To read in the AeroCom look-up tables for aerosol optical properties. - ! The grid for discrete input-values in the look-up tables is defined in opptab. - - ! Tabulating the 'aerocomk'-files to save computing time. - ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 - ! Extended for new SOA treatment - Alf Kirkevaag, September 2015. - ! Modified for optimized added masses and mass fractions for - ! concentrations from condensation, coagulation or cloud-processing - ! - Alf Kirkevaag, May 2016. - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - - integer :: ic, ifil, lin, iv - integer :: kcomp, irelh, ictot, ifac, ifbc, ifaq - integer :: ifombg, ifbcbg - real(r8) :: catot, relh, frbcbg, frac, fabc, fraq - real(r8) :: bext440, babs440, bext500, babs500, babs550 - real(r8) :: bext670, babs670, bext870, babs870 - real(r8) :: bebg440, babg440, bebg500, babg500, babg550 - real(r8) :: bebg670, babg670, bebg870, babg870 - real(r8) :: bebc440, babc440, bebc500, babc500, babc550 - real(r8) :: bebc670, babc670, bebc870, babc870 - real(r8) :: beoc440, baoc440, beoc500, baoc500, baoc550 - real(r8) :: beoc670, baoc670, beoc870, baoc870 - real(r8) :: besu440, basu440, besu500, basu500, basu550 - real(r8) :: besu670, basu670, besu870, basu870 - real(r8) :: bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1 - real(r8) :: beoc550lt1, beoc550gt1, besu550lt1, besu550gt1 - real(r8) :: backscat550 - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - real(r8) :: eps7 = 1.e-7_r8 - character(len=dir_string_length) :: aerotab_table_dir - !----------------------------------------------------------- - - call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) - open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' , form='formatted',status='old') - open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' , form='formatted',status='old') - open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' , form='formatted',status='old') - open(14,file=trim(aerotab_table_dir)//'/aerocomk5.out' , form='formatted',status='old') - open(15,file=trim(aerotab_table_dir)//'/aerocomk6.out' , form='formatted',status='old') - open(16,file=trim(aerotab_table_dir)//'/aerocomk7.out' , form='formatted',status='old') - open(17,file=trim(aerotab_table_dir)//'/aerocomk8.out' , form='formatted',status='old') - open(18,file=trim(aerotab_table_dir)//'/aerocomk9.out' , form='formatted',status='old') - open(19,file=trim(aerotab_table_dir)//'/aerocomk10.out', form='formatted',status='old') - open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' , form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' , form='formatted',status='old') - - ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 11,21 - call checkTableHeader (ifil) - enddo - ! - !------------------------------------------- - ! Mode 0, BC(ax - !------------------------------------------- - ! - read(20,'(I2,f6.3,12e11.4)') & - kcomp, relh, & - bex440, bax440, bex500, bax500, bax550, bex670, bax670, & - bex870, bax870, bex550lt1, bex550gt1, backscx550 - - if(bex440<=0.0_r8) then - write(*,*) 'bex440 =', bex440 - write(*,*) 'Error in initialization of bex1' - stop - endif - write(iulog,*)'aerocom mode 0 ok' - ! - !------------------------------------------- - ! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) - !------------------------------------------- - ! - do lin = 1,5760 ! 10x6x16x6 - read(21,'(I2,f6.3,3e10.3,38e10.3)') & - kcomp, relh, frombg, catot, frac, & - bext440, bext500, bext670, bext870, & - bebg440, bebg500, bebg670, bebg870, & - bebc440, bebc500, bebc670, bebc870, & - beoc440, beoc500, beoc670, beoc870, & - besu440, besu500, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & - beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & - backscat550, babg550, babc550, baoc550, basu550 - - do ic=1,10 - if(abs(relh-rh(ic)) 0 - end do ! icol - end do ! k - - end subroutine update_aeropt2to3 - - ! ========================================================== - subroutine update_aeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & - extinction_coeffs) - - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xfbcbg(pcols,pver) - integer , intent(in) :: ifbcbg1(pcols,pver) - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer , intent(in) :: ifaq1(pcols,pver,nbmodes) - type(extinction_coeffs), intent(inout) :: extinction_coeffs - - ! Local variables - real(r8) :: a, b, e, eps - integer :: i, iv, kcomp, k, icol, kc10 - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 - real(r8) :: t_fbcbg1, t_fbcbg2 - integer :: t_ifb1, t_ifb2 - real(r8) :: t_faq1, t_faq2, t_xfaq - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 - real(r8) :: t_cat1, t_cat2 - real(r8) :: t_xfbcbg - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: opt1, opt2, opt(38) - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! BC&OC(Ait) mode: - kcomp = 4 - extinction_coeffs%zero_coeffs(kcomp, ncol) - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kc10).gt.0) then - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ifb1 = ifbcbg1(icol,k) - t_ifb2 = t_ifb1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xfbcbg = xfbcbg(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fbcbg2-t_xfbcbg) - dxm1(2) = (t_xfbcbg-t_fbcbg1) - invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - do iv=1,38 ! variable number - - opt5d(1,1,1,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - - ! finally, interpolation in the rh dimension - opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - - end do ! iv=1,38 - - ! determine extinction coefficient - extinction_coeffs%update_coeffs(icol, k, kcomp, opt) - - end if ! Nnatk > 0 - end do ! icol - end do ! k - - end subroutine update_aeropt4 - - ! ========================================================== - subroutine update_aeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - extinction_coeffs) - - ! Arguments - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) - integer , intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer , intent(in) :: ifaq1(pcols,pver,nbmodes) - - ! Local variables - real(r8) :: a, b, e, eps - integer :: i, iv, kcomp, k, icol - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 - integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) :: t_faq1, t_faq2, t_xfaq - real(r8) :: t_fbc1, t_fbc2, t_xfbc - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 - real(r8) :: t_cat1, t_cat2 - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: opt1, opt2, opt(38) - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): - - do kcomp=5,10 - ! zero extinction coefficients for this kcomp - extinction_coeffs%zero_coeffs(kcomp, ncol) - - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kcomp).gt.0) then - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - t_ifb1 = ifbc1(icol,k,kcomp) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cat(kcomp,t_ict1) - t_cat2 = cat(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbc1 = fbc(t_ifb1) - t_fbc2 = fbc(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfbc = xfbc(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - d2mx(4) = (t_fbc2-t_xfbc) - dxm1(4) = (t_xfbc-t_fbc1) - invd(4) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - do iv=1,38 ! variable number - opt5d(1,1,1,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - - ! finally, interpolation in the rh dimension - opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - - end do ! iv=1,38 - - ! determine extinction coefficient - extinction_coeffs%update_coeffs(icol, k, kcomp, opt) - - end if ! Nnatk > 0 - end do ! icol - end do ! k - end do ! kcomp - - end subroutine update_aeropt5to10 - - ! ========================================================== - subroutine zero_coeffs(this, kcomp, ncol) - - class(extinction_coeffs_type) :: this - integer , intent(in) :: kcomp - integer , intent(in) :: ncol - - integer :: k - integer :: icol - - ! initialize all output fields to zero - do k=1,pver - do icol=1,ncol - this%bext440(icol,k,kcomp) = 0.0_r8 - this%babs440(icol,k,kcomp) = 0.0_r8 - this%bext500(icol,k,kcomp) = 0.0_r8 - this%babs500(icol,k,kcomp) = 0.0_r8 - this%bext550(icol,k,kcomp) = 0.0_r8 - this%babs550(icol,k,kcomp) = 0.0_r8 - this%bext670(icol,k,kcomp) = 0.0_r8 - this%babs670(icol,k,kcomp) = 0.0_r8 - this%bext870(icol,k,kcomp) = 0.0_r8 - this%babs870(icol,k,kcomp) = 0.0_r8 - this%bebg440(icol,k,kcomp) = 0.0_r8 - this%bebg500(icol,k,kcomp) = 0.0_r8 - this%bebg550(icol,k,kcomp) = 0.0_r8 - this%babg550(icol,k,kcomp) = 0.0_r8 - this%bebg670(icol,k,kcomp) = 0.0_r8 - this%bebg870(icol,k,kcomp) = 0.0_r8 - this%bebc440(icol,k,kcomp) = 0.0_r8 - this%bebc500(icol,k,kcomp) = 0.0_r8 - this%bebc550(icol,k,kcomp) = 0.0_r8 - this%babc550(icol,k,kcomp) = 0.0_r8 - this%bebc670(icol,k,kcomp) = 0.0_r8 - this%bebc870(icol,k,kcomp) = 0.0_r8 - this%beoc440(icol,k,kcomp) = 0.0_r8 - this%beoc500(icol,k,kcomp) = 0.0_r8 - this%beoc550(icol,k,kcomp) = 0.0_r8 - this%baoc550(icol,k,kcomp) = 0.0_r8 - this%beoc670(icol,k,kcomp) = 0.0_r8 - this%beoc870(icol,k,kcomp) = 0.0_r8 - this%besu440(icol,k,kcomp) = 0.0_r8 - this%besu500(icol,k,kcomp) = 0.0_r8 - this%besu550(icol,k,kcomp) = 0.0_r8 - this%basu550(icol,k,kcomp) = 0.0_r8 - this%besu670(icol,k,kcomp) = 0.0_r8 - this%besu870(icol,k,kcomp) = 0.0_r8 - this%bebg550lt1(icol,k,kcomp) = 0.0_r8 - this%bebg550gt1(icol,k,kcomp) = 0.0_r8 - this%bebc550lt1(icol,k,kcomp) = 0.0_r8 - this%bebc550gt1(icol,k,kcomp) = 0.0_r8 - this%beoc550lt1(icol,k,kcomp) = 0.0_r8 - this%beoc550gt1(icol,k,kcomp) = 0.0_r8 - this%besu550lt1(icol,k,kcomp) = 0.0_r8 - this%besu550gt1(icol,k,kcomp) = 0.0_r8 - this%backsc550(icol,k,kcomp) = 0.0_r8 - end do - end do - - end subroutine zero_coeffs - - ! ========================================================== - subroutine update_coeffs(this, icol, k, kcomp) - - class(extinction_coeffs_type) :: this - integer , intent(in) :: icol - integer , intent(in) :: k - integer , intent(in) :: kcomp - real(r8) , intent(in) :: opt(:) - - this%bext440(icol,k,kcomp) = opt(1) - this%bext500(icol,k,kcomp) = opt(2) - this%bext670(icol,k,kcomp) = opt(3) - this%bext870(icol,k,kcomp) = opt(4) - this%bebg440(icol,k,kcomp) = opt(5) - this%bebg500(icol,k,kcomp) = opt(6) - this%bebg670(icol,k,kcomp) = opt(7) - this%bebg870(icol,k,kcomp) = opt(8) - this%bebc440(icol,k,kcomp) = opt(9) - this%bebc500(icol,k,kcomp) = opt(10) - this%bebc670(icol,k,kcomp) = opt(11) - this%bebc870(icol,k,kcomp) = opt(12) - this%beoc440(icol,k,kcomp) = opt(13) - this%beoc500(icol,k,kcomp) = opt(14) - this%beoc670(icol,k,kcomp) = opt(15) - this%beoc870(icol,k,kcomp) = opt(16) - this%besu440(icol,k,kcomp) = opt(17) - this%besu500(icol,k,kcomp) = opt(18) - this%besu670(icol,k,kcomp) = opt(19) - this%besu870(icol,k,kcomp) = opt(20) - this%babs440(icol,k,kcomp) = opt(21) - this%babs500(icol,k,kcomp) = opt(22) - this%babs550(icol,k,kcomp) = opt(23) - this%babs670(icol,k,kcomp) = opt(24) - this%babs870(icol,k,kcomp) = opt(25) - this%bebg550lt1(icol,k,kcomp) = opt(26) - this%bebg550gt1(icol,k,kcomp) = opt(27) - this%bebc550lt1(icol,k,kcomp) = opt(28) - this%bebc550gt1(icol,k,kcomp) = opt(29) - this%beoc550lt1(icol,k,kcomp) = opt(30) - this%beoc550gt1(icol,k,kcomp) = opt(31) - this%besu550lt1(icol,k,kcomp) = opt(32) - this%besu550gt1(icol,k,kcomp) = opt(33) - this%backsc550(icol,k,kcomp) = opt(34) - this%babg550(icol,k,kcomp) = opt(35) - this%babc550(icol,k,kcomp) = opt(36) - this%baoc550(icol,k,kcomp) = opt(37) - this%basu550(icol,k,kcomp) = opt(38) - this%bebg550(icol,k,kcomp) = opt(26)+opt(27) - this%bebc550(icol,k,kcomp) = opt(28)+opt(29) - this%beoc550(icol,k,kcomp) = opt(30)+opt(31) - this%besu550(icol,k,kcomp) = opt(32)+opt(33) - this%bext550(icol,k,kcomp) = bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & - +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) - - end subroutine update_coeffs - -end module update_aeropt_mod - diff --git a/src/physics/cam_oslo/intfrh.F90 b/src/physics/cam_oslo/intfrh.F90 deleted file mode 100644 index 2f0bec97a2..0000000000 --- a/src/physics/cam_oslo/intfrh.F90 +++ /dev/null @@ -1,156 +0,0 @@ - -subroutine intfrh (lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relh, frh) - -! Written by Alf Kirkevaag in November 2011, based on interpol1to3 in optinterpol.F90 - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 -!o use opttab, only: nbmodes, rh - use opttab, only: rh -! use aerosoldef, only: nmodes - use commondefinitions, only: nmodes - - implicit none - -! Relative humidity intries from opttab.F90: -!! rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, & -!! 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) -! Humidity growth factors which are consistent with the aerosol optics look-up tables: - real(r8), dimension(10) :: fh_SO4 = (/ 1.00_r8, 1.34_r8, 1.40_r8, 1.53_r8, 1.64_r8, & - 1.71_r8, 1.81_r8, 1.98_r8, 2.39_r8, 5.04_r8 /) - real(r8), dimension(10) :: fh_insol = (/ 1.00_r8, 1.01_r8, 1.01_r8, 1.02_r8, 1.02_r8, & - 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8 /) - real(r8), dimension(10) :: fh_OC = (/ 1.00_r8, 1.02_r8, 1.05_r8, 1.14_r8, 1.19_r8, & - 1.22_r8, 1.27_r8, 1.36_r8, 1.59_r8, 3.18_r8 /) - real(r8), dimension(10) :: fh_SS = (/ 1.00_r8, 1.01_r8, 1.02_r8, 1.56_r8, 1.87_r8, & - 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 6.08_r8 /) -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns -!o real(r8), intent(in) :: v3so4(pcols,pver,nbmodes) ! Modal mass fraction of Sulfate -!o real(r8), intent(in) :: v3insol(pcols,pver,nbmodes)! Modal mass fraction of BC and dust -!o real(r8), intent(in) :: v3oc(pcols,pver,nbmodes) ! Modal mass fraction of OC (POM) -!o real(r8), intent(in) :: v3ss(pcols,pver,nbmodes) ! Modal mass fraction of sea-salt - real(r8), intent(in) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate - real(r8), intent(in) :: v3insol(pcols,pver,nmodes)! Modal mass fraction of BC and dust - real(r8), intent(in) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) - real(r8), intent(in) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt - real(r8), intent(in) :: relh(pcols,pver) ! Ambient relatve humidity (fraction) -! -! Output arguments -! -!o real(r8), intent(out) :: frh(pcols,pver,nbmodes) ! Modal humidity growth factor - real(r8), intent(out) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor - -! -!---------------------------Local variables----------------------------- -! - integer i, ierr, irelh, kcomp, k, icol - integer irh1(pcols,pver), irh2(pcols,pver) - real(r8) a, b, e, fso4, finsol, foc, fss - real(r8) xrh(pcols,pver) - parameter (e=2.718281828) - -! Temporary storage of often used array elements - integer t_irh1, t_irh2 - real(r8) t_xrh, t_rh1, t_rh2 - -! write(*,*) 'Before xrh-loop' - do k=1,pver - do icol=1,ncol -!test xrh(icol,k) = 0.8 - xrh(icol,k) = min(max(relh(icol,k),rh(1)),rh(10)) - end do - end do - -! write(*,*) 'Before rh-loop' - do irelh=1,9 - do k=1,pver - do icol=1,ncol - if(xrh(icol,k) >= rh(irelh).and. & - xrh(icol,k)<=rh(irelh+1)) then - irh1(icol,k)=irelh - irh2(icol,k)=irelh+1 - endif - end do - end do - end do - -!o Loop over all relevant background modes (kcomp=1,2,4-10) -!o do kcomp=1,10 -! Loop over all relevant modes (kcomp=1,2,4-11,13,14) -! (mode 3 is no longer included, and 12 is insoluble) - - do kcomp=1,14 - - do icol=1,ncol - do k=1,pver - frh(icol,k,kcomp)=0.0_r8 - end do - end do - -!o if(kcomp.ne.3) then - if(kcomp.ne.3.and.kcomp.ne.12) then - - do k=1,pver - do icol=1,ncol - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = irh2(icol,k) - -! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - - t_xrh = xrh(icol,k) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - if(t_xrh <= 0.37) then ! linear averaging w.r.t. small RH: - fso4 = ((t_rh2-t_xrh)*fh_SO4(t_irh1)+(t_xrh-t_rh1)*fh_SO4(t_irh2)) & - /(t_rh2-t_rh1) - finsol= ((t_rh2-t_xrh)*fh_insol(t_irh1)+(t_xrh-t_rh1)*fh_insol(t_irh2)) & - /(t_rh2-t_rh1) - foc = ((t_rh2-t_xrh)*fh_OC(t_irh1)+(t_xrh-t_rh1)*fh_OC(t_irh2)) & - /(t_rh2-t_rh1) - fss = ((t_rh2-t_xrh)*fh_SS(t_irh1)+(t_xrh-t_rh1)*fh_SS(t_irh2)) & - /(t_rh2-t_rh1) - else ! exponential averaging w.r.t. large RH: - a=(log(fh_SO4(t_irh2))-log(fh_SO4(t_irh1)))/(t_rh2-t_rh1) - b=(t_rh2*log(fh_SO4(t_irh1))-t_rh1*log(fh_SO4(t_irh2)))/(t_rh2-t_rh1) - fso4=e**(a*t_xrh+b) - a=(log(fh_insol(t_irh2))-log(fh_insol(t_irh1)))/(t_rh2-t_rh1) - b=(t_rh2*log(fh_insol(t_irh1))-t_rh1*log(fh_insol(t_irh2)))/(t_rh2-t_rh1) - finsol=e**(a*t_xrh+b) - a=(log(fh_OC(t_irh2))-log(fh_OC(t_irh1)))/(t_rh2-t_rh1) - b=(t_rh2*log(fh_OC(t_irh1))-t_rh1*log(fh_OC(t_irh2)))/(t_rh2-t_rh1) - foc=e**(a*t_xrh+b) - a=(log(fh_SS(t_irh2))-log(fh_SS(t_irh1)))/(t_rh2-t_rh1) - b=(t_rh2*log(fh_SS(t_irh1))-t_rh1*log(fh_SS(t_irh2)))/(t_rh2-t_rh1) - fss=e**(a*t_xrh+b) - endif -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - -! linear interpolation w.r.t. mass fractions of each internally mixed component -! (this assumption is only used here, while the full Koehler equation are solved -! for the look-up tables for log-normal size distributions and aerosol optics): - - frh(icol,k,kcomp) = v3so4(icol,k,kcomp)*fso4+v3insol(icol,k,kcomp)*finsol & - + v3oc(icol,k,kcomp) *foc +v3ss(icol,k,kcomp) *fss - -! write(*,*) 'frh =', frh(icol,k,kcomp) - - end do ! icol - end do ! k - - endif ! kcomp.ne.3.and.kcomp.ne.12 - - end do ! kcomp - - return -end subroutine intfrh diff --git a/src/physics/cam_oslo/intfrh_mod.F90 b/src/physics/cam_oslo/intfrh_mod.F90 new file mode 100644 index 0000000000..951b062339 --- /dev/null +++ b/src/physics/cam_oslo/intfrh_mod.F90 @@ -0,0 +1,140 @@ +module intfrh_mod + +contains + + subroutine intfrh (lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relh, frh) + + ! Written by Alf Kirkevaag in November 2011, based on interpol1to3 in optinterpol.F90 + ! called by NorESM/physpkg + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: rh + use commondefinitions, only: nmodes + + implicit none + ! + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate + real(r8), intent(in) :: v3insol(pcols,pver,nmodes) ! Modal mass fraction of BC and dust + real(r8), intent(in) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) + real(r8), intent(in) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt + real(r8), intent(in) :: relh(pcols,pver) ! Ambient relatve humidity (fraction) + ! + ! Output arguments + real(r8), intent(out) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor + ! + ! Local variables + integer :: i, ierr, irelh, kcomp, k, icol + integer :: irh1(pcols,pver), irh2(pcols,pver) + real(r8) :: a, b, e, fso4, finsol, foc, fss + real(r8) :: xrh(pcols,pver) + integer :: t_irh1, t_irh2 + real(r8) :: t_xrh, t_rh1, t_rh2 + parameter (e=2.718281828) + + ! Relative humidity intries from opttab.F90: + ! rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, & + ! 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) + ! Humidity growth factors which are consistent with the aerosol optics look-up tables: + real(r8), dimension(10) :: fh_SO4 = & + (/ 1.00_r8, 1.34_r8, 1.40_r8, 1.53_r8, 1.64_r8, & + 1.71_r8, 1.81_r8, 1.98_r8, 2.39_r8, 5.04_r8 /) + real(r8), dimension(10) :: fh_insol = & + (/ 1.00_r8, 1.01_r8, 1.01_r8, 1.02_r8, 1.02_r8, & + 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8 /) + real(r8), dimension(10) :: fh_OC = & + (/ 1.00_r8, 1.02_r8, 1.05_r8, 1.14_r8, 1.19_r8, & + 1.22_r8, 1.27_r8, 1.36_r8, 1.59_r8, 3.18_r8 /) + real(r8), dimension(10) :: fh_SS = & + (/ 1.00_r8, 1.01_r8, 1.02_r8, 1.56_r8, 1.87_r8, & + 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 6.08_r8 /) + ! ----------------------------------------- + + ! write(*,*) 'Before xrh-loop' + do k=1,pver + do icol=1,ncol + !test xrh(icol,k) = 0.8 + xrh(icol,k) = min(max(relh(icol,k),rh(1)),rh(10)) + end do + end do + + ! write(*,*) 'Before rh-loop' + do irelh=1,9 + do k=1,pver + do icol=1,ncol + if(xrh(icol,k) >= rh(irelh).and. & + xrh(icol,k)<=rh(irelh+1)) then + irh1(icol,k)=irelh + irh2(icol,k)=irelh+1 + endif + end do + end do + end do + + ! Loop over all relevant modes (kcomp=1,2,4-11,13,14) + ! (mode 3 is no longer included, and 12 is insoluble) + + do kcomp=1,14 + + do icol=1,ncol + do k=1,pver + frh(icol,k,kcomp)=0.0_r8 + end do + end do + + if(kcomp.ne.3.and.kcomp.ne.12) then + + do k=1,pver + do icol=1,ncol + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = irh2(icol,k) + + ! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + + t_xrh = xrh(icol,k) + + if(t_xrh <= 0.37) then ! linear averaging w.r.t. small RH: + fso4 = ((t_rh2-t_xrh)*fh_SO4(t_irh1)+(t_xrh-t_rh1)*fh_SO4(t_irh2)) /(t_rh2-t_rh1) + finsol= ((t_rh2-t_xrh)*fh_insol(t_irh1)+(t_xrh-t_rh1)*fh_insol(t_irh2)) /(t_rh2-t_rh1) + foc = ((t_rh2-t_xrh)*fh_OC(t_irh1)+(t_xrh-t_rh1)*fh_OC(t_irh2)) /(t_rh2-t_rh1) + fss = ((t_rh2-t_xrh)*fh_SS(t_irh1)+(t_xrh-t_rh1)*fh_SS(t_irh2)) /(t_rh2-t_rh1) + else ! exponential averaging w.r.t. large RH: + a = (log(fh_SO4(t_irh2))-log(fh_SO4(t_irh1)))/(t_rh2-t_rh1) + b = (t_rh2*log(fh_SO4(t_irh1))-t_rh1*log(fh_SO4(t_irh2)))/(t_rh2-t_rh1) + fso4 = e**(a*t_xrh+b) + a = (log(fh_insol(t_irh2))-log(fh_insol(t_irh1)))/(t_rh2-t_rh1) + b = (t_rh2*log(fh_insol(t_irh1))-t_rh1*log(fh_insol(t_irh2)))/(t_rh2-t_rh1) + finsol = e**(a*t_xrh+b) + a = (log(fh_OC(t_irh2))-log(fh_OC(t_irh1)))/(t_rh2-t_rh1) + b = (t_rh2*log(fh_OC(t_irh1))-t_rh1*log(fh_OC(t_irh2)))/(t_rh2-t_rh1) + foc = e**(a*t_xrh+b) + a = (log(fh_SS(t_irh2))-log(fh_SS(t_irh1)))/(t_rh2-t_rh1) + b = (t_rh2*log(fh_SS(t_irh1))-t_rh1*log(fh_SS(t_irh2)))/(t_rh2-t_rh1) + fss = e**(a*t_xrh+b) + endif + + ! linear interpolation w.r.t. mass fractions of each internally mixed component + ! (this assumption is only used here, while the full Koehler equation are solved + ! for the look-up tables for log-normal size distributions and aerosol optics): + + frh(icol,k,kcomp) = v3so4(icol,k,kcomp)*fso4 + v3insol(icol,k,kcomp)*finsol & + + v3oc(icol,k,kcomp) *foc + v3ss(icol,k,kcomp)*fss + + ! write(*,*) 'frh =', frh(icol,k,kcomp) + end do ! icol + end do ! k + endif ! kcomp.ne.3.and.kcomp.ne.12 + end do ! kcomp + + end subroutine intfrh +end module intfrh_mod diff --git a/src/physics/cam_oslo/lininterpol3dim.F90 b/src/physics/cam_oslo/lininterpol3dim.F90 deleted file mode 100644 index 3781b4c278..0000000000 --- a/src/physics/cam_oslo/lininterpol3dim.F90 +++ /dev/null @@ -1,41 +0,0 @@ - - subroutine lininterpol3dim (d2mx, dxm1, invd, opt3d, optout1, optout2) - - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - -! -! Input arguments -! - real(r8), intent(in) :: opt3d(2,2,2) - real(r8), intent(in) :: d2mx(3) - real(r8), intent(in) :: dxm1(3) - real(r8), intent(in) :: invd(3) -! -! Output arguments -! - real(r8), intent(out) :: optout1 - real(r8), intent(out) :: optout2 -! -!---------------------------Local variables----------------------------- -! - real(r8) opt2d(2,2) -! -!------------------------------------------------------------------------ -! -! interpolation in the third dimension (except invd(3) factor) - opt2d(1,1)=d2mx(3)*opt3d(1,1,1)+dxm1(3)*opt3d(1,1,2) - opt2d(1,2)=d2mx(3)*opt3d(1,2,1)+dxm1(3)*opt3d(1,2,2) - opt2d(2,1)=d2mx(3)*opt3d(2,1,1)+dxm1(3)*opt3d(2,1,2) - opt2d(2,2)=d2mx(3)*opt3d(2,2,1)+dxm1(3)*opt3d(2,2,2) - -! interpolation in the (third and) second dimension - optout1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(3)*invd(2) - optout2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(3)*invd(2) - - - return - -end subroutine lininterpol3dim diff --git a/src/physics/cam_oslo/lininterpol4dim.F90 b/src/physics/cam_oslo/lininterpol4dim.F90 deleted file mode 100644 index 2af2bd5146..0000000000 --- a/src/physics/cam_oslo/lininterpol4dim.F90 +++ /dev/null @@ -1,51 +0,0 @@ - - subroutine lininterpol4dim (d2mx, dxm1, invd, opt4d, optout1, optout2) - - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - -! -! Input arguments -! - real(r8), intent(in) :: opt4d(2,2,2,2) - real(r8), intent(in) :: d2mx(4) - real(r8), intent(in) :: dxm1(4) - real(r8), intent(in) :: invd(4) -! -! Output arguments -! - real(r8), intent(out) :: optout1 - real(r8), intent(out) :: optout2 -! -!---------------------------Local variables----------------------------- -! - real(r8) opt3d(2,2,2), opt2d(2,2) -! -!------------------------------------------------------------------------ -! -! interpolation in the fourth dimension (except invd(4) factor) - opt3d(1,1,1)=d2mx(4)*opt4d(1,1,1,1)+dxm1(4)*opt4d(1,1,1,2) - opt3d(1,1,2)=d2mx(4)*opt4d(1,1,2,1)+dxm1(4)*opt4d(1,1,2,2) - opt3d(1,2,1)=d2mx(4)*opt4d(1,2,1,1)+dxm1(4)*opt4d(1,2,1,2) - opt3d(1,2,2)=d2mx(4)*opt4d(1,2,2,1)+dxm1(4)*opt4d(1,2,2,2) - opt3d(2,1,1)=d2mx(4)*opt4d(2,1,1,1)+dxm1(4)*opt4d(2,1,1,2) - opt3d(2,1,2)=d2mx(4)*opt4d(2,1,2,1)+dxm1(4)*opt4d(2,1,2,2) - opt3d(2,2,1)=d2mx(4)*opt4d(2,2,1,1)+dxm1(4)*opt4d(2,2,1,2) - opt3d(2,2,2)=d2mx(4)*opt4d(2,2,2,1)+dxm1(4)*opt4d(2,2,2,2) - -! interpolation in the third dimension (except invd(3) factor) - opt2d(1,1)=d2mx(3)*opt3d(1,1,1)+dxm1(3)*opt3d(1,1,2) - opt2d(1,2)=d2mx(3)*opt3d(1,2,1)+dxm1(3)*opt3d(1,2,2) - opt2d(2,1)=d2mx(3)*opt3d(2,1,1)+dxm1(3)*opt3d(2,1,2) - opt2d(2,2)=d2mx(3)*opt3d(2,2,1)+dxm1(3)*opt3d(2,2,2) - -! interpolation in the (fourth, third and) second dimension - optout1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(4)*invd(3)*invd(2) - optout2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(4)*invd(3)*invd(2) - - - return - -end subroutine lininterpol4dim diff --git a/src/physics/cam_oslo/lininterpol5dim.F90 b/src/physics/cam_oslo/lininterpol5dim.F90 deleted file mode 100644 index b71f529072..0000000000 --- a/src/physics/cam_oslo/lininterpol5dim.F90 +++ /dev/null @@ -1,69 +0,0 @@ - - subroutine lininterpol5dim (d2mx, dxm1, invd, opt5d, optout1, optout2) - - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - -! -! Input arguments -! - real(r8), intent(in) :: opt5d(2,2,2,2,2) - real(r8), intent(in) :: d2mx(5) - real(r8), intent(in) :: dxm1(5) - real(r8), intent(in) :: invd(5) -! -! Output arguments -! - real(r8), intent(out) :: optout1 - real(r8), intent(out) :: optout2 -! -!---------------------------Local variables----------------------------- -! - real(r8) opt4d(2,2,2,2), opt3d(2,2,2), opt2d(2,2) -! -!------------------------------------------------------------------------ -! -! interpolation in the fifth dimension (except invd(5) factor) - opt4d(1,1,1,1)=d2mx(5)*opt5d(1,1,1,1,1)+dxm1(5)*opt5d(1,1,1,1,2) - opt4d(1,1,1,2)=d2mx(5)*opt5d(1,1,1,2,1)+dxm1(5)*opt5d(1,1,1,2,2) - opt4d(1,1,2,1)=d2mx(5)*opt5d(1,1,2,1,1)+dxm1(5)*opt5d(1,1,2,1,2) - opt4d(1,1,2,2)=d2mx(5)*opt5d(1,1,2,2,1)+dxm1(5)*opt5d(1,1,2,2,2) - opt4d(1,2,1,1)=d2mx(5)*opt5d(1,2,1,1,1)+dxm1(5)*opt5d(1,2,1,1,2) - opt4d(1,2,1,2)=d2mx(5)*opt5d(1,2,1,2,1)+dxm1(5)*opt5d(1,2,1,2,2) - opt4d(1,2,2,1)=d2mx(5)*opt5d(1,2,2,1,1)+dxm1(5)*opt5d(1,2,2,1,2) - opt4d(1,2,2,2)=d2mx(5)*opt5d(1,2,2,2,1)+dxm1(5)*opt5d(1,2,2,2,2) - opt4d(2,1,1,1)=d2mx(5)*opt5d(2,1,1,1,1)+dxm1(5)*opt5d(2,1,1,1,2) - opt4d(2,1,1,2)=d2mx(5)*opt5d(2,1,1,2,1)+dxm1(5)*opt5d(2,1,1,2,2) - opt4d(2,1,2,1)=d2mx(5)*opt5d(2,1,2,1,1)+dxm1(5)*opt5d(2,1,2,1,2) - opt4d(2,1,2,2)=d2mx(5)*opt5d(2,1,2,2,1)+dxm1(5)*opt5d(2,1,2,2,2) - opt4d(2,2,1,1)=d2mx(5)*opt5d(2,2,1,1,1)+dxm1(5)*opt5d(2,2,1,1,2) - opt4d(2,2,1,2)=d2mx(5)*opt5d(2,2,1,2,1)+dxm1(5)*opt5d(2,2,1,2,2) - opt4d(2,2,2,1)=d2mx(5)*opt5d(2,2,2,1,1)+dxm1(5)*opt5d(2,2,2,1,2) - opt4d(2,2,2,2)=d2mx(5)*opt5d(2,2,2,2,1)+dxm1(5)*opt5d(2,2,2,2,2) - -! interpolation in the fourth dimension (except invd(4) factor) - opt3d(1,1,1)=d2mx(4)*opt4d(1,1,1,1)+dxm1(4)*opt4d(1,1,1,2) - opt3d(1,1,2)=d2mx(4)*opt4d(1,1,2,1)+dxm1(4)*opt4d(1,1,2,2) - opt3d(1,2,1)=d2mx(4)*opt4d(1,2,1,1)+dxm1(4)*opt4d(1,2,1,2) - opt3d(1,2,2)=d2mx(4)*opt4d(1,2,2,1)+dxm1(4)*opt4d(1,2,2,2) - opt3d(2,1,1)=d2mx(4)*opt4d(2,1,1,1)+dxm1(4)*opt4d(2,1,1,2) - opt3d(2,1,2)=d2mx(4)*opt4d(2,1,2,1)+dxm1(4)*opt4d(2,1,2,2) - opt3d(2,2,1)=d2mx(4)*opt4d(2,2,1,1)+dxm1(4)*opt4d(2,2,1,2) - opt3d(2,2,2)=d2mx(4)*opt4d(2,2,2,1)+dxm1(4)*opt4d(2,2,2,2) - -! interpolation in the third dimension (except invd(3) factor) - opt2d(1,1)=d2mx(3)*opt3d(1,1,1)+dxm1(3)*opt3d(1,1,2) - opt2d(1,2)=d2mx(3)*opt3d(1,2,1)+dxm1(3)*opt3d(1,2,2) - opt2d(2,1)=d2mx(3)*opt3d(2,1,1)+dxm1(3)*opt3d(2,1,2) - opt2d(2,2)=d2mx(3)*opt3d(2,2,1)+dxm1(3)*opt3d(2,2,2) - -! interpolation in the (fifth, fourth, third and) second dimension - optout1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*(invd(5)*invd(4)*invd(3)*invd(2)) - optout2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*(invd(5)*invd(4)*invd(3)*invd(2)) - - - return - -end subroutine lininterpol5dim diff --git a/src/physics/cam_oslo/opticsAtConstRh.F90 b/src/physics/cam_oslo/opticsAtConstRh.F90 index e48b5737f9..f4790c2cbf 100644 --- a/src/physics/cam_oslo/opticsAtConstRh.F90 +++ b/src/physics/cam_oslo/opticsAtConstRh.F90 @@ -2,9 +2,7 @@ subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbc, vaitbc, v_soana, & - extinction_coeffs, extinction_coeffsn) - + xfombg, ifombg1, vnbc, vaitbc, v_soana) ! Extra AeroCom diagnostics requiring table look-ups with constant/fixed RH, ! i.e. for RH = (/"00","40","55","65","75","85" /) (see opttab.F90) @@ -20,7 +18,7 @@ subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & use physics_types, only: physics_state use interp_aeropt_mod, only : extinction_coeffs_type use interp_aeropt_mod, only : intaeropt0, intaeropt1 - + use aeropt_mod, only : extinction_coeffs, extinction_coeffsn implicit none ! @@ -51,8 +49,6 @@ subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & integer, intent(in) :: ifbc1(pcols,pver,nbmodes) real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - type(extinction_coeffs_type) , intent(inout) :: extinction_coeffs - type(extinction_coeffs_type) , intent(inout) :: extinction_coeffsn ! !---------------------------Local variables----------------------------- ! @@ -191,9 +187,9 @@ subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & basu550tot(icol,k) = basu550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%basu550(icol,k,i) babc550tot(icol,k) = babc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babc550(icol,k,i) baoc550tot(icol,k) = baoc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%baoc550(icol,k,i) - bes4lt1t(icol,k) = bes4lt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bes4lt1(icol,k,i) - bebclt1t(icol,k) = bebclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebclt1(icol,k,i) - beoclt1t(icol,k) = beoclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%beoclt1(icol,k,i) + bes4lt1t(icol,k) = bes4lt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%besu550lt1(icol,k,i) + bebclt1t(icol,k) = bebclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebc550lt1(icol,k,i) + beoclt1t(icol,k) = beoclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%beoc550lt1(icol,k,i) enddo do i=11,14 ec550rh_aer(icol,k) = ec550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext550(icol,k,i-10) @@ -203,14 +199,14 @@ subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & ec870rh_aer(icol,k) = ec870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext870(icol,k,i-10) abs870rh_aer(icol,k) = abs870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs870(icol,k,i-10) ba550x(icol,k,i) = extinction_coeffsn%babs550(icol,k,i-10) - belt1x(icol,k,i) = bebglt1(icol,k,i-10) !??? + belt1x(icol,k,i) = extinction_coeffs%bebg550lt1(icol,k,i-10) !??? enddo do i=6,7 - bedustlt1(icol,k) = bedustlt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) + bedustlt1(icol,k) = bedustlt1(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebg550lt1(icol,k,i) enddo do i=8,10 - besslt1(icol,k) = besslt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) + besslt1(icol,k) = besslt1(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebg550lt1(icol,k,i) enddo ec550rhlt1_du(icol,k) = bedustlt1(icol,k) ec550rhlt1_ss(icol,k) = besslt1(icol,k) @@ -224,17 +220,18 @@ subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 ec550rhlt1_su(icol,k) = bes4lt1t(icol,k) & ! condensate - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k))& ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebglt1(icol,k,5) ! background, SO4(Ait75) mode (5) + + Nnatk(icol,k,1)*extinction_coeffs%bebg550lt1(icol,k,1)*(1.0_r8-v_soana(icol,k))& ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg550lt1(icol,k,5) ! background, SO4(Ait75) mode (5) ec550rhlt1_bc(icol,k) = bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) - + Nnatk(icol,k,4)*bebglt1(icol,k,4)*vaitbc(icol,k) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebglt1(icol,k,0) ! background, BC(ax) mode (0) + + Nnatk(icol,k,2)*extinction_coeffs%bebg550lt1(icol,k,2) & ! background, BC(Ait) mode (2) + + Nnatk(icol,k,4)*extinction_coeffs%bebg550lt1(icol,k,4)*vaitbc(icol,k) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg550lt1(icol,k,0) ! background, BC(ax) mode (0) + !soa + v_soan part of mode 11 for the OC volume fraction of that mode ec550rhlt1_oc(icol,k) = beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC (13) - + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) - + Nnatk(icol,k,4)*bebglt1(icol,k,4)*(1.0_r8-vaitbc(icol,k))& ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) + + Nnatk(icol,k,3)*extinction_coeffs%bebg550lt1(icol,k,3) & ! background, OC(Ait) mode (3) + + Nnatk(icol,k,4)*extinction_coeffs%bebg550lt1(icol,k,4)*(1.0_r8-vaitbc(icol,k))& ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*extinction_coeffs%bebg550lt1(icol,k,1)*v_soana(icol,k) ec550rhlt1_aer(icol,k) = ec550rhlt1_su(icol,k)+ec550rhlt1_bc(icol,k) & + ec550rhlt1_oc(icol,k) + ec550rhlt1_ss(icol,k)+ec550rhlt1_du(icol,k) @@ -245,6 +242,7 @@ subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & abs550rh_ss(icol,k) = Nnatk(icol,k,8)*babg550(icol,k,8) & + Nnatk(icol,k,9)*babg550(icol,k,9) & + Nnatk(icol,k,10)*babg550(icol,k,10) + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 abs550rh_su(icol,k) = basu550tot(icol,k) & ! condensate:w + (1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) diff --git a/src/physics/cam_oslo/optinterpol.F90 b/src/physics/cam_oslo/optinterpol.F90 index a9c5d2b254..35dfd678d3 100644 --- a/src/physics/cam_oslo/optinterpol.F90 +++ b/src/physics/cam_oslo/optinterpol.F90 @@ -1,1814 +1,1875 @@ module optinterpol -! Purpose: To interpolate between look-up table entries for SW optical aerosol properties. + !-------------------------------------------------------------------------------- + ! Purpose: To interpolate between look-up table entries for SW optical aerosol properties. + ! Optimized for speed by Arild Burud and Egil Storen (NoSerC), June-July 2002 + ! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013. + ! Extended for new SOA treatment for kcomp1-4.out and treating SOA as coagulated OC + ! for kcomp5-10 - Alf Kirkevaag, August 2015, and also rewritten to a more generalized + ! for for interpolations using common subroutines interpol*dim. + !-------------------------------------------------------------------------------- + + use shr_kind_mod , only : r8 => shr_kind_r8 + use ppgrid , only : pcols, pver + use commondefinitions , only : nmodes, nbmodes + use opttab_lw , only : ka0, ka1, ka2to3, ka4, ka5to10 + use opttab , only : fombg, fbcbg, cate, cat, fac, faq, fbc, rh, eps -! Optimized for speed by Arild Burud and Egil Storen (NoSerC), June-July 2002 -!-------------------------------------------------------------------------------- - -! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013. -! Extended for new SOA treatment for kcomp1-4.out and treating SOA as coagulated OC -! for kcomp5-10 - Alf Kirkevaag, August 2015, and also rewritten to a more generalized -! for for interpolations using common subroutines interpol*dim. - - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab - use opttab_lw - use commondefinitions, only: nmodes, nbmodes implicit none + private - private - save - - public interpol0 - public interpol1 - public interpol2to3 - public interpol4 - public interpol5to10 - - contains + public :: inputForInterpol + public :: interpol0 + public :: interpol1 + public :: interpol2to3 + public :: interpol4 + public :: interpol5to10 +!******************************************************************************************** +contains !******************************************************************************************** -subroutine interpol0 (lchnk, ncol, daylight, Nnatk, omega, gass, bex, ske, lw_on, kabs) - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - - -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - logical, intent(in) :: daylight(pcols) ! calculations also at (polar) night if daylight=.true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration -! -! Output arguments -! - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient -! -!---------------------------Local variables----------------------------- -! - integer i, kcomp, k, icol + subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & + f_soana, xfombg, ifombg1, faitbc, xfbcbg, ifbcbg1, & + fnbc, xfbcbgn, ifbcbgn1, Nnatk, Cam, xct, ict1, & + focm, fcm, xfac, ifac1, fbcm, xfbc, ifbc1, faqm, xfaq, ifaq1) + + ! + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: rhum(pcols,pver) ! level relative humidity (fraction) + real(r8), intent(in) :: f_soana(pcols,pver) ! SOA/(SOA+H2SO4) mass fraction for the background in mode 1 + real(r8), intent(in) :: faitbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 4 + real(r8), intent(in) :: fnbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 14 + real(r8), intent(in) :: focm(pcols,pver,4) ! fraction of added mass which is either SOA condensate or OC coagulate + real(r8), intent(in) :: Cam(pcols,pver,nbmodes) ! added internally mixed SO4+BC+OC concentration for a normalized mode + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration + real(r8), intent(in) :: fcm(pcols,pver,nbmodes) ! fraction of added mass which is either BC or OC/SOA (carbonaceous) + real(r8), intent(in) :: fbcm(pcols,pver,nbmodes) ! fraction of added mass as BC/(BC+OC) + real(r8), intent(in) :: faqm(pcols,pver,nbmodes) ! fraction of added sulfate which is from aqueous phase (ammonium sulfate) + ! + ! Output arguments + real(r8), intent(out) :: xrh(pcols,pver) ! rhum for use in the interpolations + integer, intent(out) :: irh1(pcols,pver) + real(r8), intent(out) :: xfombg(pcols,pver) ! f_soana for use in the interpolations (mode 1) + integer, intent(out) :: ifombg1(pcols,pver) + real(r8), intent(out) :: xfbcbg(pcols,pver) ! faitbc for use in the interpolations (mode 4) + integer, intent(out) :: ifbcbg1(pcols,pver) + real(r8), intent(out) :: xfbcbgn(pcols,pver) ! fnbc for use in the interpolations (mode 14) + integer, intent(out) :: ifbcbgn1(pcols,pver) + real(r8), intent(out) :: xct(pcols,pver,nmodes) ! Cam/Nnatk for use in the interpolations + integer, intent(out) :: ict1(pcols,pver,nmodes) + real(r8), intent(out) :: xfac(pcols,pver,nbmodes) ! focm (1-4) or fcm (5-10) for use in the interpolations + integer, intent(out) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(out) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations + integer, intent(out) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(out) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations + integer, intent(out) :: ifaq1(pcols,pver,nbmodes) + ! + ! Local variables + integer k, icol, i, irelh + real(r8) :: eps10 = 1.e-10_r8 + !------------------------------------------------------------------------ + ! + ! write(*,*) 'Before xrh-loop' + do k=1,pver + do icol=1,ncol + xrh(icol,k) = min(max(rhum(icol,k),rh(1)),rh(10)) + end do + end do + + ! write(*,*) 'Before rh-loop' + do irelh=1,9 + do k=1,pver + do icol=1,ncol + if(xrh(icol,k) >= rh(irelh).and. & + xrh(icol,k)<=rh(irelh+1)) then + irh1(icol,k)=irelh + endif + end do + end do + end do + ! write(*,*) 'xrh, irh1, irh2 =', xrh(1,26), irh1(1,26), irh2(1,26) + + do k=1,pver + do icol=1,ncol + ! find common xfombg, ifombg1 and ifombg2 for use in the interpolation routines + xfombg(icol,k) =min(max(f_soana(icol,k),fombg(1)),fombg(6)) + ifombg1(icol,k)=int(5.0_r8*xfombg(icol,k)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + + do k=1,pver + do icol=1,ncol + ! find common xfbcbg, ifbcbg1 and ifbcbg2 for use in the interpolation routines + xfbcbg(icol,k) =min(max(faitbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 + ifbcbg1(icol,k)=min(max(int(4*log10(xfbcbg(icol,k))+6),1),5) + ! find common xfbcbgn, ifbcbgn1 and ifbcbgn2 for use in the interpolation routines + xfbcbgn(icol,k) =min(max(fnbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 + ifbcbgn1(icol,k)=min(max(int(4*log10(xfbcbgn(icol,k))+6),1),5) + end do + enddo + + do i=1,4 + do k=1,pver + do icol=1,ncol + ! find common xfac, ifac1 and ifac2 for use in the interpolation routines + xfac(icol,k,i) =min(max(focm(icol,k,i),fac(1)),fac(6)) + ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + enddo + do i=5,nbmodes + do k=1,pver + do icol=1,ncol + ! find common xfac, ifac1 and ifac2 for use in the interpolation routines + xfac(icol,k,i) =min(max(fcm(icol,k,i),fac(1)),fac(6)) + ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + enddo + do i=1,nbmodes + do k=1,pver + do icol=1,ncol + ! find common xfbc, ifbc1 and ifbc2 for use in the interpolation routines + xfbc(icol,k,i) =min(max(fbcm(icol,k,i),fbc(1)),fbc(6)) ! Boer linkes til def. i opttab.F90 + ifbc1(icol,k,i)=min(max(int(4*log10(xfbc(icol,k,i))+6),1),5) + end do + enddo + enddo - kcomp=0 + do i=1,nbmodes + do k=1,pver + do icol=1,ncol + ! find common xfaq, ifaq1 and ifaq2 for use in the interpolation routines + xfaq(icol,k,i) =min(max(faqm(icol,k,i),faq(1)),faq(6)) + ifaq1(icol,k,i)=int(5.0_r8*xfaq(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + enddo - do i=1,nbands + ! find common xct, ict1 and ict2 for use in the interpolation routines ! Boer linkes til def. i opttab.F90 + do i=1,4 + do k=1,pver do icol=1,ncol - do k=1,pver - omega(icol,k,kcomp,i)=0.0_r8 - gass(icol,k,kcomp,i)=0.0_r8 - bex(icol,k,kcomp,i)=0.0_r8 - ske(icol,k,kcomp,i)=0.0_r8 - end do + xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cate(i,1)),cate(i,16)) + if(i.le.2) then + ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+19.666_r8),1),15) + elseif(i.eq.3) then ! mode not used + xct(icol,k,i)=cate(i,1) + ict1(icol,k,i)=1 + else + ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+13.903_r8),1),15) + endif end do - end do - do i=1,nlwbands + end do + end do + + do i=5,10 + do k=1,pver do icol=1,ncol - do k=1,pver - kabs(icol,k,kcomp,i)=0.0_r8 - end do + xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cat(i,1)),cat(i,6)) + if(i.eq.5) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.824_r8),1),5) + elseif(i.eq.6) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.523_r8),1),5) + elseif(i.eq.7) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) + elseif(i.eq.8) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+5.921_r8),1),5) + elseif(i.eq.9) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.301_r8),1),5) + else + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) + endif end do - end do - -! SW optical parameters + end do + end do - do k=1,pver + do i=11,nmodes ! for the externally mixed modes 11-14 (now only 12 and 14) + do k=1,pver do icol=1,ncol + xct(icol,k,i)=cate(i-10,1) + ict1(icol,k,i)=1 + end do + end do + end do + + return + + end subroutine inputForInterpol + + !******************************************************************************************** + subroutine interpol0 (lchnk, ncol, daylight, Nnatk, omega, gass, bex, ske, lw_on, kabs) + ! + ! Arguments + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + logical , intent(in) :: daylight(pcols) ! calculations also at (polar) night if daylight=.true. + logical , intent(in) :: lw_on ! LW calculations are performed if true + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8) , intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8) , intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8) , intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8) , intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands) ! LW spectral modal specific absorption coefficient + ! + ! Local variables + integer i, kcomp, k, icol + !--------------------------------------- + + kcomp=0 + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kcomp,i)=0.0_r8 + gass(icol,k,kcomp,i)=0.0_r8 + bex(icol,k,kcomp,i)=0.0_r8 + ske(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do -! if(Nnatk(icol,k,kcomp)>0.0_r8) then - if(daylight(icol)) then - do i=1,nbands ! i = wavelength index + ! SW optical parameters + + do k=1,pver + do icol=1,ncol + ! if(Nnatk(icol,k,kcomp)>0.0_r8) then + if(daylight(icol)) then + do i=1,nbands ! i = wavelength index omega(icol,k,kcomp,i)=om0(i) - gass(icol,k,kcomp,i)=g0(i) + gass(icol,k,kcomp,i)=g0(i) bex(icol,k,kcomp,i)=be0(i) ske(icol,k,kcomp,i)=ke0(i) - end do ! i - - else ! daylight -! Need be and ke in nband=4 for lw calculation - bex(icol,k,kcomp,4)=be0(4) - ske(icol,k,kcomp,4)=ke0(4) - end if ! daylight - end do ! icol - end do ! k - - if(lw_on) then - -! LW optical parameters - - do k=1,pver + end do ! i + else ! daylight + ! Need be and ke in nband=4 for lw calculation + bex(icol,k,kcomp,4)=be0(4) + ske(icol,k,kcomp,4)=ke0(4) + end if ! daylight + end do ! icol + end do ! k + + ! LW optical parameters + + if(lw_on) then + do k=1,pver do icol=1,ncol - - do i=1,nlwbands ! i = wavelength index - kabs(icol,k,kcomp,i)=ka0(i) - end do ! i - + do i=1,nlwbands ! i = wavelength index + kabs(icol,k,kcomp,i)=ka0(i) + end do ! i end do ! icol - end do ! k - - endif ! lw_on - - return -end subroutine interpol0 - - -!******************************************************************************************** - -subroutine interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfombg, ifombg1, & - xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode - integer, intent(in) :: ifombg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) -! -! -! Input-Output arguments -! -! -! Output arguments -! - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absoption coefficient -! -!---------------------------Local variables----------------------------- -! - integer i, kcomp, k, icol, kc10 - real(r8) a, b - -! Temporary storage of often used array elements - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifo1, t_ifo2 - real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, & - t_cat1, t_cat2, t_fombg1, t_fombg2, t_xfombg - real(r8) d2mx(4), dxm1(4), invd(4) - real(r8) opt4d(2,2,2,2) - real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) kabs1, kabs2 - - -! write(*,*) 'Before kcomp-loop' - do kcomp=1,1 - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - -! write(*,*) 'Before init-loop', kc10 - do i=1,nbands + end do ! k + + endif ! lw_on + + end subroutine interpol0 + + !******************************************************************************************** + subroutine interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfombg, ifombg1, & + xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) + + ! + ! Arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absoption coefficient + ! + ! Local variables + integer i, kcomp, k, icol, kc10 + real(r8) a, b + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifo1, t_ifo2 + real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2 + real(r8) t_cat1, t_cat2, t_fombg1, t_fombg2, t_xfombg + real(r8) d2mx(4), dxm1(4), invd(4) + real(r8) opt4d(2,2,2,2) + real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) kabs1, kabs2 + !--------------------------------------- + + ! write(*,*) 'Before kcomp-loop' + do kcomp=1,1 + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + ! write(*,*) 'Before init-loop', kc10 + do i=1,nbands do icol=1,ncol - do k=1,pver - omega(icol,k,kc10,i)=0.0_r8 - gass(icol,k,kc10,i)=0.0_r8 - bex(icol,k,kc10,i)=0.0_r8 - ske(icol,k,kc10,i)=0.0_r8 - end do + do k=1,pver + omega(icol,k,kc10,i)=0.0_r8 + gass(icol,k,kc10,i)=0.0_r8 + bex(icol,k,kc10,i)=0.0_r8 + ske(icol,k,kc10,i)=0.0_r8 + end do end do - end do - do i=1,nlwbands + end do + do i=1,nlwbands do icol=1,ncol - do k=1,pver - kabs(icol,k,kc10,i)=0.0_r8 + do k=1,pver + kabs(icol,k,kc10,i)=0.0_r8 end do end do - end do - - do k=1,pver - do icol=1,ncol - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifo1 = ifombg1(icol,k) - t_ifo2 = t_ifo1+1 - - t_rh1 = rh(t_irh1) -!x t_rh2 = t_rh1+1 - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fombg1 = fombg(t_ifo1) - t_fombg2 = fombg(t_ifo2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfombg = xfombg(icol,k) - -! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fombg2-t_xfombg) - dxm1(2) = (t_xfombg-t_fombg1) - invd(2) = 1.0_r8/(t_fombg2-t_fombg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - - -! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! single scattering albedo: - -! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - -! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, ome1, ome2) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before omega' - omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & - /(t_rh2-t_rh1) -!alt omega(icol,k,kc10,i)=(d2mx(1)*ome1+dxm1(1)*ome2)*invd(1) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! asymmetry factor - -! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - -! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, ge1, ge2) - -! finally, interpolation in the rh dimension (dim. 1) -! write(*,*) 'Before gass' - gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) -!alt gass(icol,k,kc10,i)=(d2mx(1)*ge1+dxm1(1)*ge2)*invd(1) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol extinction - -! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - -! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) -!alt bex(icol,k,kc10,i)=(d2mx(1)*bex1+dxm1(1)*bex2)*invd(1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) -!alt a=(log(bex2)-log(bex1))*invd(1) -!alt b=(t_rh2*log(bex1)-t_rh1*log(bex2))*invd(1) -!alt bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - -! if(bex(icol,k,kc10,8)<1.e-20_r8) then -! write(*,995) 'bex(8)=', kc10, t_xrh, t_xct, t_xfac, t_xfombg, bex(icol,k,kc10,8) -! endif - else ! daylight - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol extinction used for size information in LW - - i=4 - -! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - -! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - -! finally, interpolation in the rh dimension - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - - do i=4,4 ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol specific extinction - -! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - -! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, ske1, ske2) - - ske1=max(ske1,1.e-30_r8) - ske2=max(ske2,1.e-30_r8) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before ske' - if(t_xrh <= 0.37_r8) then - ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) -!alt ske(icol,k,kc10,i)=(d2mx(1)*ske1+dxm1(1)*ske2)*invd(1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kc10,i)=e**(a*t_xrh+b) -!alt a=(log(ske2)-log(ske1))*invd(1) -!alt b=(t_rh2*log(ske1)-t_rh1*log(ske2))*invd(1) -!alt ske(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - -! LW optical parameters - do i=1,nlwbands ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol specific absorption in LW - -! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - -! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30) - kabs2=max(kabs2,1.e-30) - -! write(*,*) 'Before kabs' - if(t_xrh <= 0.37) then - kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - -! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) -! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) -! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) -! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) - - end do ! kcomp + end do - return -end subroutine interpol1 + do k=1,pver + do icol=1,ncol + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifo1 = ifombg1(icol,k) + t_ifo2 = t_ifo1+1 + + t_rh1 = rh(t_irh1) + !x t_rh2 = t_rh1+1 + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fombg1 = fombg(t_ifo1) + t_fombg2 = fombg(t_ifo2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfombg = xfombg(icol,k) + + ! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fombg2-t_xfombg) + dxm1(2) = (t_xfombg-t_fombg1) + invd(2) = 1.0_r8/(t_fombg2-t_fombg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + + + ! SW optical parameters + if(daylight(icol)) then -!******************************************************************************************** + do i=1,nbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! single scattering albedo: + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, ome1, ome2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before omega' + omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) /(t_rh2-t_rh1) + !alt omega(icol,k,kc10,i)=(d2mx(1)*ome1+dxm1(1)*ome2)*invd(1) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! asymmetry factor + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, ge1, ge2) + + ! finally, interpolation in the rh dimension (dim. 1) + ! write(*,*) 'Before gass' + gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) /(t_rh2-t_rh1) + !alt gass(icol,k,kc10,i)=(d2mx(1)*ge1+dxm1(1)*ge2)*invd(1) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) /(t_rh2-t_rh1) + !alt bex(icol,k,kc10,i)=(d2mx(1)*bex1+dxm1(1)*bex2)*invd(1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + !alt a=(log(bex2)-log(bex1))*invd(1) + !alt b=(t_rh2*log(bex1)-t_rh1*log(bex2))*invd(1) + !alt bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + ! if(bex(icol,k,kc10,8)<1.e-20_r8) then + ! write(*,995) 'bex(8)=', kc10, t_xrh, t_xct, t_xfac, t_xfombg, bex(icol,k,kc10,8) + ! endif + else ! daylight + + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction used for size information in LW + + i=4 + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + do i=4,4 ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific extinction + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, ske1, ske2) + + ske1=max(ske1,1.e-30_r8) + ske2=max(ske2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before ske' + if(t_xrh <= 0.37_r8) then + ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + !alt ske(icol,k,kc10,i)=(d2mx(1)*ske1+dxm1(1)*ske2)*invd(1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kc10,i)=e**(a*t_xrh+b) + !alt a=(log(ske2)-log(ske1))*invd(1) + !alt b=(t_rh2*log(ske1)-t_rh1*log(ske2))*invd(1) + !alt ske(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + if (lw_on) then + + ! LW optical parameters + do i=1,nlwbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific absorption in LW + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30) + kabs2=max(kabs2,1.e-30) + + ! write(*,*) 'Before kabs' + if(t_xrh <= 0.37) then + kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on -subroutine interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, & - xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) - - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) -! -! -! Input-Output arguments -! -! -! Output arguments -! - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient -! -!---------------------------Local variables----------------------------- -! - integer i, kcomp, k, icol, kc10 - real(r8) a, b - -! Temporary storage of often used array elements - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 - real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, & - t_cat1, t_cat2 - real(r8) d2mx(3), dxm1(3), invd(3) - real(r8) opt3d(2,2,2) - real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) kabs1, kabs2 - - -! write(*,*) 'Before kcomp-loop' -! do kcomp=2,3 - do kcomp=2,2 - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - -! write(*,*) 'Before init-loop', kc10 - do i=1,nbands + end do ! icol + end do ! k + + ! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) + ! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) + ! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) + ! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) + + end do ! kcomp + + return + end subroutine interpol1 + + + !******************************************************************************************** + subroutine interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, & + xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) + + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + + ! Output arguments + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient + ! + ! Local variables + integer i, kcomp, k, icol, kc10 + real(r8) a, b + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 + real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2,t_cat1, t_cat2 + real(r8) d2mx(3), dxm1(3), invd(3) + real(r8) opt3d(2,2,2) + real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) kabs1, kabs2 + !--------------------------------------- + + ! write(*,*) 'Before kcomp-loop' + ! do kcomp=2,3 + do kcomp=2,2 + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + ! write(*,*) 'Before init-loop', kc10 + do i=1,nbands do icol=1,ncol - do k=1,pver - omega(icol,k,kc10,i)=0.0_r8 - gass(icol,k,kc10,i)=0.0_r8 - bex(icol,k,kc10,i)=0.0_r8 - ske(icol,k,kc10,i)=0.0_r8 + do k=1,pver + omega(icol,k,kc10,i)=0.0_r8 + gass(icol,k,kc10,i)=0.0_r8 + bex(icol,k,kc10,i)=0.0_r8 + ske(icol,k,kc10,i)=0.0_r8 end do end do - end do - do i=1,nlwbands + end do + do i=1,nlwbands do icol=1,ncol - do k=1,pver - kabs(icol,k,kc10,i)=0.0_r8 + do k=1,pver + kabs(icol,k,kc10,i)=0.0_r8 end do end do - end do - - do k=1,pver - do icol=1,ncol + end do -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - -! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 -! write(*,*) 't_ict1,t_ict2=',t_ict1,t_ict2 -! write(*,*) 't_ifc1,t_ifc2=',t_ifc1,t_ifc2 -! write(*,*) 't_ifa1,t_ifa2=',t_ifa1,t_ifa2 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - -! write(*,*) 't_rh1,t_rh2,t_cat1,t_cat2=',t_rh1,t_rh2,t_cat1,t_cat2 -! write(*,*) 't_fac1,t_fac2=',t_fac1,t_fac2 - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - -! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - - -! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! single scattering albedo: - -! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=om2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=om2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=om2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=om2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=om2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=om2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=om2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=om2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - -! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, ome1, ome2) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before omega' - omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & - /(t_rh2-t_rh1) -! write(*,*) omega(icol,k,kc10,i) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! asymmetry factor - -! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=g2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=g2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=g2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=g2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=g2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=g2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=g2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=g2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - -! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, ge1, ge2) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before gass' - gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) -! write(*,*) gass(icol,k,kc10,i) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol extinction - -! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - -! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) - - bex1=max(bex1,1.e-30) - bex2=max(bex2,1.e-30) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before bex' - if(t_xrh <= 0.37) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - else ! daylight - - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol extinction used for LW size information - - i=4 -! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - -! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) - - bex1=max(bex1,1.e-30) - bex2=max(bex2,1.e-30) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before bex' - if(t_xrh <= 0.37) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - - - do i=4,4 ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol specific extinction - -! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=ke2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=ke2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=ke2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=ke2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=ke2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=ke2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=ke2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=ke2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - -! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, ske1, ske2) - - ske1=max(ske1,1.e-30) - ske2=max(ske2,1.e-30) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before ske' - if(t_xrh <= 0.37) then - ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - -! LW optical parameters - do i=1,nlwbands ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol specific absorption in LW - -! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=ka2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=ka2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=ka2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=ka2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=ka2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=ka2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=ka2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=ka2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + do k=1,pver + do icol=1,ncol -! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, kabs1, kabs2) + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + ! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 + ! write(*,*) 't_ict1,t_ict2=',t_ict1,t_ict2 + ! write(*,*) 't_ifc1,t_ifc2=',t_ifc1,t_ifc2 + ! write(*,*) 't_ifa1,t_ifa2=',t_ifa1,t_ifa2 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + + ! write(*,*) 't_rh1,t_rh2,t_cat1,t_cat2=',t_rh1,t_rh2,t_cat1,t_cat2 + ! write(*,*) 't_fac1,t_fac2=',t_fac1,t_fac2 + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + + ! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + + + ! SW optical parameters + if(daylight(icol)) then - kabs1=max(kabs1,1.e-30_r8) - kabs2=max(kabs2,1.e-30_r8) + do i=1,nbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! single scattering albedo: + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=om2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=om2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=om2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=om2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=om2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=om2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=om2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=om2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, ome1, ome2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before omega' + omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & + /(t_rh2-t_rh1) + ! write(*,*) omega(icol,k,kc10,i) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! asymmetry factor + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=g2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=g2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=g2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=g2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=g2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=g2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=g2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=g2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, ge1, ge2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before gass' + gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) + ! write(*,*) gass(icol,k,kc10,i) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) + + bex1=max(bex1,1.e-30) + bex2=max(bex2,1.e-30) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + else ! daylight + + + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction used for LW size information + + i=4 + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) + + bex1=max(bex1,1.e-30) + bex2=max(bex2,1.e-30) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + + + do i=4,4 ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific extinction + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=ke2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=ke2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=ke2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=ke2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=ke2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=ke2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=ke2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=ke2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, ske1, ske2) + + ske1=max(ske1,1.e-30) + ske2=max(ske2,1.e-30) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before ske' + if(t_xrh <= 0.37) then + ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + + ! LW optical parameters + do i=1,nlwbands ! i = wavelength index -! write(*,*) 'Before kabs' - if(t_xrh <= 0.37_r8) then - kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific absorption in LW - endif ! lw_on + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=ka2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=ka2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=ka2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=ka2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=ka2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=ka2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=ka2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=ka2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - end do ! icol - end do ! k + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, kabs1, kabs2) -! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) -! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) -! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) -! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) + kabs1=max(kabs1,1.e-30_r8) + kabs2=max(kabs2,1.e-30_r8) - end do ! kcomp + ! write(*,*) 'Before kabs' + if(t_xrh <= 0.37_r8) then + kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i - return -end subroutine interpol2to3 + endif ! lw_on -!******************************************************************************************** - -subroutine interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfbcbg, ifbcbg1, & - xct, ict1, xfac, ifac1, xfaq, ifaq1, & - omega, gass, bex, ske, lw_on, kabs) - - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - - -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode - integer, intent(in) :: ifbcbg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) -! -! Input-Output arguments -! -! -! Output arguments -! - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient -! -!---------------------------Local variables----------------------------- -! - integer i, kcomp, k, kc10, icol - real(r8) a, b - -! Temporary storage of often used array elements - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2, & - t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) t_faq1, t_faq2, t_xfaq, t_fbcbg1, t_fbcbg2, t_xfbcbg, t_fac1, & - t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 - - real(r8) d2mx(5), dxm1(5), invd(5) - real(r8) opt5d(2,2,2,2,2) - real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) kabs1, kabs2 - - -! write(*,*) 'Before kcomp-loop' - do kcomp=4,4 - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - -! write(*,*) 'Before init-loop', kc10 - do i=1,nbands + end do ! icol + end do ! k + + ! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) + ! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) + ! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) + ! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) + + end do ! kcomp + + return + end subroutine interpol2to3 + + !******************************************************************************************** + + subroutine interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfbcbg, ifbcbg1, & + xct, ict1, xfac, ifac1, xfaq, ifaq1, & + omega, gass, bex, ske, lw_on, kabs) + + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode + integer, intent(in) :: ifbcbg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + + ! Output arguments + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient + ! + ! Local variables + integer :: i, kcomp, k, kc10, icol + real(r8) :: a, b + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2, t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) :: t_faq1, t_faq2, t_xfaq, t_fbcbg1, t_fbcbg2, t_xfbcbg, t_fac1 + real(r8) :: t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) :: kabs1, kabs2 + !--------------------------------------- + + ! write(*,*) 'Before kcomp-loop' + do kcomp=4,4 + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + ! write(*,*) 'Before init-loop', kc10 + do i=1,nbands do icol=1,ncol - do k=1,pver - omega(icol,k,kc10,i)=0.0_r8 - gass(icol,k,kc10,i)=0.0_r8 - bex(icol,k,kc10,i)=0.0_r8 - ske(icol,k,kc10,i)=0.0_r8 - end do + do k=1,pver + omega(icol,k,kc10,i)=0.0_r8 + gass(icol,k,kc10,i)=0.0_r8 + bex(icol,k,kc10,i)=0.0_r8 + ske(icol,k,kc10,i)=0.0_r8 + end do end do - end do - do i=1,nlwbands + end do + do i=1,nlwbands do icol=1,ncol - do k=1,pver - kabs(icol,k,kc10,i)=0.0_r8 + do k=1,pver + kabs(icol,k,kc10,i)=0.0_r8 end do end do - end do - - do k=1,pver - do icol=1,ncol - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifb1 = ifbcbg1(icol,k) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - t_xfbcbg = xfbcbg(icol,k) - t_xfaq = xfaq(icol,k,kcomp) - -! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fbcbg2-t_xfbcbg) - dxm1(2) = (t_xfbcbg-t_fbcbg1) - invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - -! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! single scattering albedo: - - opt5d(1,1,1,1,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - -! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before omega' - omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & - /(t_rh2-t_rh1) -! write(*,*) omega(icol,k,kc10,i) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! asymmetry factor - - opt5d(1,1,1,1,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - -! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before gass' - gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol extinction - - opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - -! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - else ! daylight - - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol extinction called for use in size estimate for use in LW - i=4 - - opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - -! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - - - - - do i=4,4 ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol specific extinction - - opt5d(1,1,1,1,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - -! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) - - ske1=max(ske1,1.e-30_r8) - ske2=max(ske2,1.e-30_r8) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before ske' - if(t_xrh <= 0.37_r8) then - ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - -! LW optical parameters - - do i=1,nlwbands ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol specific absorption - - opt5d(1,1,1,1,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - -! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30_r8) - kabs2=max(kabs2,1.e-30_r8) - -! write(*,*) 'Before kabs' - if(t_xrh <= 0.37_r8) then - kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - -! write(*,*) 'kcomp, omega(1,26,kc10,4)=', kcomp, omega(1,26,kc10,4) -! write(*,*) 'kcomp, gass(1,26,kc10,4)=', kcomp, gass(1,26,kc10,4) -! write(*,*) 'kcomp, bex(1,26,kc10,4)=', kcomp, bex(1,26,kc10,4) -! write(*,*) 'kcomp, ske(1,26,kc10,4)=', kcomp, ske(1,26,kc10,4) - - end do ! kcomp + end do - return -end subroutine interpol4 + do k=1,pver + do icol=1,ncol + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifb1 = ifbcbg1(icol,k) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + t_xfbcbg = xfbcbg(icol,k) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fbcbg2-t_xfbcbg) + dxm1(2) = (t_xfbcbg-t_fbcbg1) + invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + ! SW optical parameters + if(daylight(icol)) then -!******************************************************************************************** + do i=1,nbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! single scattering albedo: + + opt5d(1,1,1,1,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before omega' + omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) /(t_rh2-t_rh1) + ! write(*,*) omega(icol,k,kc10,i) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! asymmetry factor + + opt5d(1,1,1,1,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before gass' + gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction + + opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + else ! daylight + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction called for use in size estimate for use in LW + i=4 + + opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + do i=4,4 ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific extinction + + opt5d(1,1,1,1,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) + + ske1=max(ske1,1.e-30_r8) + ske2=max(ske2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before ske' + if(t_xrh <= 0.37_r8) then + ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + + ! LW optical parameters + + do i=1,nlwbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific absorption + + opt5d(1,1,1,1,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30_r8) + kabs2=max(kabs2,1.e-30_r8) + + ! write(*,*) 'Before kabs' + if(t_xrh <= 0.37_r8) then + kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on -subroutine interpol5to10 (lchnk, ncol, daylight, xrh, irh1, Nnatk, xct, ict1, & - xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - omega, gass, bex, ske, lw_on, kabs) - - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - - -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) - integer, intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) -! -! -! Input-Output arguments -! -! -! Output arguments -! - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient -! -!---------------------------Local variables----------------------------- -! - integer i, kcomp, k, icol - real(r8) a, b - -! Temporary storage of often used array elements - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2, & - t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) t_faq1, t_faq2, t_xfaq, t_fbc1, t_fbc2, t_xfbc, t_fac1, & - t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 - real(r8) d2mx(5), dxm1(5), invd(5) - real(r8) opt5d(2,2,2,2,2) - real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) kabs1, kabs2 - - -! write(*,*) 'Before kcomp-loop' - do kcomp=5,10 - -! write(*,*) 'Before init-loop', kcomp - do i=1,nbands + end do ! icol + end do ! k + + ! write(*,*) 'kcomp, omega(1,26,kc10,4)=', kcomp, omega(1,26,kc10,4) + ! write(*,*) 'kcomp, gass(1,26,kc10,4)=', kcomp, gass(1,26,kc10,4) + ! write(*,*) 'kcomp, bex(1,26,kc10,4)=', kcomp, bex(1,26,kc10,4) + ! write(*,*) 'kcomp, ske(1,26,kc10,4)=', kcomp, ske(1,26,kc10,4) + + end do ! kcomp + + end subroutine interpol4 + + !******************************************************************************************** + subroutine interpol5to10 (lchnk, ncol, daylight, xrh, irh1, Nnatk, xct, ict1, & + xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + omega, gass, bex, ske, lw_on, kabs) + + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) + integer, intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + + ! Output arguments + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient + + ! Local variables + integer :: i, kcomp, k, icol + real(r8) :: a, b + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 + integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) :: t_faq1, t_faq2, t_xfaq, t_fbc1, t_fbc2, t_xfbc, t_fac1, & + real(r8) :: t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) :: kabs1, kabs2 + !--------------------------------------- + + ! write(*,*) 'Before kcomp-loop' + do kcomp=5,10 + + ! write(*,*) 'Before init-loop', kcomp + do i=1,nbands do icol=1,ncol - do k=1,pver - omega(icol,k,kcomp,i)=0.0_r8 - gass(icol,k,kcomp,i)=0.0_r8 - bex(icol,k,kcomp,i)=0.0_r8 - ske(icol,k,kcomp,i)=0.0_r8 - end do + do k=1,pver + omega(icol,k,kcomp,i)=0.0_r8 + gass(icol,k,kcomp,i)=0.0_r8 + bex(icol,k,kcomp,i)=0.0_r8 + ske(icol,k,kcomp,i)=0.0_r8 + end do end do - end do - do i=1,nlwbands + end do + do i=1,nlwbands do icol=1,ncol - do k=1,pver - kabs(icol,k,kcomp,i)=0.0_r8 - end do + do k=1,pver + kabs(icol,k,kcomp,i)=0.0_r8 + end do end do - end do - - do k=1,pver - do icol=1,ncol - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - t_ifb1 = ifbc1(icol,k,kcomp) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cat(kcomp,t_ict1) - t_cat2 = cat(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbc1 = fbc(t_ifb1) - t_fbc2 = fbc(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfbc = xfbc(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - -! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - d2mx(4) = (t_fbc2-t_xfbc) - dxm1(4) = (t_xfbc-t_fbc1) - invd(4) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - -! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! single scattering albedo: - - opt5d(1,1,1,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - -! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before omega' - omega(icol,k,kcomp,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & - /(t_rh2-t_rh1) -! write(*,*) omega(icol,k,kcomp,i) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! asymmetry factor - - opt5d(1,1,1,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - -! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before gass' - gass(icol,k,kcomp,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol extinction - - opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - -! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - end do ! i - else ! daylight - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol extinction used for aerosol size estimate needed for LW calculations - i=4 - opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - -! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - - - do i=4,4 ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol specific extinction - - opt5d(1,1,1,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - -! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) - - ske1=max(ske1,1.e-30_r8) - ske2=max(ske2,1.e-30_r8) - -! finally, interpolation in the rh dimension -! write(*,*) 'Before ske' - if(t_xrh <= 0.37_r8) then - ske(icol,k,kcomp,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - -! LW optical parameters - - do i=1,nlwbands ! i = wavelength index - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! aerosol specific absorption - - opt5d(1,1,1,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - -! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30_r8) - kabs2=max(kabs2,1.e-30_r8) - -! write(*,*) 'Before kabs' - if(t_xrh <= 0.37_r8) then - kabs(icol,k,kcomp,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - + end do - end do ! kcomp + do k=1,pver + do icol=1,ncol - return -end subroutine interpol5to10 + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + t_ifb1 = ifbc1(icol,k,kcomp) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cat(kcomp,t_ict1) + t_cat2 = cat(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbc1 = fbc(t_ifb1) + t_fbc2 = fbc(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfbc = xfbc(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + d2mx(4) = (t_fbc2-t_xfbc) + dxm1(4) = (t_xfbc-t_fbc1) + invd(4) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + ! SW optical parameters + if(daylight(icol)) then + do i=1,nbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! single scattering albedo: + + opt5d(1,1,1,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before omega' + omega(icol,k,kcomp,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & + /(t_rh2-t_rh1) + ! write(*,*) omega(icol,k,kcomp,i) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! asymmetry factor + + opt5d(1,1,1,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before gass' + gass(icol,k,kcomp,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction + + opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + end do ! i + else ! daylight + + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction used for aerosol size estimate needed for LW calculations + i=4 + opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + + + do i=4,4 ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific extinction + + opt5d(1,1,1,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) + + ske1=max(ske1,1.e-30_r8) + ske2=max(ske2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before ske' + if(t_xrh <= 0.37_r8) then + ske(icol,k,kcomp,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + + ! LW optical parameters + + do i=1,nlwbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific absorption + + opt5d(1,1,1,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30_r8) + kabs2=max(kabs2,1.e-30_r8) + + ! write(*,*) 'Before kabs' + if(t_xrh <= 0.37_r8) then + kabs(icol,k,kcomp,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on -!******************************************************************************************** + end do ! icol + end do ! k + end do ! kcomp + end subroutine interpol5to10 end module optinterpol diff --git a/src/physics/cam_oslo/opttab.F90 b/src/physics/cam_oslo/opttab.F90 index 094695d8c1..2b5757dc6a 100644 --- a/src/physics/cam_oslo/opttab.F90 +++ b/src/physics/cam_oslo/opttab.F90 @@ -1,34 +1,29 @@ module opttab -!Purpose: To read in SW look-up tables for calculation of aerosol optical properties, -! and to define the grid for discrete input-values in these look-up tables. - -! Modified for new wavelength bands and look-up tables - Alf Kirkevaag Dec. 2013. -! Updated for reading input files with extra header info - Alf Kirkevaag, May 2015. -! Extended for new SOA treatment - Alf Kirkevaag, August 2015. -! Added output (ASCII) Jabuary 2016: #ifdef COLTST4INTCONS -> extinction -! koefficients (wrt. all added mass including condensed water vapour) are -! written out for checking against the look-up tables (using xmgrace), e.g. -! as function of RH (to be changed to whatever parameter the user is interested in) -! Modified for optimized added masses and mass fractions for concentrations from -! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. -! Modified cate values for kcomp=2 (as in AeroTab) - Alf Kirkevaag October 2016. - -#include + !Purpose: To read in SW look-up tables for calculation of aerosol optical properties, + ! and to define the grid for discrete input-values in these look-up tables. + + ! Modified for new wavelength bands and look-up tables - Alf Kirkevaag Dec. 2013. + ! Updated for reading input files with extra header info - Alf Kirkevaag, May 2015. + ! Extended for new SOA treatment - Alf Kirkevaag, August 2015. + ! Added output (ASCII) Jabuary 2016: #ifdef COLTST4INTCONS -> extinction + ! koefficients (wrt. all added mass including condensed water vapour) are + ! written out for checking against the look-up tables (using xmgrace), e.g. + ! as function of RH (to be changed to whatever parameter the user is interested in) + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + ! Modified cate values for kcomp=2 (as in AeroTab) - Alf Kirkevaag October 2016. use shr_kind_mod, only: r8 => shr_kind_r8 use cam_logfile, only: iulog implicit none private - save - ! Interfaces - public initopt - + public :: initopt -! integer, public, parameter :: nbands=12 ! number of aerosol spectral bands in CAM4-Oslo + ! integer, public, parameter :: nbands=12 ! number of aerosol spectral bands in CAM4-Oslo integer, public, parameter :: nbands=14 ! number of aerosol spectral bands in SW integer, public, parameter :: nbmp1=11 ! number of first non-background mode @@ -36,7 +31,7 @@ module opttab real(r8), public, dimension(6) :: fombg, fbcbg, fac, fbc, faq real(r8), public, dimension(4,16) :: cate real(r8), public, dimension(5:10,6) :: cat - + real(r8), public :: om1(nbands,10,6,16,6) real(r8), public :: g1 (nbands,10,6,16,6) real(r8), public :: be1(nbands,10,6,16,6) @@ -62,600 +57,520 @@ module opttab real(r8), public :: be5to10(nbands,10,6,6,6,6,5:10) real(r8), public :: ke5to10(nbands,10,6,6,6,6,5:10) -! relative humidity (RH, as integer for output variable names) for use in AeroCom code + ! relative humidity (RH, as integer for output variable names) for use in AeroCom code integer, public, dimension(6) :: RF = (/0, 40, 55, 65, 75, 85 /) -! AeroCom specific RH input variables for use in opticsAtConstRh.F90 - integer, public :: irhrf1(6) + ! AeroCom specific RH input variables for use in opticsAtConstRh.F90 + integer , public :: irhrf1(6) real(r8), public :: xrhrf(6) real(r8), public :: e, eps parameter (e=2.718281828_r8, eps=1.0e-30_r8) - - - contains - -subroutine initopt - -!--------------------------------------------------------------- -! Modified by Egil Storen/NoSerC July 2002. -! The sequence of the indices in arrays om1, g1, be1 and ke1 -! (common block /tab1/) has been rearranged to avoid cache -! problems while running subroutine interpol1. Files also -! involved by this modification: interpol1.F and opttab.h. -! Modified for new aerosol schemes by Alf Kirkevaag in January -! 2006. Modified for new wavelength bands and look-up tables -! by Alf Kirkevaag in December 2013, and for SOA in August 2015. -!--------------------------------------------------------------- - - use oslo_control, only : oslo_getopts, dir_string_length - - implicit none - - integer kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq, i, irf - integer ifombg, ifbcbg - integer ik, ic, ifil, lin, linmax - real(r8) catot, relh, frac, fabc, fraq, frombg, frbcbg - real(r8) ssa, ass, ext, spext - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps3 = 1.e-3_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - character(len=dir_string_length) :: aerotab_table_dir - -! Defining array bounds for tabulated optical parameters (and r and sigma) -! relative humidity (only 0 value used for r and sigma tables): - rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) - -! AeroCom specific RH input variables for use in opticsAtConstRh.F90 - do irf=1,6 - xrhrf(irf) = real(RF(irf))*0.01_r8 - enddo - do irelh=1,9 - do irf=1,6 - if(xrhrf(irf)>=rh(irelh).and.xrhrf(irf)<=rh(irelh+1)) then + +contains + + subroutine initopt() + + !--------------------------------------------------------------- + ! Modified by Egil Storen/NoSerC July 2002. + ! The sequence of the indices in arrays om1, g1, be1 and ke1 + ! (common block /tab1/) has been rearranged to avoid cache + ! problems while running subroutine interpol1. Files also + ! involved by this modification: interpol1.F and opttab.h. + ! Modified for new aerosol schemes by Alf Kirkevaag in January + ! 2006. Modified for new wavelength bands and look-up tables + ! by Alf Kirkevaag in December 2013, and for SOA in August 2015. + !--------------------------------------------------------------- + + use oslo_control, only : oslo_getopts, dir_string_length + + ! Local variables + integer :: kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq, i, irf + integer :: ifombg, ifbcbg + integer :: ik, ic, ifil, lin, linmax + real(r8) :: catot, relh, frac, fabc, fraq, frombg, frbcbg + real(r8) :: ssa, ass, ext, spext + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps3 = 1.e-3_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + character(len=dir_string_length) :: aerotab_table_dir + !----------------------------------------------------------- + + ! Defining array bounds for tabulated optical parameters (and r and sigma) + ! relative humidity (only 0 value used for r and sigma tables): + rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) + + ! AeroCom specific RH input variables for use in opticsAtConstRh.F90 + do irf=1,6 + xrhrf(irf) = real(RF(irf))*0.01_r8 + enddo + do irelh=1,9 + do irf=1,6 + if(xrhrf(irf)>=rh(irelh).and.xrhrf(irf)<=rh(irelh+1)) then irhrf1(irf)=irelh - endif - end do - end do - -! mass fractions internal mixtures in background (fombg and fbcbg) and mass added to the -! background modes (fac, faq, faq) - fombg = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) - fac = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) - faq = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) - -! with more weight on low fractions (thus a logaritmic f axis) for BC, -! which is less ambundant than sulfate and OC, and the first value -! corresponding to a clean background mode: - fbcbg(1)=1.e-10_r8 - fbc(1)=1.e-10_r8 - do i=2,6 - fbcbg(i)=10**((i-1)/4.0_r8-1.25_r8) - fbc(i)=fbcbg(i) - end do -! and most weight on small concentrations for added mass onto the background: - do kcomp=1,4 - cate(kcomp,1)=1.e-10_r8 - do i=2,16 + endif + end do + end do + + ! mass fractions internal mixtures in background (fombg and fbcbg) and mass added to the + ! background modes (fac, faq, faq) + fombg = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) + fac = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) + faq = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) + + ! with more weight on low fractions (thus a logaritmic f axis) for BC, + ! which is less ambundant than sulfate and OC, and the first value + ! corresponding to a clean background mode: + fbcbg(1)=1.e-10_r8 + fbc(1)=1.e-10_r8 + do i=2,6 + fbcbg(i)=10**((i-1)/4.0_r8-1.25_r8) + fbc(i)=fbcbg(i) + end do + ! and most weight on small concentrations for added mass onto the background: + do kcomp=1,4 + cate(kcomp,1)=1.e-10_r8 + do i=2,16 if(kcomp.eq.1.or.kcomp.eq.2) then - cate(kcomp,i)=10.0_r8**((i-1)/3.0_r8-6.222_r8) + cate(kcomp,i)=10.0_r8**((i-1)/3.0_r8-6.222_r8) elseif(kcomp.eq.3) then - cate(kcomp,i)=1.0e-10_r8 ! not used + cate(kcomp,i)=1.0e-10_r8 ! not used else - cate(kcomp,i)=10.0_r8**((i-1)/3.0_r8-4.301_r8) + cate(kcomp,i)=10.0_r8**((i-1)/3.0_r8-4.301_r8) endif - end do - end do - do kcomp=5,10 - cat(kcomp,1) =1.e-10_r8 - do i=2,6 + end do + end do + do kcomp=5,10 + cat(kcomp,1) =1.e-10_r8 + do i=2,6 if(kcomp.eq.5) then - cat(kcomp,i)=10.0_r8**((i-1)-3.824_r8) + cat(kcomp,i)=10.0_r8**((i-1)-3.824_r8) elseif(kcomp.eq.6) then - cat(kcomp,i)=10.0_r8**((i-1)-3.523_r8) + cat(kcomp,i)=10.0_r8**((i-1)-3.523_r8) elseif(kcomp.eq.7) then - cat(kcomp,i)=10.0_r8**((i-1)-3.699_r8) + cat(kcomp,i)=10.0_r8**((i-1)-3.699_r8) elseif(kcomp.eq.8) then - cat(kcomp,i)=10.0_r8**((i-1)-4.921_r8) + cat(kcomp,i)=10.0_r8**((i-1)-4.921_r8) elseif(kcomp.eq.9) then - cat(kcomp,i)=10.0_r8**((i-1)-3.301_r8) + cat(kcomp,i)=10.0_r8**((i-1)-3.301_r8) else - cat(kcomp,i)=10.0_r8**((i-1)-3.699_r8) + cat(kcomp,i)=10.0_r8**((i-1)-3.699_r8) endif - end do - end do - - call oslo_getopts(aerotab_table_dir_out= aerotab_table_dir) - -! Opening the 'kcomp'-files: - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - open(40,file=trim(aerotab_table_dir)//'/kcomp1.out' & - ,form='formatted',status='old') - open(41,file=trim(aerotab_table_dir)//'/kcomp2.out' & - ,form='formatted',status='old') - open(42,file=trim(aerotab_table_dir)//'/kcomp3.out' & - ,form='formatted',status='old') - open(43,file=trim(aerotab_table_dir)//'/kcomp4.out' & - ,form='formatted',status='old') - open(44,file=trim(aerotab_table_dir)//'/kcomp5.out' & - ,form='formatted',status='old') - open(45,file=trim(aerotab_table_dir)//'/kcomp6.out' & - ,form='formatted',status='old') - open(46,file=trim(aerotab_table_dir)//'/kcomp7.out' & - ,form='formatted',status='old') - open(47,file=trim(aerotab_table_dir)//'/kcomp8.out' & - ,form='formatted',status='old') - open(48,file=trim(aerotab_table_dir)//'/kcomp9.out' & - ,form='formatted',status='old') - open(49,file=trim(aerotab_table_dir)//'/kcomp10.out'& - ,form='formatted',status='old') - open(50,file=trim(aerotab_table_dir)//'/kcomp0.out'& - ,form='formatted',status='old') - -! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 40,50 - call checkTableHeader (ifil) - enddo - -! Then reading in the look-up table entries for each file (kcomp*.out) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! Mode 0, BC(ax) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 11 - linmax=nbands - do lin = 1,linmax - - read(39+ifil,996) kcomp, iwl, relh, & - ssa, ass, ext, spext - om0(iwl)=ssa - g0 (iwl)=ass - be0(iwl)=ext ! unit km^-1 - ke0(iwl)=spext ! unit m^2/g - -! write(iulog,*) 'kcomp, om =', kcomp, om0(iwl) -! write(iulog,*) 'kcomp, g =', kcomp, g0(iwl) -! write(iulog,*) 'kcomp, be =', kcomp, be0(iwl) -! write(iulog,*) 'kcomp, ke =', kcomp, ke0(iwl) - - end do + end do + end do + + call oslo_getopts(aerotab_table_dir_out= aerotab_table_dir) + + ! Opening the 'kcomp'-files: + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + open(50,file=trim(aerotab_table_dir)//'/kcomp0.out' ,form='formatted',status='old') + open(40,file=trim(aerotab_table_dir)//'/kcomp1.out' ,form='formatted',status='old') + open(41,file=trim(aerotab_table_dir)//'/kcomp2.out' ,form='formatted',status='old') + open(42,file=trim(aerotab_table_dir)//'/kcomp3.out' ,form='formatted',status='old') + open(43,file=trim(aerotab_table_dir)//'/kcomp4.out' ,form='formatted',status='old') + open(44,file=trim(aerotab_table_dir)//'/kcomp5.out' ,form='formatted',status='old') + open(45,file=trim(aerotab_table_dir)//'/kcomp6.out' ,form='formatted',status='old') + open(46,file=trim(aerotab_table_dir)//'/kcomp7.out' ,form='formatted',status='old') + open(47,file=trim(aerotab_table_dir)//'/kcomp8.out' ,form='formatted',status='old') + open(48,file=trim(aerotab_table_dir)//'/kcomp9.out' ,form='formatted',status='old') + open(49,file=trim(aerotab_table_dir)//'/kcomp10.out',form='formatted',status='old') + + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 40,50 + call checkTableHeader (ifil) + enddo + + ! Then reading in the look-up table entries for each file (kcomp*.out) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! Mode 0, BC(ax) + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 11 + linmax=nbands + do lin = 1,linmax + read(39+ifil,'(2I3,f8.3,4(x,e12.5)') kcomp, iwl, relh, ssa, ass, ext, spext + om0(iwl)=ssa + g0 (iwl)=ass + be0(iwl)=ext ! unit km^-1 + ke0(iwl)=spext ! unit m^2/g + ! write(iulog,*) 'kcomp, om =', kcomp, om0(iwl) + ! write(iulog,*) 'kcomp, g =', kcomp, g0(iwl) + ! write(iulog,*) 'kcomp, be =', kcomp, be0(iwl) + ! write(iulog,*) 'kcomp, ke =', kcomp, ke0(iwl) + end do do iwl=1,nbands - if(be0(iwl)<=0.0_r8) then - write(iulog,*) 'be0 =', iwl, be0(iwl) - write(iulog,*) 'Error in initialization of be0' - stop - endif + if(be0(iwl)<=0.0_r8) then + write(iulog,*) 'be0 =', iwl, be0(iwl) + write(iulog,*) 'Error in initialization of be0' + stop + endif enddo - write(iulog,*)'mode 0 ok' + write(iulog,*)'mode 0 ok' -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! Mode 1 (H2SO4 and SOA + condesate from H2SO4 and SOA) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! Mode 1 (H2SO4 and SOA + condesate from H2SO4 and SOA) + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc #ifdef COLTST4INTCONS -! open(101, file='check-kcomp1.out') + ! open(101, file='check-kcomp1.out') #endif - linmax = nbands*10*6*16*6 ! 14*10*6*16*6 - do ifil = 1,1 - do lin = 1,linmax + linmax = nbands*10*6*16*6 ! 14*10*6*16*6 + do lin = 1,linmax - read(39+ifil,995) kcomp, iwl, relh, frombg, catot, frac, & - ssa, ass, ext, spext + read(40,'(2I3,f8.3,3(x,e10.3),4(x,e12.5)') kcomp, iwl, relh, frombg, catot, frac, ssa, ass, ext, spext - do ic=1,10 - if(abs(relh-rh(ic)) +!#include !=============================================================================== contains !=============================================================================== -subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, & - volc_ext_earth, volc_omega_earth, & -#ifdef AEROCOM - aodvis, absvis, dod440, dod550, dod870, abs550, abs550alt) -#else - aodvis, absvis) -#endif - -! Optical parameters for a composite aerosol is calculated by interpolation -! from the tables kcomp1.out-kcomp14.out. -! Optimized June 2002 byrild Burud/NoSerC -! Optimized July 2002 by Egil Storen/NoSerC (ces) -! Revised for inclusion of OC and modified aerosol backgeound aerosol -! by Alf Kirkevaag in 2003, and finally rewritten for CAM3 February 2005. -! Modified for new aerosol schemes by Alf Kirkevaag in January 2006. -! Updated by Alf Kirkevåg, May 2013: The SO4(Ait) mode now takes into -! account condensed SOA in addition to H2SO4. -! Updated for CAM5-Oslo with RRTMG by Alf Kirkevåg, 2014-2015, for new -! SOA treatment August/September 2015, and for cleanig up and optimizing -! the code around interpolations in November 2016. - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_history, only: outfld - use constituents, only: pcnst - use physconst, only: rair,pi - use opttab - use oslo_utils, only: calculateNumberConcentration - use parmix_progncdnc, only: calculateBulkProperties, partitionMass - use opttab_lw - use const - use aerosoldef - use commondefinitions - use optinterpol, only: interpol0,interpol1,interpol2to3,interpol4,interpol5to10 - use physics_types, only: physics_state - use wv_saturation, only: qsat_water - - implicit none - -! -! Input arguments - - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle - real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) - real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures (Pa) - real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures (K) - real(r8), intent(in) :: cld(pcols,pver) ! cloud fraction - real(r8), intent(in) :: qm1(pcols,pver,pcnst) ! Specific humidity and tracers (kg/kg) - real(r8), intent(in) :: volc_ext_sun(pcols,pver,nbands) ! volcanic aerosol extinction for solar bands, CMIP6 - real(r8), intent(in) :: volc_omega_sun(pcols,pver,nbands) ! volcanic aerosol SSA for solar bands, CMIP6 - real(r8), intent(in) :: volc_g_sun(pcols,pver,nbands) ! volcanic aerosol g for solar bands, CMIP6 - real(r8), intent(in) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 - real(r8), intent(in) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 -! real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) ! for testing bare -! -! Input-output arguments - - real(r8), intent(inout) :: Nnatk(pcols,pver,0:nmodes)! aerosol mode number concentration - -! Output arguments -! - real(r8), intent(out) :: per_tau (pcols,0:pver,nbands) ! aerosol extinction optical depth - real(r8), intent(out) :: per_tau_w (pcols,0:pver,nbands) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: per_tau_w_g(pcols,0:pver,nbands) ! aerosol assymetry parameter * w * tau - real(r8), intent(out) :: per_tau_w_f(pcols,0:pver,nbands) ! aerosol forward scattered fraction * w * tau - real(r8), intent(out) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optical depth (LW) -! AOD and absorptive AOD for visible wavelength closest to 0.55 um (0.442-0.625) -! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values - real(r8), intent(out) :: aodvis(pcols) ! AOD vis - real(r8), intent(out) :: absvis(pcols) ! AAOD vis - -! -!---------------------------Local variables----------------------------- -! - integer i, k, ib, icol, mplus10 - integer iloop - logical daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. - - real(r8) aodvisvolc(pcols) ! AOD vis for CMIP6 volcanic aerosol - real(r8) absvisvolc(pcols) ! AAOD vis for CMIP6 volcanic aerosol -!akc6+ - real(r8) bevisvolc(pcols,pver) ! Extinction in vis wavelength band for CMIP6 volcanic aerosol -!akc6- - real(r8) rhum(pcols,pver) ! (trimmed) relative humidity for the aerosol calculations -!tst -! real(r8) aodvis3d(pcols,pver) ! 3D AOD in VIS -!tst - - real(r8) deltah_km(pcols,pver) ! Layer thickness, unit km - -!akc6 real(r8) deltah, airmass(pcols,pver) - real(r8) deltah, airmassl(pcols,pver), airmass(pcols) !akc6 - real(r8) Ca(pcols,pver), f_c(pcols,pver), f_bc(pcols,pver), f_aq(pcols,pver) - real(r8) fnbc(pcols,pver), faitbc(pcols,pver), f_so4_cond(pcols,pver), & - f_soa(pcols,pver),f_soana(pcols,pver), vnbc, vaitbc - real(r8) v_soana(pcols,pver), vnbcarr(pcols,pver), vaitbcarr(pcols,pver) - real(r8) dCtot(pcols,pver), Ctot(pcols,pver) - real(r8) Cam(pcols,pver,nbmodes), fbcm(pcols,pver,nbmodes), fcm(pcols,pver,nbmodes), & - faqm(pcols,pver,nbmodes), f_condm(pcols,pver,nbmodes), & - f_soam(pcols, pver,nbmodes), faqm4(pcols,pver) - real(r8) xrh(pcols,pver), xrhnull(pcols,pver) - integer irh1(pcols,pver), irh2(pcols,pver), irh1null(pcols,pver), irh2null(pcols,pver) - real(r8) focm(pcols,pver,4) -! real(r8) akso4c(pcols), akbcc(pcols), akocc(pcols) - real(r8) ssa(pcols,pver,0:nmodes,nbands), asym(pcols,pver,0:nmodes,nbands), & - be(pcols,pver,0:nmodes,nbands), ke(pcols,pver,0:nmodes,nbands), & - betotvis(pcols,pver), batotvis(pcols,pver) - real(r8) ssatot(pcols,pver,nbands) ! spectral aerosol single scattering albedo - real(r8) asymtot(pcols,pver,nbands) ! spectral aerosol asymmetry factor - real(r8) betot(pcols,pver,nbands) ! spectral aerosol extinction coefficient - real(r8) batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW - real(r8) kalw(pcols,pver,0:nmodes,nlwbands) - real(r8) balw(pcols,pver,0:nmodes,nlwbands) - logical lw_on ! LW calculations are performed in interpol* if true - real(r8) volc_balw(pcols,0:pver,nlwbands) ! volcanic aerosol absorption coefficient for terrestrial bands, CMIP6 + subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & + volc_ext_sun, volc_omega_sun, volc_g_sun, & + volc_ext_earth, volc_omega_earth, & + aodvis, absvis, dod440, dod550, dod870, abs550, abs550alt) + + ! Optical parameters for a composite aerosol is calculated by interpolation + ! from the tables kcomp1.out-kcomp14.out. + ! Optimized June 2002 byrild Burud/NoSerC + ! Optimized July 2002 by Egil Storen/NoSerC (ces) + ! Revised for inclusion of OC and modified aerosol backgeound aerosol + ! by Alf Kirkevaag in 2003, and finally rewritten for CAM3 February 2005. + ! Modified for new aerosol schemes by Alf Kirkevaag in January 2006. + ! Updated by Alf Kirkevåg, May 2013: The SO4(Ait) mode now takes into + ! account condensed SOA in addition to H2SO4. + ! Updated for CAM5-Oslo with RRTMG by Alf Kirkevåg, 2014-2015, for new + ! SOA treatment August/September 2015, and for cleanig up and optimizing + ! the code around interpolations in November 2016. + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_history, only: outfld + use constituents, only: pcnst + use physconst, only: rair,pi + use opttab, only : cate, cat + use oslo_utils, only: calculateNumberConcentration + use parmix_progncdnc, only: calculateBulkProperties, partitionMass + use opttab_lw , only : ka0, ka1, ka2to3, ka4, ka5to10 + use const + use aerosoldef + use commondefinitions , only : nmodes, nbmodes + use optinterpol, only: inputForInterpol + use optinterpol, only: interpol0,interpol1,interpol2to3,interpol4,interpol5to10 + use physics_types, only: physics_state + use wv_saturation, only: qsat_water + + implicit none + + ! + ! Arguments + ! + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + real(r8) , intent(in) :: coszrs(pcols) ! Cosine solar zenith angle + type(physics_state) , intent(in), target :: state + real(r8) , intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) + real(r8) , intent(in) :: pmid(pcols,pver) ! Model level pressures (Pa) + real(r8) , intent(in) :: t(pcols,pver) ! Model level temperatures (K) + real(r8) , intent(in) :: cld(pcols,pver) ! cloud fraction + real(r8) , intent(in) :: qm1(pcols,pver,pcnst) ! Specific humidity and tracers (kg/kg) + real(r8) , intent(in) :: volc_ext_sun(pcols,pver,nbands) ! volcanic aerosol extinction for solar bands, CMIP6 + real(r8) , intent(in) :: volc_omega_sun(pcols,pver,nbands) ! volcanic aerosol SSA for solar bands, CMIP6 + real(r8) , intent(in) :: volc_g_sun(pcols,pver,nbands) ! volcanic aerosol g for solar bands, CMIP6 + real(r8) , intent(in) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 + real(r8) , intent(in) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 + real(r8) , intent(inout) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration + real(r8) , intent(out) :: per_tau (pcols,0:pver,nbands) ! aerosol extinction optical depth + real(r8) , intent(out) :: per_tau_w (pcols,0:pver,nbands) ! aerosol single scattering albedo * tau + real(r8) , intent(out) :: per_tau_w_g(pcols,0:pver,nbands) ! aerosol assymetry parameter * w * tau + real(r8) , intent(out) :: per_tau_w_f(pcols,0:pver,nbands) ! aerosol forward scattered fraction * w * tau + real(r8) , intent(out) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optical depth (LW) + ! AOD and absorptive AOD for visible wavelength closest to 0.55 um (0.442-0.625) + ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values + real(r8) , intent(out) :: aodvis(pcols) ! AOD vis + real(r8) , intent(out) :: absvis(pcols) ! AAOD vis + + ! + ! Local variables + ! + integer :: i, k, ib, icol, mplus10 + integer :: iloop + logical :: daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. + real(r8) :: aodvisvolc(pcols) ! AOD vis for CMIP6 volcanic aerosol + real(r8) :: absvisvolc(pcols) ! AAOD vis for CMIP6 volcanic aerosol + real(r8) :: bevisvolc(pcols,pver) ! Extinction in vis wavelength band for CMIP6 volcanic aerosol + real(r8) :: rhum(pcols,pver) ! (trimmed) relative humidity for the aerosol calculations + real(r8) :: deltah_km(pcols,pver) ! Layer thickness, unit km + + real(r8) :: deltah, airmassl(pcols,pver), airmass(pcols) !akc6 + real(r8) :: Ca(pcols,pver), f_c(pcols,pver), f_bc(pcols,pver), f_aq(pcols,pver) + real(r8) :: fnbc(pcols,pver), faitbc(pcols,pver), f_so4_cond(pcols,pver) + real(r8) :: f_soa(pcols,pver),f_soana(pcols,pver), vnbc, vaitbc + real(r8) :: v_soana(pcols,pver), vnbcarr(pcols,pver), vaitbcarr(pcols,pver) + real(r8) :: dCtot(pcols,pver), Ctot(pcols,pver) + real(r8) :: Cam(pcols,pver,nbmodes), fbcm(pcols,pver,nbmodes), fcm(pcols,pver,nbmodes) + real(r8) :: faqm(pcols,pver,nbmodes), f_condm(pcols,pver,nbmodes) + real(r8) :: f_soam(pcols, pver,nbmodes), faqm4(pcols,pver) + real(r8) :: xrh(pcols,pver), xrhnull(pcols,pver) + integer :: irh1(pcols,pver), irh2(pcols,pver), irh1null(pcols,pver), irh2null(pcols,pver) + real(r8) :: focm(pcols,pver,4) + real(r8) :: ssa(pcols,pver,0:nmodes,nbands), asym(pcols,pver,0:nmodes,nbands) + real(r8) :: be(pcols,pver,0:nmodes,nbands), ke(pcols,pver,0:nmodes,nbands) + real(r8) :: betotvis(pcols,pver), batotvis(pcols,pver) + real(r8) :: ssatot(pcols,pver,nbands) ! spectral aerosol single scattering albedo + real(r8) :: asymtot(pcols,pver,nbands) ! spectral aerosol asymmetry factor + real(r8) :: betot(pcols,pver,nbands) ! spectral aerosol extinction coefficient + real(r8) :: batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW + real(r8) :: kalw(pcols,pver,0:nmodes,nlwbands) + real(r8) :: balw(pcols,pver,0:nmodes,nlwbands) + logical :: lw_on ! LW calculations are performed in interpol* if true + real(r8) :: volc_balw(pcols,0:pver,nlwbands) ! volcanic aerosol absorption coefficient for terrestrial bands, CMIP6 #ifdef COLTST4INTCONS -!-3 real(r8) bekc1(pcols,pver), bekc2(pcols,pver), bekc3(pcols,pver), bekc4(pcols,pver), & - real(r8) bekc1(pcols,pver), bekc2(pcols,pver), bekc4(pcols,pver), & - bekc5(pcols,pver), bekc6(pcols,pver), bekc7(pcols,pver), bekc8(pcols,pver), & -!-11 bekc9(pcols,pver), bekc10(pcols,pver), bekc11(pcols,pver), & - bekc9(pcols,pver), bekc10(pcols,pver), & -!-13 bekc12(pcols,pver), bekc13(pcols,pver), bekc14(pcols,pver), bekc0(pcols,pver) - bekc12(pcols,pver), bekc14(pcols,pver), bekc0(pcols,pver) - real(r8) taukc1(pcols), taukc2(pcols), taukc3(pcols), taukc4(pcols), taukc5(pcols), & - taukc6(pcols), taukc7(pcols), taukc8(pcols), taukc9(pcols), taukc10(pcols), & - taukc11(pcols), taukc12(pcols), taukc13(pcols), taukc14(pcols), taukc0(pcols) - real(r8) kekc1(pcols,pver), kekc2(pcols,pver), kekc4(pcols,pver), & - kekc5(pcols,pver), kekc6(pcols,pver), kekc7(pcols,pver), kekc8(pcols,pver), & - kekc9(pcols,pver), kekc10(pcols,pver), & - kekc12(pcols,pver), kekc14(pcols,pver), kekc0(pcols,pver) -#ifdef AEROCOM - real(r8) cmodedry(pcols,pver,0:nmodes), & - cmdry0(pcols), cmdry1(pcols), cmdry2(pcols), cmdry4(pcols), & - cmdry5(pcols), cmdry6(pcols), cmdry7(pcols), cmdry8(pcols), & - cmdry9(pcols), cmdry10(pcols), cmdry12(pcols), cmdry14(pcols) -#endif + real(r8) :: bekc1(pcols,pver), bekc2(pcols,pver), bekc4(pcols,pver), & + bekc5(pcols,pver), bekc6(pcols,pver), bekc7(pcols,pver), bekc8(pcols,pver), & + bekc9(pcols,pver), bekc10(pcols,pver), & + bekc12(pcols,pver), bekc14(pcols,pver), bekc0(pcols,pver) + real(r8) :: taukc1(pcols), taukc2(pcols), taukc3(pcols), taukc4(pcols), taukc5(pcols), & + taukc6(pcols), taukc7(pcols), taukc8(pcols), taukc9(pcols), taukc10(pcols), & + taukc11(pcols), taukc12(pcols), taukc13(pcols), taukc14(pcols), taukc0(pcols) + real(r8) :: kekc1(pcols,pver), kekc2(pcols,pver), kekc4(pcols,pver), & + kekc5(pcols,pver), kekc6(pcols,pver), kekc7(pcols,pver), kekc8(pcols,pver), & + kekc9(pcols,pver), kekc10(pcols,pver), & + kekc12(pcols,pver), kekc14(pcols,pver), kekc0(pcols,pver) + real(r8) :: cmodedry(pcols,pver,0:nmodes), & + cmdry0(pcols), cmdry1(pcols), cmdry2(pcols), cmdry4(pcols), & + cmdry5(pcols), cmdry6(pcols), cmdry7(pcols), cmdry8(pcols), & + cmdry9(pcols), cmdry10(pcols), cmdry12(pcols), cmdry14(pcols) #endif - real(r8) rh0(pcols,pver), rhoda(pcols,pver) - real(r8) ssavis(pcols,pver), asymmvis(pcols,pver), extvis(pcols,pver), dayfoc(pcols,pver) - real(r8) n_aerorig(pcols,pver), n_aer(pcols,pver) - type(physics_state), intent(in), target :: state - real(r8) :: es(pcols,pver) ! saturation vapor pressure - real(r8) :: qs(pcols,pver) ! saturation specific humidity - real(r8) :: rht(pcols,pver) ! relative humidity (fraction) (rh is already used in opptab) - real(r8) :: rh_temp(pcols,pver) ! relative humidity (fraction) for input to LUT - real(r8) xfombg(pcols,pver) - integer ifombg1(pcols,pver), ifombg2(pcols,pver) - real(r8) xct(pcols,pver,nmodes) - integer ict1(pcols,pver,nmodes) - real(r8) xfac(pcols,pver,nbmodes) - integer ifac1(pcols,pver,nbmodes) - real(r8) xfbc(pcols,pver,nbmodes) - integer ifbc1(pcols,pver,nbmodes) - real(r8) xfaq(pcols,pver,nbmodes) - integer ifaq1(pcols,pver,nbmodes) - real(r8) xfbcbg(pcols,pver) - integer ifbcbg1(pcols,pver) - real(r8) xfbcbgn(pcols,pver) - integer ifbcbgn1(pcols,pver) - -#ifdef AEROCOM - real(r8) Ctotdry(pcols,pver), Cwater(pcols,pver), mmr_aerh2o(pcols,pver), & - dod550dry(pcols), abs550dry(pcols) - real(r8) daerh2o(pcols), dload(pcols,0:nmodes), dload3d(pcols,pver,0:nmodes), & - dload_mi(pcols), dload_ss(pcols), & - dload_s4(pcols), dload_oc(pcols), dload_bc(pcols), & - dload_s4_a(pcols), dload_s4_1(pcols), dload_s4_5(pcols) - real(r8) dload_bc_0(pcols), dload_bc_ac(pcols), dload_oc_ac(pcols), & - dload_bc_2(pcols), dload_bc_4(pcols), dload_bc_12(pcols), dload_bc_14(pcols), & - dload_oc_4(pcols), dload_oc_14(pcols) - real(r8) cmin(pcols,pver), cseas(pcols,pver) - real(r8) nnat_1(pcols,pver), nnat_2(pcols,pver), nnat_3(pcols,pver), & - nnat_4(pcols,pver), nnat_5(pcols,pver), nnat_6(pcols,pver), & - nnat_7(pcols,pver), nnat_8(pcols,pver), nnat_9(pcols,pver), & - nnat_10(pcols,pver), nnat_12(pcols,pver), & - nnat_14(pcols,pver), nnat_0(pcols,pver) - real(r8) ck(pcols,pver,0:nmodes), cknorm(pcols,pver,0:nmodes), & - cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) - real(r8) aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & - vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & - aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & - vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) - real(r8) cintbg(pcols,pver,0:nbmodes), & - cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & - cintbc(pcols,pver,0:nbmodes), & - cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & - cintoc(pcols,pver,0:nbmodes), & - cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & - cintsc(pcols,pver,0:nbmodes), & - cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & - cintsa(pcols,pver,0:nbmodes), & - cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes) - real(r8) c_mi(pcols,pver), c_mi05(pcols,pver), c_mi125(pcols,pver), & - c_ss(pcols,pver), c_ss05(pcols,pver), c_ss125(pcols,pver), & - c_bc(pcols,pver), c_bc05(pcols,pver), c_bc125(pcols,pver), & - c_oc(pcols,pver), c_oc05(pcols,pver), c_oc125(pcols,pver), & - c_sa(pcols,pver), c_sa05(pcols,pver), c_sa125(pcols,pver), & - c_sc(pcols,pver), c_sc05(pcols,pver), c_sc125(pcols,pver), & - c_s4(pcols,pver), c_s405(pcols,pver), c_s4125(pcols,pver), & - c_s4_a(pcols,pver), c_s4_1(pcols,pver), c_s4_5(pcols,pver) - real(r8) c_bc_0(pcols,pver), c_bc_ac(pcols,pver), c_oc_ac(pcols,pver), & - c_bc_2(pcols,pver), c_bc_4(pcols,pver), c_bc_12(pcols,pver), c_bc_14(pcols,pver), & - c_oc_4(pcols,pver), c_oc_14(pcols,pver) - real(r8) c_tots(pcols), c_tot125s(pcols), c_pm25s(pcols) ! = PM all sizes, PM>2.5um and PM<2.5um (PM2.5) -!akc6+ - real(r8) c_tot(pcols,pver), c_tot125(pcols,pver), c_pm25(pcols,pver), & - mmr_pm25(pcols,pver), c_tot05(pcols,pver), c_pm1(pcols,pver), mmr_pm1(pcols,pver) -!akc6- - real(r8) aaeros_tot(pcols,pver), aaerol_tot(pcols,pver), vaeros_tot(pcols,pver), & - vaerol_tot(pcols,pver), aaercols(pcols), aaercoll(pcols), vaercols(pcols), & - vaercoll(pcols), derlt05(pcols), dergt05(pcols), der(pcols), & - erlt053d(pcols,pver), ergt053d(pcols,pver), er3d(pcols,pver) - real(r8) bext440(pcols,pver,0:nbmodes), babs440(pcols,pver,0:nbmodes), & - bext500(pcols,pver,0:nbmodes), babs500(pcols,pver,0:nbmodes), & - bext550(pcols,pver,0:nbmodes), babs550(pcols,pver,0:nbmodes), & - bext670(pcols,pver,0:nbmodes), babs670(pcols,pver,0:nbmodes), & - bext870(pcols,pver,0:nbmodes), babs870(pcols,pver,0:nbmodes), & - bebg440(pcols,pver,0:nbmodes), babg440(pcols,pver,0:nbmodes), & - bebg500(pcols,pver,0:nbmodes), babg500(pcols,pver,0:nbmodes), & - bebg550(pcols,pver,0:nbmodes), babg550(pcols,pver,0:nbmodes), & - bebg670(pcols,pver,0:nbmodes), babg670(pcols,pver,0:nbmodes), & - bebg870(pcols,pver,0:nbmodes), babg870(pcols,pver,0:nbmodes), & - bebc440(pcols,pver,0:nbmodes), babc440(pcols,pver,0:nbmodes), & - bebc500(pcols,pver,0:nbmodes), babc500(pcols,pver,0:nbmodes), & - bebc550(pcols,pver,0:nbmodes), babc550(pcols,pver,0:nbmodes), & - bebc670(pcols,pver,0:nbmodes), babc670(pcols,pver,0:nbmodes), & - bebc870(pcols,pver,0:nbmodes), babc870(pcols,pver,0:nbmodes), & - beoc440(pcols,pver,0:nbmodes), baoc440(pcols,pver,0:nbmodes), & - beoc500(pcols,pver,0:nbmodes), baoc500(pcols,pver,0:nbmodes), & - beoc550(pcols,pver,0:nbmodes), baoc550(pcols,pver,0:nbmodes), & - beoc670(pcols,pver,0:nbmodes), baoc670(pcols,pver,0:nbmodes), & - beoc870(pcols,pver,0:nbmodes), baoc870(pcols,pver,0:nbmodes), & - besu440(pcols,pver,0:nbmodes), basu440(pcols,pver,0:nbmodes), & - besu500(pcols,pver,0:nbmodes), basu500(pcols,pver,0:nbmodes), & - besu550(pcols,pver,0:nbmodes), basu550(pcols,pver,0:nbmodes), & - besu670(pcols,pver,0:nbmodes), basu670(pcols,pver,0:nbmodes), & - besu870(pcols,pver,0:nbmodes), basu870(pcols,pver,0:nbmodes) - real(r8) bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & - bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & - beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & - bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes), backsc550x(pcols,pver,nbmp1:nmodes), & - backsc550tot(pcols,pver), ec550_aer(pcols,pver), abs550_aer(pcols,pver), & - bs550_aer(pcols,pver) -! Additional AeroCom Phase III output: - real(r8) asydry_aer(pcols,pver) ! dry asymtot in the visible band -! - real(r8) ec550_so4(pcols,pver),ec550_bc(pcols,pver), ec550_pom(pcols,pver), & - ec550_ss(pcols,pver), ec550_du(pcols,pver) - real(r8) bext440n(pcols,pver,0:nbmodes), babs440n(pcols,pver,0:nbmodes), & - bext500n(pcols,pver,0:nbmodes), babs500n(pcols,pver,0:nbmodes), & - bext550n(pcols,pver,0:nbmodes), babs550n(pcols,pver,0:nbmodes), & - bext670n(pcols,pver,0:nbmodes), babs670n(pcols,pver,0:nbmodes), & - bext870n(pcols,pver,0:nbmodes), babs870n(pcols,pver,0:nbmodes), & - bebg440n(pcols,pver,0:nbmodes), babg440n(pcols,pver,0:nbmodes), & - bebg500n(pcols,pver,0:nbmodes), babg500n(pcols,pver,0:nbmodes), & - bebg550n(pcols,pver,0:nbmodes), babg550n(pcols,pver,0:nbmodes), & - bebg670n(pcols,pver,0:nbmodes), babg670n(pcols,pver,0:nbmodes), & - bebg870n(pcols,pver,0:nbmodes), babg870n(pcols,pver,0:nbmodes), & - bebc440n(pcols,pver,0:nbmodes), babc440n(pcols,pver,0:nbmodes), & - bebc500n(pcols,pver,0:nbmodes), babc500n(pcols,pver,0:nbmodes), & - bebc550n(pcols,pver,0:nbmodes), babc550n(pcols,pver,0:nbmodes), & - bebc670n(pcols,pver,0:nbmodes), babc670n(pcols,pver,0:nbmodes), & - bebc870n(pcols,pver,0:nbmodes), babc870n(pcols,pver,0:nbmodes), & - beoc440n(pcols,pver,0:nbmodes), baoc440n(pcols,pver,0:nbmodes), & - beoc500n(pcols,pver,0:nbmodes), baoc500n(pcols,pver,0:nbmodes), & - beoc550n(pcols,pver,0:nbmodes), baoc550n(pcols,pver,0:nbmodes), & - beoc670n(pcols,pver,0:nbmodes), baoc670n(pcols,pver,0:nbmodes), & - beoc870n(pcols,pver,0:nbmodes), baoc870n(pcols,pver,0:nbmodes), & - besu440n(pcols,pver,0:nbmodes), basu440n(pcols,pver,0:nbmodes), & - besu500n(pcols,pver,0:nbmodes), basu500n(pcols,pver,0:nbmodes), & - besu550n(pcols,pver,0:nbmodes), basu550n(pcols,pver,0:nbmodes), & - besu670n(pcols,pver,0:nbmodes), basu670n(pcols,pver,0:nbmodes), & - besu870n(pcols,pver,0:nbmodes), basu870n(pcols,pver,0:nbmodes) - real(r8) bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & - bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & - beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & - bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & - backsc550n(pcols,pver,0:nbmodes) - real(r8) bext440tot(pcols,pver), babs440tot(pcols,pver), & - bext500tot(pcols,pver), babs500tot(pcols,pver), & - bext550tot(pcols,pver), babs550tot(pcols,pver), & - bext670tot(pcols,pver), babs670tot(pcols,pver), & - bext870tot(pcols,pver), babs870tot(pcols,pver), & - bebg440tot(pcols,pver), babg440tot(pcols,pver), & - bebg500tot(pcols,pver), babg500tot(pcols,pver), & - bebg550tot(pcols,pver), babg550tot(pcols,pver), & - bebg670tot(pcols,pver), babg670tot(pcols,pver), & - bebg870tot(pcols,pver), babg870tot(pcols,pver), & - bebc440tot(pcols,pver), babc440tot(pcols,pver), & - bebc500tot(pcols,pver), babc500tot(pcols,pver), & - bebc550tot(pcols,pver), babc550tot(pcols,pver), & - bebc670tot(pcols,pver), babc670tot(pcols,pver), & - bebc870tot(pcols,pver), babc870tot(pcols,pver), & - beoc440tot(pcols,pver), baoc440tot(pcols,pver), & - beoc500tot(pcols,pver), baoc500tot(pcols,pver), & - beoc550tot(pcols,pver), baoc550tot(pcols,pver), & - beoc670tot(pcols,pver), baoc670tot(pcols,pver), & - beoc870tot(pcols,pver), baoc870tot(pcols,pver), & - besu440tot(pcols,pver), basu440tot(pcols,pver), & - besu500tot(pcols,pver), basu500tot(pcols,pver), & - besu550tot(pcols,pver), basu550tot(pcols,pver), & - besu670tot(pcols,pver), basu670tot(pcols,pver), & - besu870tot(pcols,pver), basu870tot(pcols,pver) - real(r8) bebglt1t(pcols,pver), bebggt1t(pcols,pver), bebclt1t(pcols,pver), & - bebcgt1t(pcols,pver), beoclt1t(pcols,pver), beocgt1t(pcols,pver), & - bes4lt1t(pcols,pver), bes4gt1t(pcols,pver) - real(r8) be440x(pcols,pver,nbmp1:nmodes), ba440x(pcols,pver,nbmp1:nmodes), & - be500x(pcols,pver,nbmp1:nmodes), ba500x(pcols,pver,nbmp1:nmodes), & - be550x(pcols,pver,nbmp1:nmodes), ba550x(pcols,pver,nbmp1:nmodes), & - be670x(pcols,pver,nbmp1:nmodes), ba670x(pcols,pver,nbmp1:nmodes), & - be870x(pcols,pver,nbmp1:nmodes), ba870x(pcols,pver,nbmp1:nmodes), & - belt1x(pcols,pver,nbmp1:nmodes), begt1x(pcols,pver,nbmp1:nmodes) - real(r8) bebc440xt(pcols,pver),babc440xt(pcols,pver), & - bebc500xt(pcols,pver),babc500xt(pcols,pver), & - bebc550xt(pcols,pver),babc550xt(pcols,pver), & - bebc670xt(pcols,pver),babc670xt(pcols,pver), & - bebc870xt(pcols,pver),babc870xt(pcols,pver), & - beoc440xt(pcols,pver),baoc440xt(pcols,pver), & - beoc500xt(pcols,pver),baoc500xt(pcols,pver), & - beoc550xt(pcols,pver),baoc550xt(pcols,pver), & - beoc670xt(pcols,pver),baoc670xt(pcols,pver), & - beoc870xt(pcols,pver),baoc870xt(pcols,pver) - real(r8) bbclt1xt(pcols,pver), & - bbcgt1xt(pcols,pver), boclt1xt(pcols,pver), bocgt1xt(pcols,pver) - real(r8) bint440du(pcols,pver), bint500du(pcols,pver), bint550du(pcols,pver), & - bint670du(pcols,pver), bint870du(pcols,pver), & - bint440ss(pcols,pver), bint500ss(pcols,pver), bint550ss(pcols,pver), & - bint670ss(pcols,pver), bint870ss(pcols,pver), & - baint550du(pcols,pver), baint550ss(pcols,pver) - real(r8) bedustlt1(pcols,pver), bedustgt1(pcols,pver), & - besslt1(pcols,pver), bessgt1(pcols,pver) - real(r8) dod4403d(pcols,pver), abs4403d(pcols,pver), & - dod4403d_ss(pcols,pver), & ! abs4403d_ss(pcols,pver), & - dod4403d_dust(pcols,pver), & ! abs4403d_dust(pcols,pver), & - dod4403d_so4(pcols,pver), & ! abs4403d_so4(pcols,pver), & - dod4403d_bc(pcols,pver), & ! abs4403d_bc(pcols,pver), & - dod4403d_pom(pcols,pver), & ! abs4403d_pom(pcols,pver), & - dod5003d(pcols,pver), abs5003d(pcols,pver), & - dod5003d_ss(pcols,pver), & ! abs5003d_ss(pcols,pver), & - dod5003d_dust(pcols,pver), & ! abs5003d_dust(pcols,pver), & - dod5003d_so4(pcols,pver), & ! abs5003d_so4(pcols,pver), & - dod5003d_bc(pcols,pver), & ! abs5003d_bc(pcols,pver), & - dod5003d_pom(pcols,pver), & ! abs5003d_pom(pcols,pver), & - dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver), & - dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver), & - dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver), & - dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver), & - dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver), & - dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver), & - dod6703d(pcols,pver), abs6703d(pcols,pver), & - dod6703d_ss(pcols,pver), & ! abs6703d_ss(pcols,pver), & - dod6703d_dust(pcols,pver), & ! abs6703d_dust(pcols,pver), & - dod6703d_so4(pcols,pver), & ! abs6703d_so4(pcols,pver), & - dod6703d_bc(pcols,pver), & ! abs6703d_bc(pcols,pver), & - dod6703d_pom(pcols,pver), & ! abs6703d_pom(pcols,pver), & - dod8703d(pcols,pver), abs8703d(pcols,pver), & - dod8703d_ss(pcols,pver), & ! abs8703d_ss(pcols,pver), & - dod8703d_dust(pcols,pver), & ! abs8703d_dust(pcols,pver), & - dod8703d_so4(pcols,pver), & ! abs8703d_so4(pcols,pver), & - dod8703d_bc(pcols,pver), & ! abs8703d_bc(pcols,pver), & - dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) - real(r8) dod5503dlt1_ss(pcols,pver), dod5503dgt1_ss(pcols,pver), & - dod5503dlt1_dust(pcols,pver), dod5503dgt1_dust(pcols,pver), & - dod5503dlt1_so4(pcols,pver), dod5503dgt1_so4(pcols,pver), & - dod5503dlt1_bc(pcols,pver), dod5503dgt1_bc(pcols,pver), & - dod5503dlt1_pom(pcols,pver), dod5503dgt1_pom(pcols,pver) - real(r8) dod440(pcols), abs440(pcols), dod500(pcols), abs500(pcols), & - dod550(pcols), abs550(pcols), abs550alt(pcols), dod670(pcols),& - abs670(pcols), dod870(pcols), abs870(pcols), & - dod440_ss(pcols), dod440_dust(pcols), dod440_so4(pcols), & - dod440_bc(pcols), dod440_pom(pcols), & - dod500_ss(pcols), dod500_dust(pcols), dod500_so4(pcols), & - dod500_bc(pcols), dod500_pom(pcols), & - dod550_ss(pcols), dod550_dust(pcols), dod550_so4(pcols), & - dod550_bc(pcols), dod550_pom(pcols), & - dod670_ss(pcols), dod670_dust(pcols), dod670_so4(pcols), & - dod670_bc(pcols), dod670_pom(pcols), & - dod870_ss(pcols), dod870_dust(pcols), dod870_so4(pcols), & - dod870_bc(pcols), dod870_pom(pcols), & - dod550lt1_ss(pcols), dod550gt1_ss(pcols), dod550lt1_dust(pcols), & - dod550gt1_dust(pcols), dod550lt1_so4(pcols), & - dod550gt1_so4(pcols), dod550lt1_bc(pcols), dod550gt1_bc(pcols), & - dod550lt1_pom(pcols), dod550gt1_pom(pcols) - real(r8) abs550_ss(pcols), abs550_dust(pcols), & - abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) - real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) -#endif ! AEROCOM -!+ -#ifdef AEROCOM - character(len=10) :: modeString - character(len=20) :: varname - integer irf,irfmax - real(r8) Camrel(pcols,pver,nbmodes) - real(r8) Camtot(pcols,nbmodes) - real(r8) cxsmtot(pcols,nbmodes) - real(r8) cxsmrel(pcols,nbmodes) - real(r8) xctrel,camdiff,cxsm - real(r8) cxs(pcols,pver), cxstot(pcols,pver), akcxs(pcols) -#endif -!- - -! -!------------------------------------------------------------------------- -! - -!test: hentet fra aer_rad_props, saa modifisert/rettet (!x) - ! calculate relative humidity for table lookup into rh grid -!x call qsat(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & - call qsat_water(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & - es(1:ncol,1:pver), qs(1:ncol,1:pver)) - rht(1:ncol,1:pver) = state%q(1:ncol,1:pver,1) / qs(1:ncol,1:pver) - rh_temp(1:ncol,1:pver) = min(rht(1:ncol,1:pver),1._r8) - - - do k=1,pver - do icol=1,ncol -! Set upper and lower relative humidity for the aerosol calculations + real(r8) :: rh0(pcols,pver), rhoda(pcols,pver) + real(r8) :: ssavis(pcols,pver), asymmvis(pcols,pver), extvis(pcols,pver), dayfoc(pcols,pver) + real(r8) :: n_aerorig(pcols,pver), n_aer(pcols,pver) + real(r8) :: es(pcols,pver) ! saturation vapor pressure + real(r8) :: qs(pcols,pver) ! saturation specific humidity + real(r8) :: rht(pcols,pver) ! relative humidity (fraction) (rh is already used in opptab) + real(r8) :: rh_temp(pcols,pver) ! relative humidity (fraction) for input to LUT + real(r8) :: xfombg(pcols,pver) + integer :: ifombg1(pcols,pver), ifombg2(pcols,pver) + real(r8) :: xct(pcols,pver,nmodes) + integer :: ict1(pcols,pver,nmodes) + real(r8) :: xfac(pcols,pver,nbmodes) + integer :: ifac1(pcols,pver,nbmodes) + real(r8) :: xfbc(pcols,pver,nbmodes) + integer :: ifbc1(pcols,pver,nbmodes) + real(r8) :: xfaq(pcols,pver,nbmodes) + integer :: ifaq1(pcols,pver,nbmodes) + real(r8) :: xfbcbg(pcols,pver) + integer :: ifbcbg1(pcols,pver) + real(r8) :: xfbcbgn(pcols,pver) + integer :: ifbcbgn1(pcols,pver) + + real(r8) :: Ctotdry(pcols,pver), Cwater(pcols,pver), mmr_aerh2o(pcols,pver), & + dod550dry(pcols), abs550dry(pcols) + real(r8) :: daerh2o(pcols), dload(pcols,0:nmodes), dload3d(pcols,pver,0:nmodes), & + dload_mi(pcols), dload_ss(pcols), & + dload_s4(pcols), dload_oc(pcols), dload_bc(pcols), & + dload_s4_a(pcols), dload_s4_1(pcols), dload_s4_5(pcols) + real(r8) :: dload_bc_0(pcols), dload_bc_ac(pcols), dload_oc_ac(pcols), & + dload_bc_2(pcols), dload_bc_4(pcols), dload_bc_12(pcols), dload_bc_14(pcols), & + dload_oc_4(pcols), dload_oc_14(pcols) + real(r8) :: cmin(pcols,pver), cseas(pcols,pver) + real(r8) :: nnat_1(pcols,pver), nnat_2(pcols,pver), nnat_3(pcols,pver), & + nnat_4(pcols,pver), nnat_5(pcols,pver), nnat_6(pcols,pver), & + nnat_7(pcols,pver), nnat_8(pcols,pver), nnat_9(pcols,pver), & + nnat_10(pcols,pver), nnat_12(pcols,pver), & + nnat_14(pcols,pver), nnat_0(pcols,pver) + real(r8) :: ck(pcols,pver,0:nmodes) + + real(r8) :: c_mi(pcols,pver), c_mi05(pcols,pver), c_mi125(pcols,pver), & + c_ss(pcols,pver), c_ss05(pcols,pver), c_ss125(pcols,pver), & + c_bc(pcols,pver), c_bc05(pcols,pver), c_bc125(pcols,pver), & + c_oc(pcols,pver), c_oc05(pcols,pver), c_oc125(pcols,pver), & + c_sa(pcols,pver), c_sa05(pcols,pver), c_sa125(pcols,pver), & + c_sc(pcols,pver), c_sc05(pcols,pver), c_sc125(pcols,pver), & + c_s4(pcols,pver), c_s405(pcols,pver), c_s4125(pcols,pver), & + c_s4_a(pcols,pver), c_s4_1(pcols,pver), c_s4_5(pcols,pver) + + real(r8) :: c_bc_0(pcols,pver), c_bc_ac(pcols,pver), c_oc_ac(pcols,pver), & + c_bc_2(pcols,pver), c_bc_4(pcols,pver), c_bc_12(pcols,pver), c_bc_14(pcols,pver), & + c_oc_4(pcols,pver), c_oc_14(pcols,pver) + + real(r8) :: c_tots(pcols), c_tot125s(pcols), c_pm25s(pcols) ! = PM all sizes, PM>2.5um and PM<2.5um (PM2.5) + + real(r8) :: c_tot(pcols,pver), c_tot125(pcols,pver), c_pm25(pcols,pver), & + mmr_pm25(pcols,pver), c_tot05(pcols,pver), c_pm1(pcols,pver), mmr_pm1(pcols,pver) + + real(r8) :: aaeros_tot(pcols,pver), aaerol_tot(pcols,pver), vaeros_tot(pcols,pver), & + vaerol_tot(pcols,pver), aaercols(pcols), aaercoll(pcols), vaercols(pcols), & + vaercoll(pcols), derlt05(pcols), dergt05(pcols), der(pcols), & + erlt053d(pcols,pver), ergt053d(pcols,pver), er3d(pcols,pver) + real(r8) :: bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & + bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & + beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & + bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes), backsc550x(pcols,pver,nbmp1:nmodes), & + backsc550tot(pcols,pver), ec550_aer(pcols,pver), abs550_aer(pcols,pver), & + bs550_aer(pcols,pver) + real(r8) :: bext440tot(pcols,pver), babs440tot(pcols,pver), & + bext500tot(pcols,pver), babs500tot(pcols,pver), & + bext550tot(pcols,pver), babs550tot(pcols,pver), & + bext670tot(pcols,pver), babs670tot(pcols,pver), & + bext870tot(pcols,pver), babs870tot(pcols,pver), & + bebg440tot(pcols,pver), babg440tot(pcols,pver), & + bebg500tot(pcols,pver), babg500tot(pcols,pver), & + bebg550tot(pcols,pver), babg550tot(pcols,pver), & + bebg670tot(pcols,pver), babg670tot(pcols,pver), & + bebg870tot(pcols,pver), babg870tot(pcols,pver), & + bebc440tot(pcols,pver), babc440tot(pcols,pver), & + bebc500tot(pcols,pver), babc500tot(pcols,pver), & + bebc550tot(pcols,pver), babc550tot(pcols,pver), & + bebc670tot(pcols,pver), babc670tot(pcols,pver), & + bebc870tot(pcols,pver), babc870tot(pcols,pver), & + beoc440tot(pcols,pver), baoc440tot(pcols,pver), & + beoc500tot(pcols,pver), baoc500tot(pcols,pver), & + beoc550tot(pcols,pver), baoc550tot(pcols,pver), & + beoc670tot(pcols,pver), baoc670tot(pcols,pver), & + beoc870tot(pcols,pver), baoc870tot(pcols,pver), & + besu440tot(pcols,pver), basu440tot(pcols,pver), & + besu500tot(pcols,pver), basu500tot(pcols,pver), & + besu550tot(pcols,pver), basu550tot(pcols,pver), & + besu670tot(pcols,pver), basu670tot(pcols,pver), & + besu870tot(pcols,pver), basu870tot(pcols,pver) + ! Additional AeroCom Phase III output: + real(r8) :: asydry_aer(pcols,pver) ! dry asymtot in the visible band + ! + real(r8) :: ec550_so4(pcols,pver),ec550_bc(pcols,pver), ec550_pom(pcols,pver), & + ec550_ss(pcols,pver), ec550_du(pcols,pver) + real(r8) :: bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & + bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & + beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & + bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & + backsc550n(pcols,pver,0:nbmodes) + real(r8) :: bebglt1t(pcols,pver), bebggt1t(pcols,pver), bebclt1t(pcols,pver), & + bebcgt1t(pcols,pver), beoclt1t(pcols,pver), beocgt1t(pcols,pver), & + bes4lt1t(pcols,pver), bes4gt1t(pcols,pver) + real(r8) :: be440x(pcols,pver,nbmp1:nmodes), ba440x(pcols,pver,nbmp1:nmodes), & + be500x(pcols,pver,nbmp1:nmodes), ba500x(pcols,pver,nbmp1:nmodes), & + be550x(pcols,pver,nbmp1:nmodes), ba550x(pcols,pver,nbmp1:nmodes), & + be670x(pcols,pver,nbmp1:nmodes), ba670x(pcols,pver,nbmp1:nmodes), & + be870x(pcols,pver,nbmp1:nmodes), ba870x(pcols,pver,nbmp1:nmodes), & + belt1x(pcols,pver,nbmp1:nmodes), begt1x(pcols,pver,nbmp1:nmodes) + real(r8) :: bebc440xt(pcols,pver),babc440xt(pcols,pver), & + bebc500xt(pcols,pver),babc500xt(pcols,pver), & + bebc550xt(pcols,pver),babc550xt(pcols,pver), & + bebc670xt(pcols,pver),babc670xt(pcols,pver), & + bebc870xt(pcols,pver),babc870xt(pcols,pver), & + beoc440xt(pcols,pver),baoc440xt(pcols,pver), & + beoc500xt(pcols,pver),baoc500xt(pcols,pver), & + beoc550xt(pcols,pver),baoc550xt(pcols,pver), & + beoc670xt(pcols,pver),baoc670xt(pcols,pver), & + beoc870xt(pcols,pver),baoc870xt(pcols,pver) + real(r8) :: bbclt1xt(pcols,pver), & + bbcgt1xt(pcols,pver), boclt1xt(pcols,pver), bocgt1xt(pcols,pver) + real(r8) :: bint440du(pcols,pver), bint500du(pcols,pver), bint550du(pcols,pver), & + bint670du(pcols,pver), bint870du(pcols,pver), & + bint440ss(pcols,pver), bint500ss(pcols,pver), bint550ss(pcols,pver), & + bint670ss(pcols,pver), bint870ss(pcols,pver), & + baint550du(pcols,pver), baint550ss(pcols,pver) + real(r8) :: bedustlt1(pcols,pver), bedustgt1(pcols,pver) + real(r8) :: besslt1(pcols,pver), bessgt1(pcols,pver) + + real(r8) :: dod4403d(pcols,pver), abs4403d(pcols,pver) + real(r8) :: dod4403d_ss(pcols,pver) + real(r8) :: dod4403d_dust(pcols,pver) + real(r8) :: dod4403d_so4(pcols,pver) + real(r8) :: dod4403d_bc(pcols,pver) + real(r8) :: dod4403d_pom(pcols,pver) + + real(r8) :: dod5003d(pcols,pver), abs5003d(pcols,pver) + real(r8) :: dod5003d_ss(pcols,pver) + real(r8) :: dod5003d_dust(pcols,pver) + real(r8) :: dod5003d_so4(pcols,pver) + real(r8) :: dod5003d_bc(pcols,pver) + real(r8) :: dod5003d_pom(pcols,pver) + real(r8) :: dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver) + real(r8) :: dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver) + real(r8) :: dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver) + real(r8) :: dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver) + real(r8) :: dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver) + real(r8) :: dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver) + real(r8) :: dod6703d(pcols,pver), abs6703d(pcols,pver) + real(r8) :: dod6703d_ss(pcols,pver) + real(r8) :: dod6703d_dust(pcols,pver) + real(r8) :: dod6703d_so4(pcols,pver) + real(r8) :: dod6703d_bc(pcols,pver) + real(r8) :: dod6703d_pom(pcols,pver) + real(r8) :: dod8703d(pcols,pver), abs8703d(pcols,pver) + real(r8) :: dod8703d_ss(pcols,pver) + real(r8) :: dod8703d_dust(pcols,pver) + real(r8) :: dod8703d_so4(pcols,pver) + real(r8) :: dod8703d_bc(pcols,pver) + real(r8) :: dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) + real(r8) :: dod5503dlt1_ss(pcols,pver), dod5503dgt1_ss(pcols,pver) + real(r8) :: dod5503dlt1_dust(pcols,pver), dod5503dgt1_dust(pcols,pver) + real(r8) :: dod5503dlt1_so4(pcols,pver), dod5503dgt1_so4(pcols,pver) + real(r8) :: dod5503dlt1_bc(pcols,pver), dod5503dgt1_bc(pcols,pver) + real(r8) :: dod5503dlt1_pom(pcols,pver), dod5503dgt1_pom(pcols,pver) + real(r8) :: dod440(pcols), abs440(pcols), dod500(pcols), abs500(pcols) + real(r8) :: dod550(pcols), abs550(pcols), abs550alt(pcols), dod670(pcols) + real(r8) :: abs670(pcols), dod870(pcols), abs870(pcols) + real(r8) :: dod440_ss(pcols), dod440_dust(pcols), dod440_so4(pcols) + real(r8) :: dod440_bc(pcols), dod440_pom(pcols) + real(r8) :: dod500_ss(pcols), dod500_dust(pcols), dod500_so4(pcols) + real(r8) :: dod500_bc(pcols), dod500_pom(pcols) + real(r8) :: dod550_ss(pcols), dod550_dust(pcols), dod550_so4(pcols) + real(r8) :: dod550_bc(pcols), dod550_pom(pcols) + real(r8) :: dod670_ss(pcols), dod670_dust(pcols), dod670_so4(pcols) + real(r8) :: dod670_bc(pcols), dod670_pom(pcols) + real(r8) :: dod870_ss(pcols), dod870_dust(pcols), dod870_so4(pcols) + real(r8) :: dod870_bc(pcols), dod870_pom(pcols) + real(r8) :: dod550lt1_ss(pcols), dod550gt1_ss(pcols), dod550lt1_dust(pcols) + real(r8) :: dod550gt1_dust(pcols), dod550lt1_so4(pcols) + real(r8) :: dod550gt1_so4(pcols), dod550lt1_bc(pcols), dod550gt1_bc(pcols) + real(r8) :: dod550lt1_pom(pcols), dod550gt1_pom(pcols) + real(r8) :: abs550_ss(pcols), abs550_dust(pcols) + real(r8) :: abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) + real(r8) :: batotsw13(pcols,pver), batotlw01(pcols,pver) + + character(len=10) :: modeString + character(len=20) :: varname + integer :: irf,irfmax + real(r8) :: Camrel(pcols,pver,nbmodes) + real(r8) :: Camtot(pcols,nbmodes) + real(r8) :: cxsmtot(pcols,nbmodes) + real(r8) :: cxsmrel(pcols,nbmodes) + real(r8) :: xctrel,camdiff,cxsm + real(r8) :: cxs(pcols,pver), cxstot(pcols,pver), akcxs(pcols) + !------------------------------------------------------------------------- + ! + + !test: hentet fra aer_rad_props, saa modifisert/rettet (!x) + ! calculate relative humidity for table lookup into rh grid + !x call qsat(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver) + call qsat_water(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & + es(1:ncol,1:pver), qs(1:ncol,1:pver)) + rht(1:ncol,1:pver) = state%q(1:ncol,1:pver,1) / qs(1:ncol,1:pver) + rh_temp(1:ncol,1:pver) = min(rht(1:ncol,1:pver),1._r8) + + + do k=1,pver + do icol=1,ncol + ! Set upper and lower relative humidity for the aerosol calculations rhum(icol,k) = min(0.995_r8, max(rh_temp(icol,k), 0.01_r8)) rhoda(icol,k) = pmid(icol,k)/(rair*t(icol,k)) ! unit kg/m^3 -!test rhum(icol,k) = 0.01_r8 + !test rhum(icol,k) = 0.01_r8 if (cld(icol,k) .lt. 1.0_r8) then rhum(icol,k) = (rhum(icol,k) - cld(icol,k)) / (1.0_r8 - cld(icol,k)) ! clear portion end if rhum(icol,k) = min(0.995_r8, max(rhum(icol,k), 0.01_r8)) - end do - end do + end do + end do -! Layer thickness with unit km - do icol=1,ncol - do k=1,pver + ! Layer thickness with unit km + do icol=1,ncol + do k=1,pver deltah_km(icol,k)=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) - end do - end do - -! interpol-calculations only when daylight or not: -#ifdef AEROCOM ! always calculate optics (also at (polar) night) - do icol=1,ncol - daylight(icol) = .true. - end do -#else ! calculate optics only in daytime - do icol=1,ncol - if (coszrs(icol) > 0.0_r8) then - daylight(icol) = .true. - else - daylight(icol) = .false. - endif - end do -#endif ! AEROCOM - -! Set SO4, BC and OC concentrations: - -! initialize concentration fields - do i=0,nmodes - do k=1,pver + end do + end do + + ! interpol-calculations only when daylight or not: + do icol=1,ncol + daylight(icol) = .true. + end do + + ! Set SO4, BC and OC concentrations: + + ! initialize concentration fields + do i=0,nmodes + do k=1,pver do icol=1,ncol - Nnatk(icol,k,i) = 0.0_r8 + Nnatk(icol,k,i) = 0.0_r8 end do - end do - end do - do k=1,pver - do icol=1,ncol + end do + end do + do k=1,pver + do icol=1,ncol n_aerorig(icol,k) = 0.0_r8 n_aer(icol,k) = 0.0_r8 - end do - end do - kalw(:,:,:,:)=0._r8 - be(:,:,:,:)=0._r8 - ke(:,:,:,:)=0._r8 - asym(:,:,:,:)=0._r8 - ssa(:,:,:,:)=0._r8 -! Find process tagged bulk aerosol properies (from the life cycle module): - - call calculateBulkProperties(ncol, qm1, rhoda, Nnatk, Ca, f_c, f_bc, & - f_aq, f_so4_cond, f_soa, faitbc, fnbc, f_soana) - -! calculating vulume fractions from mass fractions: - do k=1,pver - do icol=1,ncol + end do + end do + kalw(:,:,:,:)=0._r8 + be(:,:,:,:)=0._r8 + ke(:,:,:,:)=0._r8 + asym(:,:,:,:)=0._r8 + ssa(:,:,:,:)=0._r8 + ! Find process tagged bulk aerosol properies (from the life cycle module): + + call calculateBulkProperties(ncol, qm1, rhoda, Nnatk, Ca, f_c, f_bc, & + f_aq, f_so4_cond, f_soa, faitbc, fnbc, f_soana) + + ! calculating vulume fractions from mass fractions: + do k=1,pver + do icol=1,ncol v_soana(icol,k) = f_soana(icol,k)/(f_soana(icol,k) & - +(1.0_r8-f_soana(icol,k))*rhopart(l_soa_na)/rhopart(l_so4_na)) - end do - end do + +(1.0_r8-f_soana(icol,k))*rhopart(l_soa_na)/rhopart(l_so4_na)) + end do + end do -! Avoid very small numbers - do k=1,pver - do icol=1,ncol + ! Avoid very small numbers + do k=1,pver + do icol=1,ncol Ca(icol,k) = max(eps,Ca(icol,k)) f_c(icol,k) = max(eps,f_c(icol,k)) f_bc(icol,k) = max(eps,f_bc(icol,k)) f_aq(icol,k) = max(eps,f_aq(icol,k)) fnbc(icol,k) = max(eps,fnbc(icol,k)) faitbc(icol,k) = max(eps,faitbc(icol,k)) - end do end do + end do -! Calculation of the apportionment of internally mixed SO4, BC and OC -! mass between the various background modes. + ! Calculation of the apportionment of internally mixed SO4, BC and OC + ! mass between the various background modes. - !==> calls modalapp to partition the mass - call partitionMass(ncol, nnatk, Ca, f_c, f_bc, f_aq, f_so4_cond, f_soa , & - cam, fcm, fbcm, faqm, f_condm, f_soam ) + !==> calls modalapp to partition the mass + call partitionMass(ncol, nnatk, Ca, f_c, f_bc, f_aq, f_so4_cond, f_soa , & + cam, fcm, fbcm, faqm, f_condm, f_soam ) - !The following uses non-standard units, #/cm3 and ug/m3 - Nnatk(:ncol,:,:) = Nnatk(:ncol,:,:)*1.e-6_r8 - cam(:ncol,:,:)=cam(:ncol,:,:)*1.e9_r8 + !The following uses non-standard units, #/cm3 and ug/m3 + Nnatk(:ncol,:,:) = Nnatk(:ncol,:,:)*1.e-6_r8 + cam(:ncol,:,:)=cam(:ncol,:,:)*1.e9_r8 -! Calculate fraction of added mass which is either SOA condensate or OC coagulate, -! which in AeroTab are both treated as condensate for kcomp=1-4. - do i=1,4 - do k=1,pver + ! Calculate fraction of added mass which is either SOA condensate or OC coagulate, + ! which in AeroTab are both treated as condensate for kcomp=1-4. + do i=1,4 + do k=1,pver do icol=1,ncol - focm(icol,k,i) = fcm(icol,k,i)*(1.0_r8-fbcm(icol,k,i)) + focm(icol,k,i) = fcm(icol,k,i)*(1.0_r8-fbcm(icol,k,i)) enddo - enddo - enddo - do k=1,pver - do icol=1,ncol + enddo + enddo + do k=1,pver + do icol=1,ncol faqm4(icol,k) = faqm(icol,k,4) - end do - enddo - -! find common input parameters for use in the interpolation routines + end do + enddo - call inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & + ! find common input parameters for use in the interpolation routines + call inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & f_soana, xfombg, ifombg1, faitbc, xfbcbg, ifbcbg1, & fnbc, xfbcbgn, ifbcbgn1, Nnatk, Cam, xct, ict1, & focm, fcm, xfac, ifac1, fbcm, xfbc, ifbc1, faqm, xfaq, ifaq1) -! and define the respective RH input variables for dry aerosols - do k=1,pver - do icol=1,ncol + ! and define the respective RH input variables for dry aerosols + do k=1,pver + do icol=1,ncol xrhnull(icol,k)=rh(1) irh1null(icol,k)=1 - end do - enddo - - -#ifdef AEROCOM + end do + enddo -! Initialize overshooting mass summed over all modes - do k=1,pver - do icol=1,ncol + ! Initialize overshooting mass summed over all modes + do k=1,pver + do icol=1,ncol cxstot(icol,k)=0.0_r8 - enddo - enddo - do icol=1,ncol - akcxs(icol)=0.0_r8 - enddo - -! Initializing total and relative exessive (overshooting w.r.t. -! look-up table maxima) added mass column: - do i=1,nbmodes - do icol=1,ncol - Camtot(icol,i)=0.0_r8 - cxsmtot(icol,i)=0.0_r8 - cxsmrel(icol,i)=0.0_r8 - enddo - enddo -! Calculating added internally mixed mass onto each mode 1-10, relative to -! maximum mass which can be added w.r.t. the look-up tables (for level k), -! as well as the relative exessive added mass column: - do i=1,4 + enddo + enddo + do icol=1,ncol + akcxs(icol)=0.0_r8 + enddo + + ! Initializing total and relative exessive (overshooting w.r.t. + ! look-up table maxima) added mass column: + do i=1,nbmodes + do icol=1,ncol + Camtot(icol,i)=0.0_r8 + cxsmtot(icol,i)=0.0_r8 + cxsmrel(icol,i)=0.0_r8 + enddo + enddo + ! Calculating added internally mixed mass onto each mode 1-10, relative to + ! maximum mass which can be added w.r.t. the look-up tables (for level k), + ! as well as the relative exessive added mass column: + do i=1,4 do k=1,pver - do icol=1,ncol - Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cate(i,16) - xctrel=min(max(Camrel(icol,k,i),cate(i,1)/cate(i,16)),1.0_r8) - camdiff=Cam(icol,k,i)-xctrel*cate(i,16)*(Nnatk(icol,k,i)+eps) - cxsm=max(0.0_r8,camdiff) - cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) - Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) -!t - camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) - cxs(icol,k)=max(0.0_r8,camdiff) - cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) -!t - enddo - enddo - enddo - do i=5,nbmodes + do icol=1,ncol + Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cate(i,16) + xctrel=min(max(Camrel(icol,k,i),cate(i,1)/cate(i,16)),1.0_r8) + camdiff=Cam(icol,k,i)-xctrel*cate(i,16)*(Nnatk(icol,k,i)+eps) + cxsm=max(0.0_r8,camdiff) + cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) + Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) + !t + camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) + cxs(icol,k)=max(0.0_r8,camdiff) + cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) + !t + enddo + enddo + enddo + do i=5,nbmodes do k=1,pver - do icol=1,ncol - Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cat(i,6) - xctrel=min(max(Camrel(icol,k,i),cat(i,1)/cat(i,6)),1.0_r8) - camdiff=Cam(icol,k,i)-xctrel*cat(i,6)*(Nnatk(icol,k,i)+eps) - cxsm=max(0.0_r8,camdiff) - cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) - Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) -!t - camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) - cxs(icol,k)=max(0.0_r8,camdiff) - cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) -!t - enddo - enddo - enddo - -! Total overshooting mass summed over all modes and all levels - do icol=1,ncol - do k=1,pver - akcxs(icol) =akcxs(icol)+cxstot(icol,k)*deltah_km(icol,k) - enddo - enddo - call outfld('AKCXS ',akcxs ,pcols,lchnk) - - do i=1,nbmodes - do icol=1,ncol - cxsmrel(icol,i)=cxsmtot(icol,i)/(Camtot(icol,i)+eps) - enddo - enddo - - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Camrel"//trim(modeString) - if(i.ne.3) call outfld(varName,Camrel(:,:,i),pcols,lchnk) - enddo - - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Cxsrel"//trim(modeString) - if(i.ne.3) call outfld(varName,cxsmrel(:,i),pcols,lchnk) - enddo - -#endif - - -! AeroCom: Find dry aerosol asymmetry factor and mass for subsequent -! calculation of condensed water mass below... + do icol=1,ncol + Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cat(i,6) + xctrel=min(max(Camrel(icol,k,i),cat(i,1)/cat(i,6)),1.0_r8) + camdiff=Cam(icol,k,i)-xctrel*cat(i,6)*(Nnatk(icol,k,i)+eps) + cxsm=max(0.0_r8,camdiff) + cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) + Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) + !t + camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) + cxs(icol,k)=max(0.0_r8,camdiff) + cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) + !t + enddo + enddo + enddo -#ifdef AEROCOM -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! Total overshooting mass summed over all modes and all levels + do icol=1,ncol + do k=1,pver + akcxs(icol) =akcxs(icol)+cxstot(icol,k)*deltah_km(icol,k) + enddo + enddo + call outfld('AKCXS ',akcxs ,pcols,lchnk) - do k=1,pver - do icol=1,ncol + do i=1,nbmodes + do icol=1,ncol + cxsmrel(icol,i)=cxsmtot(icol,i)/(Camtot(icol,i)+eps) + enddo + enddo + + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Camrel"//trim(modeString) + if(i.ne.3) call outfld(varName,Camrel(:,:,i),pcols,lchnk) + enddo + + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Cxsrel"//trim(modeString) + if(i.ne.3) call outfld(varName,cxsmrel(:,i),pcols,lchnk) + enddo + + ! AeroCom: Find dry aerosol asymmetry factor and mass for subsequent + ! calculation of condensed water mass below... + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + do k=1,pver + do icol=1,ncol Ctotdry(icol,k)=0.0_r8 rh0(icol,k)=0.0_r8 asydry_aer(icol,k)=0.0_r8 - end do - enddo - - lw_on = .false. ! No LW optics needed for RH=0 (interpol returns 0-values) - - do iloop=1,1 ! loop over i>1 for testing CPU use in interpol* -! BC(ax) mode (dry only): - call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) - - mplus10=0 -! SO4/SOA(Ait) mode: - call interpol1 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - -! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - -! BC&OC(Ait) mode: ------ fcm not valid here (=0). Use faitbc instead - call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, & - xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - -! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call interpol5to10 (lchnk, ncol, daylight, xrhnull, irh1null, & - Nnatk, xct, ict1, xfac, ifac1, & - xfbc, ifbc1, xfaq, ifaq1, & - ssa, asym, be, ke, lw_on, kalw) - enddo ! iloop - - - do iloop=1,1 - mplus10=1 -! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - -! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead - call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, & - ssa, asym, be, ke, lw_on, kalw) - -enddo ! iloop - - do i=0,nmodes ! mode 0 to 14 - do k=1,pver - do icol=1,ncol - dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) - Ctotdry(icol,k)=Ctotdry(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) + end do + enddo + + lw_on = .false. ! No LW optics needed for RH=0 (interpol returns 0-values) + + do iloop=1,1 ! loop over i>1 for testing CPU use in interpol* + ! BC(ax) mode (dry only): + call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) + + mplus10=0 + ! SO4/SOA(Ait) mode: + call interpol1 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + + ! BC&OC(Ait) mode: ------ fcm not valid here (=0). Use faitbc instead + call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, & + xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + + ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call interpol5to10 (lchnk, ncol, daylight, xrhnull, irh1null, & + Nnatk, xct, ict1, xfac, ifac1, & + xfbc, ifbc1, xfaq, ifaq1, & + ssa, asym, be, ke, lw_on, kalw) + enddo ! iloop + + + do iloop=1,1 + mplus10=1 + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + + ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead + call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, & + ssa, asym, be, ke, lw_on, kalw) + + enddo ! iloop + + do i=0,nmodes ! mode 0 to 14 + do k=1,pver + do icol=1,ncol + dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) + Ctotdry(icol,k)=Ctotdry(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) #ifdef COLTST4INTCONS - cmodedry(icol,k,i)=dCtot(icol,k)*Nnatk(icol,k,i) + cmodedry(icol,k,i)=dCtot(icol,k)*Nnatk(icol,k,i) #endif - end do - enddo + end do enddo + enddo -!!! AeroCom Phase III: adding asymmetry factor for dry aerosol, wavelength band 4 only -!!! (and with no CMIP6 volcnic contribution) - ib=4 - do k=1,pver + ! AeroCom Phase III: adding asymmetry factor for dry aerosol, wavelength band 4 only + ! (and with no CMIP6 volcnic contribution) + ib=4 + do k=1,pver do icol=1,ncol betot(icol,k,ib)=0.0_r8 ssatot(icol,k,ib)=0.0_r8 asymtot(icol,k,ib)=0.0_r8 - end do - enddo - do i=0,nmodes - do k=1,pver + end do + enddo + do i=0,nmodes + do k=1,pver do icol=1,ncol - betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) - ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib) - asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) -! if(ib.eq.4) then -! write(*,*) 'i, asym =', i, asym(icol,k,i,ib) -! write(*,*) 'i, be =', i, be(icol,k,i,ib) -! write(*,*) 'i, ssa =', i, ssa(icol,k,i,ib) -! endif + betot(icol,k,ib) = betot(icol,k,ib) + Nnatk(icol,k,i)*be(icol,k,i,ib) + ssatot(icol,k,ib) = ssatot(icol,k,ib) + Nnatk(icol,k,i)*be(icol,k,i,ib)*ssa(icol,k,i,ib) + asymtot(icol,k,ib) = asymtot(icol,k,ib)+ Nnatk(icol,k,i)*be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) + ! if(ib.eq.4) then + ! write(*,*) 'i, asym =', i, asym(icol,k,i,ib) + ! write(*,*) 'i, be =', i, be(icol,k,i,ib) + ! write(*,*) 'i, ssa =', i, ssa(icol,k,i,ib) + ! endif end do - enddo enddo - do k=1,pver - do icol=1,ncol + enddo + do k=1,pver + do icol=1,ncol ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) asymtot(icol,k,ib)=asymtot(icol,k,ib) & - /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) + /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) asydry_aer(icol,k)=asymtot(icol,k,ib) - end do - enddo -! - call outfld('ASYMMDRY',asydry_aer,pcols,lchnk) -! - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -#endif ! AEROCOM + end do + enddo + ! + call outfld('ASYMMDRY',asydry_aer,pcols,lchnk) + ! -! (Wet) Optical properties for each of the aerosol modes: + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! (Wet) Optical properties for each of the aerosol modes: - lw_on = .true. ! No LW optics needed for RH=0 (interpol returns 0-values) + lw_on = .true. ! No LW optics needed for RH=0 (interpol returns 0-values) - do iloop=1,1 -! BC(ax) mode (dry only): - call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) + do iloop=1,1 + ! BC(ax) mode (dry only): + call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) - mplus10=0 -! SO4/SOA(Ait) mode: - call interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, & - xfac, ifac1, ssa, asym, be, ke, lw_on, kalw) + mplus10=0 + ! SO4/SOA(Ait) mode: + call interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, & + xfac, ifac1, ssa, asym, be, ke, lw_on, kalw) -! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) -! BC&OC(Ait) mode: ------ fcm invalid here (=0). Using faitbc instead - call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xfbcbg, ifbcbg1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + ! BC&OC(Ait) mode: ------ fcm invalid here (=0). Using faitbc instead + call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xfbcbg, ifbcbg1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) -! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call interpol5to10 (lchnk, ncol, daylight, xrh, irh1, & - Nnatk, xct, ict1, xfac, ifac1, & - xfbc, ifbc1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - enddo ! iloop + ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call interpol5to10 (lchnk, ncol, daylight, xrh, irh1, & + Nnatk, xct, ict1, xfac, ifac1, & + xfbc, ifbc1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + enddo ! iloop -! total aerosol number concentrations - do i=0,nmodes ! mode 0 to 14 - do k=1,pver + ! total aerosol number concentrations + do i=0,nmodes ! mode 0 to 14 + do k=1,pver do icol=1,ncol - n_aer(icol,k)=n_aer(icol,k)+Nnatk(icol,k,i) + n_aer(icol,k)=n_aer(icol,k)+Nnatk(icol,k,i) end do - enddo - enddo - call outfld('N_AER ',n_aer ,pcols,lchnk) - - do iloop=1,1 - mplus10=1 -! SO4/SOA(Ait) mode: - !does no longer exist as an externally mixed mode - -! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - -! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead - call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - enddo ! iloop - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - do k=1,pver - do icol=1,ncol + enddo + enddo + call outfld('N_AER ',n_aer ,pcols,lchnk) + + do iloop=1,1 + mplus10=1 + ! SO4/SOA(Ait) mode: + !does no longer exist as an externally mixed mode + + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + + ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead + call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + enddo ! iloop + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + do k=1,pver + do icol=1,ncol Ctot(icol,k)=0.0_r8 - end do - enddo + end do + enddo - do i=0,nmodes ! mode 0 to 14 - do k=1,pver + do i=0,nmodes ! mode 0 to 14 + do k=1,pver do icol=1,ncol - dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) - Ctot(icol,k)=Ctot(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) + dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) + Ctot(icol,k)=Ctot(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) end do - enddo - enddo + enddo + enddo -#ifdef AEROCOM #ifdef COLTST4INTCONS -! initializing modal mass column burdens - do icol=1,ncol - cmdry0(icol)=0.0_r8 - cmdry1(icol)=0.0_r8 - cmdry2(icol)=0.0_r8 - cmdry4(icol)=0.0_r8 - cmdry5(icol)=0.0_r8 - cmdry6(icol)=0.0_r8 - cmdry7(icol)=0.0_r8 - cmdry8(icol)=0.0_r8 - cmdry9(icol)=0.0_r8 - cmdry10(icol)=0.0_r8 - cmdry12(icol)=0.0_r8 - cmdry14(icol)=0.0_r8 - enddo + ! initializing modal mass column burdens + do icol=1,ncol + cmdry0(icol)=0.0_r8 + cmdry1(icol)=0.0_r8 + cmdry2(icol)=0.0_r8 + cmdry4(icol)=0.0_r8 + cmdry5(icol)=0.0_r8 + cmdry6(icol)=0.0_r8 + cmdry7(icol)=0.0_r8 + cmdry8(icol)=0.0_r8 + cmdry9(icol)=0.0_r8 + cmdry10(icol)=0.0_r8 + cmdry12(icol)=0.0_r8 + cmdry14(icol)=0.0_r8 + enddo #endif -! Mass concentration (ug/m3) and mmr (kg/kg) of aerosol condensed water - do k=1,pver - do icol=1,ncol + ! Mass concentration (ug/m3) and mmr (kg/kg) of aerosol condensed water + do k=1,pver + do icol=1,ncol Cwater(icol,k)=Ctot(icol,k)-Ctotdry(icol,k) mmr_aerh2o(icol,k)=1.e-9_r8*Cwater(icol,k)/rhoda(icol,k) #ifdef COLTST4INTCONS -! and dry mass column burdens for each mode/mixture + ! and dry mass column burdens for each mode/mixture deltah=deltah_km(icol,k) cmdry0(icol)=cmdry0(icol)+cmodedry(icol,k,0)*deltah cmdry1(icol)=cmdry1(icol)+cmodedry(icol,k,1)*deltah @@ -866,186 +752,184 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & cmdry12(icol)=cmdry12(icol)+cmodedry(icol,k,12)*deltah cmdry14(icol)=cmdry14(icol)+cmodedry(icol,k,14)*deltah #endif - end do - enddo -#endif -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! SW Optical properties of total aerosol: - do ib=1,nbands - do k=1,pver - do icol=1,ncol - betot(icol,k,ib)=0.0_r8 - ssatot(icol,k,ib)=0.0_r8 - asymtot(icol,k,ib)=0.0_r8 - end do - enddo - enddo - do ib=1,nbands - do i=0,nmodes - do k=1,pver + end do + enddo + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! SW Optical properties of total aerosol: + do ib=1,nbands + do k=1,pver do icol=1,ncol - betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) - ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib) - asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) + betot(icol,k,ib)=0.0_r8 + ssatot(icol,k,ib)=0.0_r8 + asymtot(icol,k,ib)=0.0_r8 end do - enddo - enddo - enddo -! Adding also the volcanic contribution (CMIP6), which is using a CMIP6 -! band numbering identical to the AeroTab numbering (unlike CAM) both -! for SW and LW. I.e., no remapping is required here. -! Info from CMIP_CAM6_radiation_v3.nc -! wl1_sun = 0.2, 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, -! 1.2987, 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615 ; -! wl2_sun = 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, 1.2987, -! 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615, 12.1951 ; -! wl1_earth = 3.07692, 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, -! 7.19424, 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714 ; -! wl2_earth = 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, 7.19424, -! 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714, 1000 ; - do ib=1,nbands - betot(1:ncol,1:pver,ib) = betot(1:ncol,1:pver,ib) & - + volc_ext_sun(1:ncol,1:pver,ib) - ssatot(1:ncol,1:pver,ib) = ssatot(1:ncol,1:pver,ib) & - + volc_ext_sun(1:ncol,1:pver,ib)*volc_omega_sun(1:ncol,1:pver,ib) - asymtot(1:ncol,1:pver,ib) = asymtot(1:ncol,1:pver,ib) & - + volc_ext_sun(1:ncol,1:pver,ib)*volc_omega_sun(1:ncol,1:pver,ib) & - *volc_g_sun(1:ncol,1:pver,ib) - enddo -!akc6+ - bevisvolc(1:ncol,1:pver) = volc_ext_sun(1:ncol,1:pver,4) -!akc6- -! and then calculate the total bulk optical parameters - do ib=1,nbands - do k=1,pver - do icol=1,ncol - ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) - asymtot(icol,k,ib)=asymtot(icol,k,ib) & - /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) - end do enddo - enddo - -!------------------------------------------------------------------------------------------------ -! Replace CAM5 standard aerosol optics with CAM5-Oslo optics (except top layer: no aerosol) -! Remapping from AeroTab to CAM5 SW bands, see p. 167 in the CAM5.0 description: -! CAM5 bands AeroTab bands -! 14 3.846 12.195 14 -! 1 3.077 3.846 13 -! 2 2.500 3.077 12 -! 3 2.150 2.500 11 -! 4 1.942 2.150 10 -! 5 1.626 1.942 9 -! 6 1.299 1.626 8 -! 7 1.242 1.299 7 -! 8 0.778 1.242 6 -! 9 0.625 0.778 5 -! 10 0.442 0.625 4 -! 11 0.345 0.442 3 -! 12 0.263 0.345 2 -! 13 0.200 0.263 1 - - do i=1,ncol ! zero aerosol in the top layer - do ib=1,14 ! 1-nbands - per_tau(i,0,ib)= 0._r8 - per_tau_w(i,0,ib)= 0.999_r8 - per_tau_w_g(i,0,ib)= 0.5_r8 - per_tau_w_f(i,0,ib)= 0.25_r8 - end do - do ib=1,14 ! initialize also for the other layers + enddo + do ib=1,nbands + do i=0,nmodes do k=1,pver - per_tau(i,k,ib)= 0._r8 - per_tau_w(i,k,ib)= 0.999_r8 - per_tau_w_g(i,k,ib)= 0.5_r8 - per_tau_w_f(i,k,ib)= 0.25_r8 + do icol=1,ncol + betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) + ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib) + asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) + end do + enddo + enddo + enddo + ! Adding also the volcanic contribution (CMIP6), which is using a CMIP6 + ! band numbering identical to the AeroTab numbering (unlike CAM) both + ! for SW and LW. I.e., no remapping is required here. + ! Info from CMIP_CAM6_radiation_v3.nc + ! wl1_sun = 0.2, 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, + ! 1.2987, 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615 ; + ! wl2_sun = 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, 1.2987, + ! 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615, 12.1951 ; + ! wl1_earth = 3.07692, 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, + ! 7.19424, 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714 ; + ! wl2_earth = 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, 7.19424, + ! 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714, 1000 ; + do ib=1,nbands + betot(1:ncol,1:pver,ib) = betot(1:ncol,1:pver,ib) & + + volc_ext_sun(1:ncol,1:pver,ib) + ssatot(1:ncol,1:pver,ib) = ssatot(1:ncol,1:pver,ib) & + + volc_ext_sun(1:ncol,1:pver,ib)*volc_omega_sun(1:ncol,1:pver,ib) + asymtot(1:ncol,1:pver,ib) = asymtot(1:ncol,1:pver,ib) & + + volc_ext_sun(1:ncol,1:pver,ib)*volc_omega_sun(1:ncol,1:pver,ib) & + *volc_g_sun(1:ncol,1:pver,ib) + enddo + !akc6+ + bevisvolc(1:ncol,1:pver) = volc_ext_sun(1:ncol,1:pver,4) + !akc6- + ! and then calculate the total bulk optical parameters + do ib=1,nbands + do k=1,pver + do icol=1,ncol + ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) + asymtot(icol,k,ib)=asymtot(icol,k,ib) & + /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) end do - end do + enddo + enddo + + !------------------------------------------------------------------------------------------------ + ! Replace CAM5 standard aerosol optics with CAM5-Oslo optics (except top layer: no aerosol) + ! Remapping from AeroTab to CAM5 SW bands, see p. 167 in the CAM5.0 description: + ! CAM5 bands AeroTab bands + ! 14 3.846 12.195 14 + ! 1 3.077 3.846 13 + ! 2 2.500 3.077 12 + ! 3 2.150 2.500 11 + ! 4 1.942 2.150 10 + ! 5 1.626 1.942 9 + ! 6 1.299 1.626 8 + ! 7 1.242 1.299 7 + ! 8 0.778 1.242 6 + ! 9 0.625 0.778 5 + ! 10 0.442 0.625 4 + ! 11 0.345 0.442 3 + ! 12 0.263 0.345 2 + ! 13 0.200 0.263 1 + + do i=1,ncol ! zero aerosol in the top layer + do ib=1,14 ! 1-nbands + per_tau(i,0,ib)= 0._r8 + per_tau_w(i,0,ib)= 0.999_r8 + per_tau_w_g(i,0,ib)= 0.5_r8 + per_tau_w_f(i,0,ib)= 0.25_r8 end do -! Remapping of SW wavelength bands from AeroTab to CAM5 - do i=1,ncol - do ib=1,13 + do ib=1,14 ! initialize also for the other layers do k=1,pver - per_tau(i,k,ib)=deltah_km(i,k)*betot(i,k,14-ib) - per_tau_w(i,k,ib)=per_tau(i,k,ib)*max(min(ssatot(i,k,14-ib),0.999999_r8),1.e-6_r8) - per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,14-ib) - per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,14-ib) -!tst -! if(ib.eq.4.and.k.eq.pver.and.i.eq.1) then -! write(*,*) 'per_tau =', per_tau(i,k,ib) -! write(*,*) 'per_tau_w =', per_tau_w(i,k,ib) -! write(*,*) 'per_tau_w_g =', per_tau_w_g(i,k,ib) -! endif -!tst + per_tau(i,k,ib)= 0._r8 + per_tau_w(i,k,ib)= 0.999_r8 + per_tau_w_g(i,k,ib)= 0.5_r8 + per_tau_w_f(i,k,ib)= 0.25_r8 end do - end do - ib=14 + end do + end do + ! Remapping of SW wavelength bands from AeroTab to CAM5 + do i=1,ncol + do ib=1,13 do k=1,pver - per_tau(i,k,ib)=deltah_km(i,k)*betot(i,k,ib) - per_tau_w(i,k,ib)=per_tau(i,k,ib)*max(min(ssatot(i,k,ib),0.999999_r8),1.e-6_r8) - per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,ib) - per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,ib) - end do - end do ! ncol -!------------------------------------------------------------------------------------------------ - -! LW Optical properties of total aerosol: - do ib=1,nlwbands - do k=1,pver - do icol=1,ncol - batotlw(icol,k,ib)=0.0_r8 + per_tau(i,k,ib)=deltah_km(i,k)*betot(i,k,14-ib) + per_tau_w(i,k,ib)=per_tau(i,k,ib)*max(min(ssatot(i,k,14-ib),0.999999_r8),1.e-6_r8) + per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,14-ib) + per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,14-ib) + !tst + ! if(ib.eq.4.and.k.eq.pver.and.i.eq.1) then + ! write(*,*) 'per_tau =', per_tau(i,k,ib) + ! write(*,*) 'per_tau_w =', per_tau_w(i,k,ib) + ! write(*,*) 'per_tau_w_g =', per_tau_w_g(i,k,ib) + ! endif + !tst end do - enddo - enddo - do ib=1,nlwbands - do i=0,nmodes - do k=1,pver + end do + ib=14 + do k=1,pver + per_tau(i,k,ib)=deltah_km(i,k)*betot(i,k,ib) + per_tau_w(i,k,ib)=per_tau(i,k,ib)*max(min(ssatot(i,k,ib),0.999999_r8),1.e-6_r8) + per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,ib) + per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,ib) + end do + end do ! ncol + !------------------------------------------------------------------------------------------------ + + ! LW Optical properties of total aerosol: + do ib=1,nlwbands + do k=1,pver do icol=1,ncol - balw(icol,k,i,ib)=kalw(icol,k,i,ib)*(be(icol,k,i,4)/(ke(icol,k,i,4)+eps)) - batotlw(icol,k,ib)=batotlw(icol,k,ib)+Nnatk(icol,k,i)*balw(icol,k,i,ib) + batotlw(icol,k,ib)=0.0_r8 end do - enddo enddo - enddo - -! Adding also the volcanic contribution (CMIP6), which is also using -! AeroTab band numbering, so that a remapping is required here - do ib=1,nlwbands - volc_balw(1:ncol,1:pver,ib) = volc_ext_earth(:ncol,1:pver,ib) & - *(1.0_r8-volc_omega_earth(:ncol,1:pver,ib)) - batotlw(1:ncol,1:pver,ib)=batotlw(1:ncol,1:pver,ib)+volc_balw(1:ncol,1:pver,ib) - enddo - -! Remapping of LW wavelength bands from AeroTab to CAM5 - do ib=1,nlwbands + enddo + do ib=1,nlwbands + do i=0,nmodes + do k=1,pver + do icol=1,ncol + balw(icol,k,i,ib)=kalw(icol,k,i,ib)*(be(icol,k,i,4)/(ke(icol,k,i,4)+eps)) + batotlw(icol,k,ib)=batotlw(icol,k,ib)+Nnatk(icol,k,i)*balw(icol,k,i,ib) + end do + enddo + enddo + enddo + + ! Adding also the volcanic contribution (CMIP6), which is also using + ! AeroTab band numbering, so that a remapping is required here + do ib=1,nlwbands + volc_balw(1:ncol,1:pver,ib) = volc_ext_earth(:ncol,1:pver,ib) & + *(1.0_r8-volc_omega_earth(:ncol,1:pver,ib)) + batotlw(1:ncol,1:pver,ib)=batotlw(1:ncol,1:pver,ib)+volc_balw(1:ncol,1:pver,ib) + enddo + + ! Remapping of LW wavelength bands from AeroTab to CAM5 + do ib=1,nlwbands do i=1,ncol - do k=1,pver - per_lw_abs(i,k,ib)=deltah_km(i,k)*batotlw(i,k,17-ib) -! if(ib.eq.1.and.k.eq.pver.and.i.eq.1) then -! write(*,*) 'per_lw_abs =', per_lw_abs(i,k,ib) -! endif - end do - end do - end do + do k=1,pver + per_lw_abs(i,k,ib)=deltah_km(i,k)*batotlw(i,k,17-ib) + ! if(ib.eq.1.and.k.eq.pver.and.i.eq.1) then + ! write(*,*) 'per_lw_abs =', per_lw_abs(i,k,ib) + ! endif + end do + end do + end do -#ifdef AEROCOM - do i=1,ncol - do k=1,pver + do i=1,ncol + do k=1,pver batotsw13(i,k)=betot(i,k,13)*(1.0_r8-ssatot(i,k,13)) batotlw01(i,k)=batotlw(i,k,1) - end do - end do -! These two fields should be close to equal, both representing absorption -! in the 3.077-3.846 um wavelenght band (i.e., a check of LUT for LW vs. SW). - call outfld('BATSW13 ',batotsw13,pcols,lchnk) - call outfld('BATLW01 ',batotlw01,pcols,lchnk) -#endif + end do + end do + ! These two fields should be close to equal, both representing absorption + ! in the 3.077-3.846 um wavelenght band (i.e., a check of LUT for LW vs. SW). + call outfld('BATSW13 ',batotsw13,pcols,lchnk) + call outfld('BATLW01 ',batotlw01,pcols,lchnk) #ifdef COLTST4INTCONS -! initialize modal optical extinctions - do k=1,pver - do icol=1,ncol + ! initialize modal optical extinctions + do k=1,pver + do icol=1,ncol bekc0(icol,k)=0.0_r8 bekc1(icol,k)=0.0_r8 bekc2(icol,k)=0.0_r8 @@ -1058,7 +942,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & bekc10(icol,k)=0.0_r8 bekc12(icol,k)=0.0_r8 bekc14(icol,k)=0.0_r8 -! + ! kekc0(icol,k)=0.0_r8 kekc1(icol,k)=0.0_r8 kekc2(icol,k)=0.0_r8 @@ -1071,11 +955,11 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & kekc10(icol,k)=0.0_r8 kekc12(icol,k)=0.0_r8 kekc14(icol,k)=0.0_r8 - end do - enddo -! optical depth (in band 4 = vis.) for each of the modes - do k=1,pver - do icol=1,ncol + end do + enddo + ! optical depth (in band 4 = vis.) for each of the modes + do k=1,pver + do icol=1,ncol bekc0(icol,k) =Nnatk(icol,k,0) *be(icol,k,0,4) bekc1(icol,k) =Nnatk(icol,k,1) *be(icol,k,1,4) bekc2(icol,k) =Nnatk(icol,k,2) *be(icol,k,2,4) @@ -1088,7 +972,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & bekc10(icol,k)=Nnatk(icol,k,10)*be(icol,k,10,4) bekc12(icol,k)=Nnatk(icol,k,12)*be(icol,k,12,4) bekc14(icol,k)=Nnatk(icol,k,14)*be(icol,k,14,4) -! + ! kekc0(icol,k) =ke(icol,k,0,4) kekc1(icol,k) =ke(icol,k,1,4) kekc2(icol,k) =ke(icol,k,2,4) @@ -1101,1215 +985,1116 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & kekc10(icol,k)=ke(icol,k,10,4) kekc12(icol,k)=ke(icol,k,12,4) kekc14(icol,k)=ke(icol,k,14,4) - end do - enddo + end do + enddo #endif -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! APPROXIMATE aerosol extinction and absorption at 550nm (0.442-0.625 um) -! (in the visible wavelength band) - do k=1,pver - do icol=1,ncol + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! APPROXIMATE aerosol extinction and absorption at 550nm (0.442-0.625 um) + ! (in the visible wavelength band) + do k=1,pver + do icol=1,ncol betotvis(icol,k)=betot(icol,k,4) batotvis(icol,k)=betotvis(icol,k)*(1.0-ssatot(icol,k,4)) - end do - enddo -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + end do + enddo + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - do k=1,pver - do icol=1,ncol + do k=1,pver + do icol=1,ncol ssavis(icol,k) = 0.0_r8 asymmvis(icol,k) = 0.0_r8 extvis(icol,k) = 0.0_r8 dayfoc(icol,k) = 0.0_r8 - enddo - end do + enddo + end do - do k=1,pver - do icol=1,ncol -! dayfoc < 1 when looping only over gridcells with daylight + do k=1,pver + do icol=1,ncol + ! dayfoc < 1 when looping only over gridcells with daylight if(daylight(icol)) then - dayfoc(icol,k) = 1.0_r8 -! with the new bands in CAM5, band 4 is now at ca 0.5 um (0.442-0.625) - ssavis(icol,k) = ssatot(icol,k,4) - asymmvis(icol,k) = asymtot(icol,k,4) - extvis(icol,k) = betot(icol,k,4) - endif - enddo - end do - -! optical parameters in visible light (0.442-0.625um) - call outfld('SSAVIS ',ssavis,pcols,lchnk) - call outfld('ASYMMVIS',asymmvis,pcols,lchnk) - call outfld('EXTVIS ',extvis,pcols,lchnk) - call outfld('DAYFOC ',dayfoc,pcols,lchnk) - -! Initialize fields - do icol=1,ncol -! akso4c(icol)=0.0_r8 -! akbcc(icol)=0.0_r8 -! akocc(icol)=0.0_r8 - aodvis(icol)=0.0_r8 - absvis(icol)=0.0_r8 - aodvisvolc(icol)=0.0_r8 - absvisvolc(icol)=0.0_r8 - airmass(icol)=0.0_r8 !akc6 -#ifdef COLTST4INTCONS - taukc0(icol)=0.0_r8 - taukc1(icol)=0.0_r8 - taukc2(icol)=0.0_r8 -! taukc3(icol)=0.0_r8 - taukc4(icol)=0.0_r8 - taukc5(icol)=0.0_r8 - taukc6(icol)=0.0_r8 - taukc7(icol)=0.0_r8 - taukc8(icol)=0.0_r8 - taukc9(icol)=0.0_r8 - taukc10(icol)=0.0_r8 -! taukc11(icol)=0.0_r8 - taukc12(icol)=0.0_r8 -! taukc13(icol)=0.0_r8 - taukc14(icol)=0.0_r8 -#endif + dayfoc(icol,k) = 1.0_r8 + ! with the new bands in CAM5, band 4 is now at ca 0.5 um (0.442-0.625) + ssavis(icol,k) = ssatot(icol,k,4) + asymmvis(icol,k) = asymtot(icol,k,4) + extvis(icol,k) = betot(icol,k,4) + endif enddo - - do icol=1,ncol - if(daylight(icol)) then - do k=1,pver -! Layer thickness, unit km, and layer airmass, unit kg/m2 - deltah=deltah_km(icol,k) -!akc6 airmass(icol,k)=1.e3_r8*deltah*rhoda(icol,k) - airmassl(icol,k)=1.e3_r8*deltah*rhoda(icol,k) - airmass(icol)=airmass(icol)+airmassl(icol,k) !akc6 -! Optical depths at ca. 550 nm (0.442-0.625um) all aerosols -!tst -! aodvis3d(icol,k)=betotvis(icol,k)*deltah -!tst - aodvis(icol)=aodvis(icol)+betotvis(icol,k)*deltah - absvis(icol)=absvis(icol)+batotvis(icol,k)*deltah -! Optical depths at ca. 550 nm (0.442-0.625um) CMIP6 volcanic aerosol - aodvisvolc(icol)=aodvisvolc(icol)+volc_ext_sun(icol,k,4)*deltah - absvisvolc(icol)=absvisvolc(icol)+volc_ext_sun(icol,k,4) & - *(1.0_r8-volc_omega_sun(icol,k,4))*deltah + end do + + ! optical parameters in visible light (0.442-0.625um) + call outfld('SSAVIS ',ssavis,pcols,lchnk) + call outfld('ASYMMVIS',asymmvis,pcols,lchnk) + call outfld('EXTVIS ',extvis,pcols,lchnk) + call outfld('DAYFOC ',dayfoc,pcols,lchnk) + + ! Initialize fields + do icol=1,ncol + ! akso4c(icol)=0.0_r8 + ! akbcc(icol)=0.0_r8 + ! akocc(icol)=0.0_r8 + aodvis(icol)=0.0_r8 + absvis(icol)=0.0_r8 + aodvisvolc(icol)=0.0_r8 + absvisvolc(icol)=0.0_r8 + airmass(icol)=0.0_r8 !akc6 #ifdef COLTST4INTCONS -! To check internal consistency of these AOD calculations, make -! sure that sum_i(taukc_i)=aodvis (tested to be ok on 7/1-2016). -! Note that this will not be the case when CMIP6 volcanic forcing -! as optical properties are included, since this comes "on top of" -! the mixtures 0-14 below. - taukc0(icol) =taukc0(icol) +bekc0(icol,k)*deltah - taukc1(icol) =taukc1(icol) +bekc1(icol,k)*deltah - taukc2(icol) =taukc2(icol) +bekc2(icol,k)*deltah - taukc4(icol) =taukc4(icol) +bekc4(icol,k)*deltah - taukc5(icol) =taukc5(icol) +bekc5(icol,k)*deltah - taukc6(icol) =taukc6(icol) +bekc6(icol,k)*deltah - taukc7(icol) =taukc7(icol) +bekc7(icol,k)*deltah - taukc8(icol) =taukc8(icol) +bekc8(icol,k)*deltah - taukc9(icol) =taukc9(icol) +bekc9(icol,k)*deltah - taukc10(icol)=taukc10(icol)+bekc10(icol,k)*deltah - taukc12(icol)=taukc12(icol)+bekc12(icol,k)*deltah - taukc14(icol)=taukc14(icol)+bekc14(icol,k)*deltah + taukc0(icol)=0.0_r8 + taukc1(icol)=0.0_r8 + taukc2(icol)=0.0_r8 + ! taukc3(icol)=0.0_r8 + taukc4(icol)=0.0_r8 + taukc5(icol)=0.0_r8 + taukc6(icol)=0.0_r8 + taukc7(icol)=0.0_r8 + taukc8(icol)=0.0_r8 + taukc9(icol)=0.0_r8 + taukc10(icol)=0.0_r8 + ! taukc11(icol)=0.0_r8 + taukc12(icol)=0.0_r8 + ! taukc13(icol)=0.0_r8 + taukc14(icol)=0.0_r8 #endif - end do ! k - endif ! daylight - end do ! icol - -! Extinction and absorption for 0.55 um for the total aerosol, and AODs -#ifdef AEROCOM - call outfld('BETOTVIS',betotvis,pcols,lchnk) - call outfld('BATOTVIS',batotvis,pcols,lchnk) + enddo + + do icol=1,ncol + if(daylight(icol)) then + do k=1,pver + ! Layer thickness, unit km, and layer airmass, unit kg/m2 + deltah=deltah_km(icol,k) + !akc6 airmass(icol,k)=1.e3_r8*deltah*rhoda(icol,k) + airmassl(icol,k)=1.e3_r8*deltah*rhoda(icol,k) + airmass(icol)=airmass(icol)+airmassl(icol,k) !akc6 + ! Optical depths at ca. 550 nm (0.442-0.625um) all aerosols + !tst + ! aodvis3d(icol,k)=betotvis(icol,k)*deltah + !tst + aodvis(icol)=aodvis(icol)+betotvis(icol,k)*deltah + absvis(icol)=absvis(icol)+batotvis(icol,k)*deltah + ! Optical depths at ca. 550 nm (0.442-0.625um) CMIP6 volcanic aerosol + aodvisvolc(icol)=aodvisvolc(icol)+volc_ext_sun(icol,k,4)*deltah + absvisvolc(icol)=absvisvolc(icol)+volc_ext_sun(icol,k,4) & + *(1.0_r8-volc_omega_sun(icol,k,4))*deltah +#ifdef COLTST4INTCONS + ! To check internal consistency of these AOD calculations, make + ! sure that sum_i(taukc_i)=aodvis (tested to be ok on 7/1-2016). + ! Note that this will not be the case when CMIP6 volcanic forcing + ! as optical properties are included, since this comes "on top of" + ! the mixtures 0-14 below. + taukc0(icol) =taukc0(icol) +bekc0(icol,k)*deltah + taukc1(icol) =taukc1(icol) +bekc1(icol,k)*deltah + taukc2(icol) =taukc2(icol) +bekc2(icol,k)*deltah + taukc4(icol) =taukc4(icol) +bekc4(icol,k)*deltah + taukc5(icol) =taukc5(icol) +bekc5(icol,k)*deltah + taukc6(icol) =taukc6(icol) +bekc6(icol,k)*deltah + taukc7(icol) =taukc7(icol) +bekc7(icol,k)*deltah + taukc8(icol) =taukc8(icol) +bekc8(icol,k)*deltah + taukc9(icol) =taukc9(icol) +bekc9(icol,k)*deltah + taukc10(icol)=taukc10(icol)+bekc10(icol,k)*deltah + taukc12(icol)=taukc12(icol)+bekc12(icol,k)*deltah + taukc14(icol)=taukc14(icol)+bekc14(icol,k)*deltah #endif -! call outfld('AODVIS ',aodvis ,pcols,lchnk) - call outfld('AOD_VIS ',aodvis ,pcols,lchnk) - call outfld('ABSVIS ',absvis ,pcols,lchnk) - call outfld('AODVVOLC',aodvisvolc ,pcols,lchnk) - call outfld('ABSVVOLC',absvisvolc ,pcols,lchnk) -!akc6+ - call outfld('BVISVOLC',bevisvolc ,pcols,lchnk) -!akc6- -!tst -! call outfld('AODVIS3D',aodvis3d,pcols,lchnk) -!tst + end do ! k + endif ! daylight + end do ! icol + + ! Extinction and absorption for 0.55 um for the total aerosol, and AODs + call outfld('BETOTVIS',betotvis,pcols,lchnk) + call outfld('BATOTVIS',batotvis,pcols,lchnk) + ! call outfld('AODVIS ',aodvis ,pcols,lchnk) + call outfld('AOD_VIS ',aodvis ,pcols,lchnk) + call outfld('ABSVIS ',absvis ,pcols,lchnk) + call outfld('AODVVOLC',aodvisvolc ,pcols,lchnk) + call outfld('ABSVVOLC',absvisvolc ,pcols,lchnk) + !akc6+ + call outfld('BVISVOLC',bevisvolc ,pcols,lchnk) + !akc6- + !tst + ! call outfld('AODVIS3D',aodvis3d,pcols,lchnk) + !tst #ifdef COLTST4INTCONS - call outfld('TAUKC0 ',taukc0 ,pcols,lchnk) - call outfld('TAUKC1 ',taukc1 ,pcols,lchnk) - call outfld('TAUKC2 ',taukc2 ,pcols,lchnk) - call outfld('TAUKC4 ',taukc4 ,pcols,lchnk) - call outfld('TAUKC5 ',taukc5 ,pcols,lchnk) - call outfld('TAUKC6 ',taukc6 ,pcols,lchnk) - call outfld('TAUKC7 ',taukc7 ,pcols,lchnk) - call outfld('TAUKC8 ',taukc8 ,pcols,lchnk) - call outfld('TAUKC9 ',taukc9 ,pcols,lchnk) - call outfld('TAUKC10 ',taukc10,pcols,lchnk) - call outfld('TAUKC12 ',taukc12,pcols,lchnk) - call outfld('TAUKC14 ',taukc14,pcols,lchnk) -! - call outfld('MECKC0 ',kekc0 ,pcols,lchnk) - call outfld('MECKC1 ',kekc1 ,pcols,lchnk) - call outfld('MECKC2 ',kekc2 ,pcols,lchnk) - call outfld('MECKC4 ',kekc4 ,pcols,lchnk) - call outfld('MECKC5 ',kekc5 ,pcols,lchnk) - call outfld('MECKC6 ',kekc6 ,pcols,lchnk) - call outfld('MECKC7 ',kekc7 ,pcols,lchnk) - call outfld('MECKC8 ',kekc8 ,pcols,lchnk) - call outfld('MECKC9 ',kekc9 ,pcols,lchnk) - call outfld('MECKC10 ',kekc10 ,pcols,lchnk) - call outfld('MECKC12 ',kekc12 ,pcols,lchnk) - call outfld('MECKC14 ',kekc14 ,pcols,lchnk) + call outfld('TAUKC0 ',taukc0 ,pcols,lchnk) + call outfld('TAUKC1 ',taukc1 ,pcols,lchnk) + call outfld('TAUKC2 ',taukc2 ,pcols,lchnk) + call outfld('TAUKC4 ',taukc4 ,pcols,lchnk) + call outfld('TAUKC5 ',taukc5 ,pcols,lchnk) + call outfld('TAUKC6 ',taukc6 ,pcols,lchnk) + call outfld('TAUKC7 ',taukc7 ,pcols,lchnk) + call outfld('TAUKC8 ',taukc8 ,pcols,lchnk) + call outfld('TAUKC9 ',taukc9 ,pcols,lchnk) + call outfld('TAUKC10 ',taukc10,pcols,lchnk) + call outfld('TAUKC12 ',taukc12,pcols,lchnk) + call outfld('TAUKC14 ',taukc14,pcols,lchnk) + ! + call outfld('MECKC0 ',kekc0 ,pcols,lchnk) + call outfld('MECKC1 ',kekc1 ,pcols,lchnk) + call outfld('MECKC2 ',kekc2 ,pcols,lchnk) + call outfld('MECKC4 ',kekc4 ,pcols,lchnk) + call outfld('MECKC5 ',kekc5 ,pcols,lchnk) + call outfld('MECKC6 ',kekc6 ,pcols,lchnk) + call outfld('MECKC7 ',kekc7 ,pcols,lchnk) + call outfld('MECKC8 ',kekc8 ,pcols,lchnk) + call outfld('MECKC9 ',kekc9 ,pcols,lchnk) + call outfld('MECKC10 ',kekc10 ,pcols,lchnk) + call outfld('MECKC12 ',kekc12 ,pcols,lchnk) + call outfld('MECKC14 ',kekc14 ,pcols,lchnk) #endif -#ifdef AEROCOM ! AEROCOM***********AEROCOM**************AEROCOM***************below + ra#ifdef AEROCOM ! AEROCOM***********AEROCOM**************AEROCOM***************below -! call outfld('BEKC4 ',bekc4 ,pcols,lchnk) + ! call outfld('BEKC4 ',bekc4 ,pcols,lchnk) -! Initialize fields - do icol=1,ncol - daerh2o(icol)=0.0_r8 - vaercols(icol)=0.0_r8 - vaercoll(icol)=0.0_r8 - aaercols(icol)=0.0_r8 - aaercoll(icol)=0.0_r8 - do i=0,nmodes - dload(icol,i)=0.0_r8 - enddo - enddo - bext550n(:,:,:) = 0._r8 - babs550n(:,:,:) = 0._r8 - bext440n(:,:,:) = 0._r8 - babs440n(:,:,:) = 0._r8 - bext870n(:,:,:) = 0._r8 - babs870n(:,:,:) = 0._r8 - babs500n(:,:,:) = 0._r8 - babs670n(:,:,:) = 0._r8 - vnbcarr(:,:) =0.0_r8 - vaitbcarr(:,:) =0.0_r8 - cknorm(:,:,:) =0.0_r8 -!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - -! AeroCom diagnostics requiring table look-ups with ambient RH. - - do irf=0,0 - call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebglt1, bebggt1, bebclt1, bebcgt1, & - beoclt1, beocgt1, bes4lt1, bes4gt1, & - backsc550, babg550, babc550, baoc550, basu550, & - bext440n, bext500n, bext550n, bext670n, bext870n, & - bebg440n, bebg500n, bebg550n, bebg670n, bebg870n, & - bebc440n, bebc500n, bebc550n, bebc670n, bebc870n, & - beoc440n, beoc500n, beoc550n, beoc670n, beoc870n, & - besu440n, besu500n, besu550n, besu670n, besu870n, & - babs440n, babs500n, babs550n, babs670n, babs870n, & - bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & - beoclt1n, beocgt1n, bes4lt1n, bes4gt1n, & - backsc550n, babg550n, babc550n, baoc550n, basu550n) - end do ! irf - -!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - - do k=1,pver - do icol=1,ncol - - bebglt1t(icol,k)=0.0_r8 - bebggt1t(icol,k)=0.0_r8 - bebclt1t(icol,k)=0.0_r8 - bebcgt1t(icol,k)=0.0_r8 - beoclt1t(icol,k)=0.0_r8 - beocgt1t(icol,k)=0.0_r8 - bes4lt1t(icol,k)=0.0_r8 - bes4gt1t(icol,k)=0.0_r8 - bedustlt1(icol,k)=0.0_r8 - bedustgt1(icol,k)=0.0_r8 - besslt1(icol,k)=0.0_r8 - bessgt1(icol,k)=0.0_r8 - - bext440tot(icol,k)=0.0_r8 - babs440tot(icol,k)=0.0_r8 - bext500tot(icol,k)=0.0_r8 - babs500tot(icol,k)=0.0_r8 - bext550tot(icol,k)=0.0_r8 - babs550tot(icol,k)=0.0_r8 - bext670tot(icol,k)=0.0_r8 - babs670tot(icol,k)=0.0_r8 - bext870tot(icol,k)=0.0_r8 - babs870tot(icol,k)=0.0_r8 - - backsc550tot(icol,k)=0.0_r8 - - bebg440tot(icol,k)=0.0_r8 -! babg440tot(icol,k)=0.0_r8 - bebg500tot(icol,k)=0.0_r8 -! babg500tot(icol,k)=0.0_r8 - bebg550tot(icol,k)=0.0_r8 - babg550tot(icol,k)=0.0_r8 - bebg670tot(icol,k)=0.0_r8 -! babg670tot(icol,k)=0.0_r8 - bebg870tot(icol,k)=0.0_r8 -! babg870tot(icol,k)=0.0_r8 - - bebc440tot(icol,k)=0.0_r8 -! babc440tot(icol,k)=0.0_r8 - bebc500tot(icol,k)=0.0_r8 -! babc500tot(icol,k)=0.0_r8 - bebc550tot(icol,k)=0.0_r8 - babc550tot(icol,k)=0.0_r8 - bebc670tot(icol,k)=0.0_r8 -! babc670tot(icol,k)=0.0_r8 - bebc870tot(icol,k)=0.0_r8 -! babc870tot(icol,k)=0.0_r8 - - beoc440tot(icol,k)=0.0_r8 -! baoc440tot(icol,k)=0.0_r8 - beoc500tot(icol,k)=0.0_r8 -! baoc500tot(icol,k)=0.0_r8 - beoc550tot(icol,k)=0.0_r8 - baoc550tot(icol,k)=0.0_r8 - beoc670tot(icol,k)=0.0_r8 -! baoc670tot(icol,k)=0.0_r8 - beoc870tot(icol,k)=0.0_r8 -! baoc870tot(icol,k)=0.0_r8 - - besu440tot(icol,k)=0.0_r8 -! basu440tot(icol,k)=0.0_r8 - besu500tot(icol,k)=0.0_r8 -! basu500tot(icol,k)=0.0_r8 - besu550tot(icol,k)=0.0_r8 - basu550tot(icol,k)=0.0_r8 - besu670tot(icol,k)=0.0_r8 -! basu670tot(icol,k)=0.0_r8 - besu870tot(icol,k)=0.0_r8 -! basu870tot(icol,k)=0.0_r8 - - enddo - enddo - - do i=0,nbmodes - do k=1,pver + ! Initialize fields + do icol=1,ncol + daerh2o(icol)=0.0_r8 + vaercols(icol)=0.0_r8 + vaercoll(icol)=0.0_r8 + aaercols(icol)=0.0_r8 + aaercoll(icol)=0.0_r8 + do i=0,nmodes + dload(icol,i)=0.0_r8 + enddo + enddo + bext550n(:,:,:) = 0._r8 + babs550n(:,:,:) = 0._r8 + bext440n(:,:,:) = 0._r8 + babs440n(:,:,:) = 0._r8 + bext870n(:,:,:) = 0._r8 + babs870n(:,:,:) = 0._r8 + babs500n(:,:,:) = 0._r8 + babs670n(:,:,:) = 0._r8 + vnbcarr(:,:) =0.0_r8 + vaitbcarr(:,:) =0.0_r8 + cknorm(:,:,:) =0.0_r8 + + !-------------------------------------- + ! AeroCom diagnostics requiring table look-ups with ambient RH. + !-------------------------------------- + + do irf=0,0 + call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana, & + bebglt1, bebggt1, bebclt1, bebcgt1, & + beoclt1, beocgt1, bes4lt1, bes4gt1, & + bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & + beoclt1n, beocgt1n, bes4lt1n, bes4gt1n) + end do ! irf + + !-------------------------------------- + + do k=1,pver + do icol=1,ncol + + bebglt1t(icol,k)=0.0_r8 + bebggt1t(icol,k)=0.0_r8 + bebclt1t(icol,k)=0.0_r8 + bebcgt1t(icol,k)=0.0_r8 + beoclt1t(icol,k)=0.0_r8 + beocgt1t(icol,k)=0.0_r8 + bes4lt1t(icol,k)=0.0_r8 + bes4gt1t(icol,k)=0.0_r8 + bedustlt1(icol,k)=0.0_r8 + bedustgt1(icol,k)=0.0_r8 + besslt1(icol,k)=0.0_r8 + bessgt1(icol,k)=0.0_r8 + + bext440tot(icol,k)=0.0_r8 + babs440tot(icol,k)=0.0_r8 + bext500tot(icol,k)=0.0_r8 + babs500tot(icol,k)=0.0_r8 + bext550tot(icol,k)=0.0_r8 + babs550tot(icol,k)=0.0_r8 + bext670tot(icol,k)=0.0_r8 + babs670tot(icol,k)=0.0_r8 + bext870tot(icol,k)=0.0_r8 + babs870tot(icol,k)=0.0_r8 + + backsc550tot(icol,k)=0.0_r8 + + bebg440tot(icol,k)=0.0_r8 + bebg500tot(icol,k)=0.0_r8 + bebg550tot(icol,k)=0.0_r8 + babg550tot(icol,k)=0.0_r8 + bebg670tot(icol,k)=0.0_r8 + bebg870tot(icol,k)=0.0_r8 + + bebc440tot(icol,k)=0.0_r8 + bebc500tot(icol,k)=0.0_r8 + bebc550tot(icol,k)=0.0_r8 + babc550tot(icol,k)=0.0_r8 + bebc670tot(icol,k)=0.0_r8 + bebc870tot(icol,k)=0.0_r8 + + beoc440tot(icol,k)=0.0_r8 + beoc500tot(icol,k)=0.0_r8 + beoc550tot(icol,k)=0.0_r8 + baoc550tot(icol,k)=0.0_r8 + beoc670tot(icol,k)=0.0_r8 + beoc870tot(icol,k)=0.0_r8 + + besu440tot(icol,k)=0.0_r8 + besu500tot(icol,k)=0.0_r8 + besu550tot(icol,k)=0.0_r8 + basu550tot(icol,k)=0.0_r8 + besu670tot(icol,k)=0.0_r8 + besu870tot(icol,k)=0.0_r8 + + enddo + enddo + + do i=0,nbmodes + do k=1,pver do icol=1,ncol -! total internal extinction and absorption for 0.44, 0.50, 0.55, 0.68 and 0.87 um - bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*bext440(icol,k,i) - babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i) - bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*bext500(icol,k,i) - babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i) - bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*bext550(icol,k,i) - babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i) - bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*bext670(icol,k,i) - babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i) - bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*bext870(icol,k,i) - babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i) - backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*backsc550(icol,k,i) -! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um -! for the whole background aerosol (icluding SO4,BC, and OC for modes 0-5) - bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*bebg440(icol,k,i) -! babg440tot(icol,k)=babg440tot(icol,k)+Nnatk(icol,k,i)*babg440(icol,k,i) - bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*bebg500(icol,k,i) -! babg500tot(icol,k)=babg500tot(icol,k)+Nnatk(icol,k,i)*babg500(icol,k,i) - bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*bebg550(icol,k,i) - babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*babg550(icol,k,i) - bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*bebg670(icol,k,i) -! babg670tot(icol,k)=babg670tot(icol,k)+Nnatk(icol,k,i)*babg670(icol,k,i) - bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*bebg870(icol,k,i) -! babg870tot(icol,k)=babg870tot(icol,k)+Nnatk(icol,k,i)*babg870(icol,k,i) -! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um -! for each added (internally mixed through Aq./cond./coag.) component (SO4,BC,OC). -! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: - besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*besu440(icol,k,i) -! basu440tot(icol,k)=basu440tot(icol,k)+Nnatk(icol,k,i)*basu440(icol,k,i) - besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*besu500(icol,k,i) -! basu500tot(icol,k)=basu500tot(icol,k)+Nnatk(icol,k,i)*basu500(icol,k,i) - besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*besu550(icol,k,i) - basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*basu550(icol,k,i) - besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*besu670(icol,k,i) -! basu670tot(icol,k)=basu670tot(icol,k)+Nnatk(icol,k,i)*basu670(icol,k,i) - besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*besu870(icol,k,i) -! basu870tot(icol,k)=basu870tot(icol,k)+Nnatk(icol,k,i)*basu870(icol,k,i) -! -! Condensed OC on modes 1-4 and coagulated BC and OC on modes 5-10: - if(i>=1) then - bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i)*bebc440(icol,k,i) -! babc440tot(icol,k)=babc440tot(icol,k)+Nnatk(icol,k,i)*babc440(icol,k,i) - bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i)*bebc500(icol,k,i) -! babc500tot(icol,k)=babc500tot(icol,k)+Nnatk(icol,k,i)*babc500(icol,k,i) - bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i)*bebc550(icol,k,i) - babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i)*babc550(icol,k,i) - bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i)*bebc670(icol,k,i) -! babc670tot(icol,k)=babc670tot(icol,k)+Nnatk(icol,k,i)*babc670(icol,k,i) - bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i)*bebc870(icol,k,i) -! babc870tot(icol,k)=babc870tot(icol,k)+Nnatk(icol,k,i)*babc870(icol,k,i) - beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i)*beoc440(icol,k,i) -! baoc440tot(icol,k)=baoc440tot(icol,k)+Nnatk(icol,k,i)*baoc440(icol,k,i) - beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i)*beoc500(icol,k,i) -! baoc500tot(icol,k)=baoc500tot(icol,k)+Nnatk(icol,k,i)*baoc500(icol,k,i) - beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i)*beoc550(icol,k,i) - baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i)*baoc550(icol,k,i) - beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i)*beoc670(icol,k,i) -! baoc670tot(icol,k)=baoc670tot(icol,k)+Nnatk(icol,k,i)*baoc670(icol,k,i) - beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i)*beoc870(icol,k,i) -! baoc870tot(icol,k)=baoc870tot(icol,k)+Nnatk(icol,k,i)*baoc870(icol,k,i) - endif ! i>=1 - if(i==6.or.i==7) then - bedustlt1(icol,k)=bedustlt1(icol,k) & - +Nnatk(icol,k,i)*bebglt1(icol,k,i) - bedustgt1(icol,k)=bedustgt1(icol,k) & - +Nnatk(icol,k,i)*bebggt1(icol,k,i) - elseif(i>=8.and.i<=10) then - besslt1(icol,k)=besslt1(icol,k) & - +Nnatk(icol,k,i)*bebglt1(icol,k,i) - bessgt1(icol,k)=bessgt1(icol,k) & - +Nnatk(icol,k,i)*bebggt1(icol,k,i) - endif -! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: - bes4lt1t(icol,k)=bes4lt1t(icol,k) & - +Nnatk(icol,k,i)*bes4lt1(icol,k,i) - bes4gt1t(icol,k)=bes4gt1t(icol,k) & - +Nnatk(icol,k,i)*bes4gt1(icol,k,i) -! Condensed OC on mode 1 and coagulated BC and OC on modes 5-10: - if(i>=1) then - bebclt1t(icol,k)=bebclt1t(icol,k) & - +Nnatk(icol,k,i)*bebclt1(icol,k,i) - bebcgt1t(icol,k)=bebcgt1t(icol,k) & - +Nnatk(icol,k,i)*bebcgt1(icol,k,i) - beoclt1t(icol,k)=beoclt1t(icol,k) & - +Nnatk(icol,k,i)*beoclt1(icol,k,i) - beocgt1t(icol,k)=beocgt1t(icol,k) & - +Nnatk(icol,k,i)*beocgt1(icol,k,i) - endif ! i>=1 + ! total internal extinction and absorption for 0.44, 0.50, 0.55, 0.68 and 0.87 um + bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*bext440(icol,k,i) + babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i) + bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*bext500(icol,k,i) + babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i) + bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*bext550(icol,k,i) + babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i) + bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*bext670(icol,k,i) + babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i) + bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*bext870(icol,k,i) + babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i) + backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*backsc550(icol,k,i) + + ! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um + ! for the whole background aerosol (icluding SO4,BC, and OC for modes 0-5) + bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*bebg440(icol,k,i) + bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*bebg500(icol,k,i) + bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*bebg550(icol,k,i) + babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*babg550(icol,k,i) + bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*bebg670(icol,k,i) + bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*bebg870(icol,k,i) + + ! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um + ! for each added (internally mixed through Aq./cond./coag.) component (SO4,BC,OC). + ! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: + besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*besu440(icol,k,i) + besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*besu500(icol,k,i) + besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*besu550(icol,k,i) + basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*basu550(icol,k,i) + besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*besu670(icol,k,i) + besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*besu870(icol,k,i) + ! + ! Condensed OC on modes 1-4 and coagulated BC and OC on modes 5-10: + if(i>=1) then + bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc440(icol,k,i) + bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc500(icol,k,i) + bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc550(icol,k,i) + babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%babc550(icol,k,i) + bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc670(icol,k,i) + bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc870(icol,k,i) + beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc440(icol,k,i) + beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc500(icol,k,i) + beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc550(icol,k,i) + baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%baoc550(icol,k,i) + beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc670(icol,k,i) + beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc870(icol,k,i) + endif ! i>=1 + if(i==6.or.i==7) then + bedustlt1(icol,k)=bedustlt1(icol,k) + Nnatk(icol,k,i) * bebglt1(icol,k,i) + bedustgt1(icol,k)=bedustgt1(icol,k) + Nnatk(icol,k,i) * bebggt1(icol,k,i) + elseif(i>=8.and.i<=10) then + besslt1(icol,k)=besslt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) + bessgt1(icol,k)=bessgt1(icol,k) + Nnatk(icol,k,i)*bebggt1(icol,k,i) + endif + ! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: + bes4lt1t(icol,k)=bes4lt1t(icol,k) & + +Nnatk(icol,k,i)*bes4lt1(icol,k,i) + bes4gt1t(icol,k)=bes4gt1t(icol,k) & + +Nnatk(icol,k,i)*bes4gt1(icol,k,i) + ! Condensed OC on mode 1 and coagulated BC and OC on modes 5-10: + if(i>=1) then + bebclt1t(icol,k)=bebclt1t(icol,k) & + +Nnatk(icol,k,i)*bebclt1(icol,k,i) + bebcgt1t(icol,k)=bebcgt1t(icol,k) & + +Nnatk(icol,k,i)*bebcgt1(icol,k,i) + beoclt1t(icol,k)=beoclt1t(icol,k) & + +Nnatk(icol,k,i)*beoclt1(icol,k,i) + beocgt1t(icol,k)=beocgt1t(icol,k) & + +Nnatk(icol,k,i)*beocgt1(icol,k,i) + endif ! i>=1 end do ! icol - enddo ! k - enddo ! i + enddo ! k + enddo ! i -! extinction/absorptions (km-1) for each background component -! in the internal mixture are - do k=1,pver - do icol=1,ncol - bint440du(icol,k)=Nnatk(icol,k,6)*bebg440(icol,k,6) & - +Nnatk(icol,k,7)*bebg440(icol,k,7) - bint500du(icol,k)=Nnatk(icol,k,6)*bebg500(icol,k,6) & - +Nnatk(icol,k,7)*bebg500(icol,k,7) - bint550du(icol,k)=Nnatk(icol,k,6)*bebg550(icol,k,6) & - +Nnatk(icol,k,7)*bebg550(icol,k,7) - bint670du(icol,k)=Nnatk(icol,k,6)*bebg670(icol,k,6) & - +Nnatk(icol,k,7)*bebg670(icol,k,7) - bint870du(icol,k)=Nnatk(icol,k,6)*bebg870(icol,k,6) & - +Nnatk(icol,k,7)*bebg870(icol,k,7) - bint440ss(icol,k)=Nnatk(icol,k,8)*bebg440(icol,k,8) & - +Nnatk(icol,k,9)*bebg440(icol,k,9) & - +Nnatk(icol,k,10)*bebg440(icol,k,10) - bint500ss(icol,k)=Nnatk(icol,k,8)*bebg500(icol,k,8) & - +Nnatk(icol,k,9)*bebg500(icol,k,9) & - +Nnatk(icol,k,10)*bebg500(icol,k,10) - bint550ss(icol,k)=Nnatk(icol,k,8)*bebg550(icol,k,8) & - +Nnatk(icol,k,9)*bebg550(icol,k,9) & - +Nnatk(icol,k,10)*bebg550(icol,k,10) - bint670ss(icol,k)=Nnatk(icol,k,8)*bebg670(icol,k,8) & - +Nnatk(icol,k,9)*bebg670(icol,k,9) & - +Nnatk(icol,k,10)*bebg670(icol,k,10) - bint870ss(icol,k)=Nnatk(icol,k,8)*bebg870(icol,k,8) & - +Nnatk(icol,k,9)*bebg870(icol,k,9) & - +Nnatk(icol,k,10)*bebg870(icol,k,10) - baint550du(icol,k)=Nnatk(icol,k,6)*babg550(icol,k,6) & - +Nnatk(icol,k,7)*babg550(icol,k,7) - baint550ss(icol,k)=Nnatk(icol,k,8)*babg550(icol,k,8) & - +Nnatk(icol,k,9)*babg550(icol,k,9) & - +Nnatk(icol,k,10)*babg550(icol,k,10) - end do - enddo + ! extinction/absorptions (km-1) for each background component + ! in the internal mixture are + do k=1,pver + do icol=1,ncol + bint440du(icol,k)=Nnatk(icol,k,6)*bebg440(icol,k,6) & + +Nnatk(icol,k,7)*bebg440(icol,k,7) + bint500du(icol,k)=Nnatk(icol,k,6)*bebg500(icol,k,6) & + +Nnatk(icol,k,7)*bebg500(icol,k,7) + bint550du(icol,k)=Nnatk(icol,k,6)*bebg550(icol,k,6) & + +Nnatk(icol,k,7)*bebg550(icol,k,7) + bint670du(icol,k)=Nnatk(icol,k,6)*bebg670(icol,k,6) & + +Nnatk(icol,k,7)*bebg670(icol,k,7) + bint870du(icol,k)=Nnatk(icol,k,6)*bebg870(icol,k,6) & + +Nnatk(icol,k,7)*bebg870(icol,k,7) + bint440ss(icol,k)=Nnatk(icol,k,8)*bebg440(icol,k,8) & + +Nnatk(icol,k,9)*bebg440(icol,k,9) & + +Nnatk(icol,k,10)*bebg440(icol,k,10) + bint500ss(icol,k)=Nnatk(icol,k,8)*bebg500(icol,k,8) & + +Nnatk(icol,k,9)*bebg500(icol,k,9) & + +Nnatk(icol,k,10)*bebg500(icol,k,10) + bint550ss(icol,k)=Nnatk(icol,k,8)*bebg550(icol,k,8) & + +Nnatk(icol,k,9)*bebg550(icol,k,9) & + +Nnatk(icol,k,10)*bebg550(icol,k,10) + bint670ss(icol,k)=Nnatk(icol,k,8)*bebg670(icol,k,8) & + +Nnatk(icol,k,9)*bebg670(icol,k,9) & + +Nnatk(icol,k,10)*bebg670(icol,k,10) + bint870ss(icol,k)=Nnatk(icol,k,8)*bebg870(icol,k,8) & + +Nnatk(icol,k,9)*bebg870(icol,k,9) & + +Nnatk(icol,k,10)*bebg870(icol,k,10) + baint550du(icol,k)=Nnatk(icol,k,6)*babg550(icol,k,6) & + +Nnatk(icol,k,7)*babg550(icol,k,7) + baint550ss(icol,k)=Nnatk(icol,k,8)*babg550(icol,k,8) & + +Nnatk(icol,k,9)*babg550(icol,k,9) & + +Nnatk(icol,k,10)*babg550(icol,k,10) + end do + enddo - do i=11,14 + do i=11,14 do k=1,pver - do icol=1,ncol - be440x(icol,k,i)=bext440n(icol,k,i-10) - ba440x(icol,k,i)=babs440n(icol,k,i-10) - be500x(icol,k,i)=bext500n(icol,k,i-10) - ba500x(icol,k,i)=babs500n(icol,k,i-10) - be550x(icol,k,i)=bext550n(icol,k,i-10) - ba550x(icol,k,i)=babs550n(icol,k,i-10) - be670x(icol,k,i)=bext670n(icol,k,i-10) - ba670x(icol,k,i)=babs670n(icol,k,i-10) - be870x(icol,k,i)=bext870n(icol,k,i-10) - ba870x(icol,k,i)=babs870n(icol,k,i-10) - belt1x(icol,k,i)=bebglt1n(icol,k,i-10) - begt1x(icol,k,i)=bebggt1n(icol,k,i-10) - backsc550x(icol,k,i)=backsc550n(icol,k,i-10) - end do + do icol=1,ncol + be440x(icol,k,i)=bext440n(icol,k,i-10) + ba440x(icol,k,i)=babs440n(icol,k,i-10) + be500x(icol,k,i)=bext500n(icol,k,i-10) + ba500x(icol,k,i)=babs500n(icol,k,i-10) + be550x(icol,k,i)=bext550n(icol,k,i-10) + ba550x(icol,k,i)=babs550n(icol,k,i-10) + be670x(icol,k,i)=bext670n(icol,k,i-10) + ba670x(icol,k,i)=babs670n(icol,k,i-10) + be870x(icol,k,i)=bext870n(icol,k,i-10) + ba870x(icol,k,i)=babs870n(icol,k,i-10) + belt1x(icol,k,i)=bebglt1n(icol,k,i-10) + begt1x(icol,k,i)=bebggt1n(icol,k,i-10) + backsc550x(icol,k,i)=backsc550n(icol,k,i-10) + end do enddo - enddo + enddo -! The externally modes' contribution to extinction and absorption: - do k=1,pver - do icol=1,ncol + ! The externally modes' contribution to extinction and absorption: + do k=1,pver + do icol=1,ncol -!BC - vnbcarr(icol,k) = fnbc(icol,k)/(fnbc(icol,k) & - +(1.0_r8-fnbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) - vnbc = vnbcarr(icol,k) - bebc440xt(icol,k) =Nnatk(icol,k,12)*be440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) - babc440xt(icol,k) =Nnatk(icol,k,12)*ba440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) - bebc500xt(icol,k) =Nnatk(icol,k,12)*be500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) - babc500xt(icol,k) =Nnatk(icol,k,12)*ba500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) - bebc550xt(icol,k) =Nnatk(icol,k,12)*be550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) - babc550xt(icol,k) =Nnatk(icol,k,12)*ba550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) - bebc670xt(icol,k) =Nnatk(icol,k,12)*be670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) - babc670xt(icol,k) =Nnatk(icol,k,12)*ba670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) - bebc870xt(icol,k) =Nnatk(icol,k,12)*be870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) - babc870xt(icol,k) =Nnatk(icol,k,12)*ba870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) - bbclt1xt(icol,k)=Nnatk(icol,k,12)*belt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) - bbcgt1xt(icol,k)=Nnatk(icol,k,12)*begt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) -!OC - beoc440xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be440x(icol,k,14) - baoc440xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba440x(icol,k,14) - beoc500xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be500x(icol,k,14) - baoc500xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba500x(icol,k,14) - beoc550xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be550x(icol,k,14) - baoc550xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba550x(icol,k,14) - beoc670xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be670x(icol,k,14) - baoc670xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba670x(icol,k,14) - beoc870xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be870x(icol,k,14) - baoc870xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba870x(icol,k,14) - boclt1xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*belt1x(icol,k,14) - bocgt1xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*begt1x(icol,k,14) -! Total (for all modes) absorption optical depth and backscattering - abs550_aer(icol,k)=babs550tot(icol,k) & - +Nnatk(icol,k,12)*ba550x(icol,k,12) & - +Nnatk(icol,k,14)*ba550x(icol,k,14) - abs550_aer(icol,k)=1.e-3_r8*abs550_aer(icol,k) - bs550_aer(icol,k)= backsc550tot(icol,k) & - +Nnatk(icol,k,12)*backsc550x(icol,k,12) & - +Nnatk(icol,k,14)*backsc550x(icol,k,14) - bs550_aer(icol,k)=1.e-3_r8*bs550_aer(icol,k) -! - end do - enddo -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! collect AeroCom-fields for optical depth/absorption of each comp, -! 3D and 2D, at 440, 500, 550, 670 and 870 nm, for all d, d<1um and d>1um -! initialize 2d-fields - do icol=1,ncol - dod440(icol) = 0.0_r8 - abs440(icol) = 0.0_r8 - dod500(icol) = 0.0_r8 - abs500(icol) = 0.0_r8 - dod550(icol) = 0.0_r8 - abs550(icol) = 0.0_r8 - abs550alt(icol) = 0.0_r8 - dod670(icol) = 0.0_r8 - abs670(icol) = 0.0_r8 - dod870(icol) = 0.0_r8 - abs870(icol) = 0.0_r8 -! - abs550_ss(icol) = 0.0_r8 - abs550_dust(icol) = 0.0_r8 - abs550_so4(icol) = 0.0_r8 - abs550_bc(icol) = 0.0_r8 - abs550_pom(icol) = 0.0_r8 -! - dod440_ss(icol) = 0.0_r8 - dod440_dust(icol) = 0.0_r8 - dod440_so4(icol) = 0.0_r8 - dod440_bc(icol) = 0.0_r8 - dod440_pom(icol) = 0.0_r8 - dod500_ss(icol) = 0.0_r8 - dod500_dust(icol) = 0.0_r8 - dod500_so4(icol) = 0.0_r8 - dod500_bc(icol) = 0.0_r8 - dod500_pom(icol) = 0.0_r8 - dod550_ss(icol) = 0.0_r8 - dod550_dust(icol) = 0.0_r8 - dod550_so4(icol) = 0.0_r8 - dod550_bc(icol) = 0.0_r8 - dod550_pom(icol) = 0.0_r8 - dod670_ss(icol) = 0.0_r8 - dod670_dust(icol) = 0.0_r8 - dod670_so4(icol) = 0.0_r8 - dod670_bc(icol) = 0.0_r8 - dod670_pom(icol) = 0.0_r8 - dod870_ss(icol) = 0.0_r8 - dod870_dust(icol) = 0.0_r8 - dod870_so4(icol) = 0.0_r8 - dod870_bc(icol) = 0.0_r8 - dod870_pom(icol) = 0.0_r8 - dod550lt1_ss(icol) = 0.0_r8 - dod550gt1_ss(icol) = 0.0_r8 - dod550lt1_dust(icol) = 0.0_r8 - dod550gt1_dust(icol) = 0.0_r8 - dod550lt1_so4(icol) = 0.0_r8 - dod550gt1_so4(icol) = 0.0_r8 - dod550lt1_bc(icol) = 0.0_r8 - dod550gt1_bc(icol) = 0.0_r8 - dod550lt1_pom(icol) = 0.0_r8 - dod550gt1_pom(icol) = 0.0_r8 - do k=1,pver - abs4403d(icol,k) = 0.0_r8 - abs5003d(icol,k) = 0.0_r8 - abs5503d(icol,k) = 0.0_r8 - abs6703d(icol,k) = 0.0_r8 - abs8703d(icol,k) = 0.0_r8 - abs5503dalt(icol,k) = 0.0_r8 - enddo - enddo + !BC + vnbcarr(icol,k) = fnbc(icol,k)/(fnbc(icol,k) & + +(1.0_r8-fnbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) + vnbc = vnbcarr(icol,k) + bebc440xt(icol,k) =Nnatk(icol,k,12)*be440x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) + babc440xt(icol,k) =Nnatk(icol,k,12)*ba440x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) + bebc500xt(icol,k) =Nnatk(icol,k,12)*be500x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) + babc500xt(icol,k) =Nnatk(icol,k,12)*ba500x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) + bebc550xt(icol,k) =Nnatk(icol,k,12)*be550x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) + babc550xt(icol,k) =Nnatk(icol,k,12)*ba550x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) + bebc670xt(icol,k) =Nnatk(icol,k,12)*be670x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) + babc670xt(icol,k) =Nnatk(icol,k,12)*ba670x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) + bebc870xt(icol,k) =Nnatk(icol,k,12)*be870x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) + babc870xt(icol,k) =Nnatk(icol,k,12)*ba870x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) + bbclt1xt(icol,k)=Nnatk(icol,k,12)*belt1x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) + bbcgt1xt(icol,k)=Nnatk(icol,k,12)*begt1x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) + !OC + beoc440xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be440x(icol,k,14) + baoc440xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba440x(icol,k,14) + beoc500xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be500x(icol,k,14) + baoc500xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba500x(icol,k,14) + beoc550xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be550x(icol,k,14) + baoc550xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba550x(icol,k,14) + beoc670xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be670x(icol,k,14) + baoc670xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba670x(icol,k,14) + beoc870xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be870x(icol,k,14) + baoc870xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba870x(icol,k,14) + boclt1xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*belt1x(icol,k,14) + bocgt1xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*begt1x(icol,k,14) + ! Total (for all modes) absorption optical depth and backscattering + abs550_aer(icol,k)=babs550tot(icol,k) & + +Nnatk(icol,k,12)*ba550x(icol,k,12) & + +Nnatk(icol,k,14)*ba550x(icol,k,14) + abs550_aer(icol,k)=1.e-3_r8*abs550_aer(icol,k) + bs550_aer(icol,k)= backsc550tot(icol,k) & + +Nnatk(icol,k,12)*backsc550x(icol,k,12) & + +Nnatk(icol,k,14)*backsc550x(icol,k,14) + bs550_aer(icol,k)=1.e-3_r8*bs550_aer(icol,k) + ! + end do + enddo + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! collect AeroCom-fields for optical depth/absorption of each comp, + ! 3D and 2D, at 440, 500, 550, 670 and 870 nm, for all d, d<1um and d>1um + ! initialize 2d-fields + do icol=1,ncol + dod440(icol) = 0.0_r8 + abs440(icol) = 0.0_r8 + dod500(icol) = 0.0_r8 + abs500(icol) = 0.0_r8 + dod550(icol) = 0.0_r8 + abs550(icol) = 0.0_r8 + abs550alt(icol) = 0.0_r8 + dod670(icol) = 0.0_r8 + abs670(icol) = 0.0_r8 + dod870(icol) = 0.0_r8 + abs870(icol) = 0.0_r8 + ! + abs550_ss(icol) = 0.0_r8 + abs550_dust(icol) = 0.0_r8 + abs550_so4(icol) = 0.0_r8 + abs550_bc(icol) = 0.0_r8 + abs550_pom(icol) = 0.0_r8 + ! + dod440_ss(icol) = 0.0_r8 + dod440_dust(icol) = 0.0_r8 + dod440_so4(icol) = 0.0_r8 + dod440_bc(icol) = 0.0_r8 + dod440_pom(icol) = 0.0_r8 + dod500_ss(icol) = 0.0_r8 + dod500_dust(icol) = 0.0_r8 + dod500_so4(icol) = 0.0_r8 + dod500_bc(icol) = 0.0_r8 + dod500_pom(icol) = 0.0_r8 + dod550_ss(icol) = 0.0_r8 + dod550_dust(icol) = 0.0_r8 + dod550_so4(icol) = 0.0_r8 + dod550_bc(icol) = 0.0_r8 + dod550_pom(icol) = 0.0_r8 + dod670_ss(icol) = 0.0_r8 + dod670_dust(icol) = 0.0_r8 + dod670_so4(icol) = 0.0_r8 + dod670_bc(icol) = 0.0_r8 + dod670_pom(icol) = 0.0_r8 + dod870_ss(icol) = 0.0_r8 + dod870_dust(icol) = 0.0_r8 + dod870_so4(icol) = 0.0_r8 + dod870_bc(icol) = 0.0_r8 + dod870_pom(icol) = 0.0_r8 + dod550lt1_ss(icol) = 0.0_r8 + dod550gt1_ss(icol) = 0.0_r8 + dod550lt1_dust(icol) = 0.0_r8 + dod550gt1_dust(icol) = 0.0_r8 + dod550lt1_so4(icol) = 0.0_r8 + dod550gt1_so4(icol) = 0.0_r8 + dod550lt1_bc(icol) = 0.0_r8 + dod550gt1_bc(icol) = 0.0_r8 + dod550lt1_pom(icol) = 0.0_r8 + dod550gt1_pom(icol) = 0.0_r8 + do k=1,pver + abs4403d(icol,k) = 0.0_r8 + abs5003d(icol,k) = 0.0_r8 + abs5503d(icol,k) = 0.0_r8 + abs6703d(icol,k) = 0.0_r8 + abs8703d(icol,k) = 0.0_r8 + abs5503dalt(icol,k) = 0.0_r8 + enddo + enddo - do icol=1,ncol - do k=1,pver -! Layer thickness, unit km - deltah=deltah_km(icol,k) -! if(k==pver) write(*,*) 'icol, deltah(pmxsub)=', icol, deltah -! 3D optical depths for monthly averages -!SS - dod4403d_ss(icol,k) = bint440ss(icol,k)*deltah - dod5003d_ss(icol,k) = bint500ss(icol,k)*deltah - dod5503d_ss(icol,k) = bint550ss(icol,k)*deltah - abs5503d_ss(icol,k) = baint550ss(icol,k)*deltah - dod6703d_ss(icol,k) = bint670ss(icol,k)*deltah - dod8703d_ss(icol,k) = bint870ss(icol,k)*deltah -!DUST - dod4403d_dust(icol,k) = bint440du(icol,k)*deltah - dod5003d_dust(icol,k) = bint500du(icol,k)*deltah - dod5503d_dust(icol,k) = bint550du(icol,k)*deltah - abs5503d_dust(icol,k) = baint550du(icol,k)*deltah - dod6703d_dust(icol,k) = bint670du(icol,k)*deltah - dod8703d_dust(icol,k) = bint870du(icol,k)*deltah -!SO4 -!soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - dod4403d_so4(icol,k) = (besu440tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5003d_so4(icol,k) = (besu500tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5503d_so4(icol,k) = (besu550tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - abs5503d_so4(icol,k) = (basu550tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod6703d_so4(icol,k) = (besu670tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod8703d_so4(icol,k) = (besu870tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) -!BC - vaitbcarr(icol,k) = faitbc(icol,k)/(faitbc(icol,k) & - +(1.0_r8-faitbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) - vaitbc = vaitbcarr(icol,k) - dod4403d_bc(icol,k) = (bebc440tot(icol,k)+bebc440xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg440(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5003d_bc(icol,k) = (bebc500tot(icol,k)+bebc500xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg500(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5503d_bc(icol,k) = (bebc550tot(icol,k)+bebc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) - abs5503d_bc(icol,k) = (babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*babg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod6703d_bc(icol,k) = (bebc670tot(icol,k)+bebc670xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg670(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod8703d_bc(icol,k) = (bebc870tot(icol,k)+bebc870xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg870(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) -!OC -!soa + v_soana part of mode 11 for the OC volume fraction of that mode -! v_soana(icol,k) - dod4403d_pom(icol,k) = (beoc440tot(icol,k)+beoc440xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 -!-3 + Nnatk(icol,k,3)*bebg440(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg440(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5003d_pom(icol,k) = (beoc500tot(icol,k)+beoc500xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 -!-3 + Nnatk(icol,k,3)*bebg500(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg500(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5503d_pom(icol,k) = (beoc550tot(icol,k)+beoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 -!-3 + Nnatk(icol,k,3)*bebg550(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - abs5503d_pom(icol,k) = (baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 -!-3 + Nnatk(icol,k,3)*babg550(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*babg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod6703d_pom(icol,k) = (beoc670tot(icol,k)+beoc670xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 -!-3 + Nnatk(icol,k,3)*bebg670(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg670(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod8703d_pom(icol,k) = (beoc870tot(icol,k)+beoc870xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 -!-3 + Nnatk(icol,k,3)*bebg870(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg870(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - - ec550_so4(icol,k) = 1.e-3*dod5503d_so4(icol,k)/deltah - ec550_bc(icol,k) = 1.e-3*dod5503d_bc(icol,k)/deltah - ec550_pom(icol,k) = 1.e-3*dod5503d_pom(icol,k)/deltah - ec550_ss(icol,k) = 1.e-3*dod5503d_ss(icol,k)/deltah - ec550_du(icol,k) = 1.e-3*dod5503d_dust(icol,k)/deltah - ec550_aer(icol,k) = ec550_so4(icol,k)+ec550_bc(icol,k)+ec550_pom(icol,k) & - + ec550_ss(icol,k)+ec550_du(icol,k) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! Total 3D optical depths/abs. for column integrations - dod4403d(icol,k) = dod4403d_ss(icol,k)+dod4403d_dust(icol,k) & - +dod4403d_so4(icol,k)+dod4403d_bc(icol,k) & - +dod4403d_pom(icol,k) - dod5003d(icol,k) = dod5003d_ss(icol,k)+dod5003d_dust(icol,k) & - +dod5003d_so4(icol,k)+dod5003d_bc(icol,k) & - +dod5003d_pom(icol,k) - dod5503d(icol,k) = dod5503d_ss(icol,k)+dod5503d_dust(icol,k) & - +dod5503d_so4(icol,k)+dod5503d_bc(icol,k) & - +dod5503d_pom(icol,k) - dod6703d(icol,k) = dod6703d_ss(icol,k)+dod6703d_dust(icol,k) & - +dod6703d_so4(icol,k)+dod6703d_bc(icol,k) & - +dod6703d_pom(icol,k) - dod8703d(icol,k) = dod8703d_ss(icol,k)+dod8703d_dust(icol,k) & - +dod8703d_so4(icol,k)+dod8703d_bc(icol,k) & - +dod8703d_pom(icol,k) - abs5503d(icol,k) = abs5503d_ss(icol,k)+abs5503d_dust(icol,k) & - +abs5503d_so4(icol,k)+abs5503d_bc(icol,k) & - +abs5503d_pom(icol,k) -! (Note: Local abs550alt is up to 6% larger (annually averaged) in typical b.b. -! regions, compared to abs550. This is most likely most correct, but should be checked!) - do i=0,10 + do icol=1,ncol + do k=1,pver + ! Layer thickness, unit km + deltah=deltah_km(icol,k) + ! if(k==pver) write(*,*) 'icol, deltah(pmxsub)=', icol, deltah + ! 3D optical depths for monthly averages + !SS + dod4403d_ss(icol,k) = bint440ss(icol,k)*deltah + dod5003d_ss(icol,k) = bint500ss(icol,k)*deltah + dod5503d_ss(icol,k) = bint550ss(icol,k)*deltah + abs5503d_ss(icol,k) = baint550ss(icol,k)*deltah + dod6703d_ss(icol,k) = bint670ss(icol,k)*deltah + dod8703d_ss(icol,k) = bint870ss(icol,k)*deltah + !DUST + dod4403d_dust(icol,k) = bint440du(icol,k)*deltah + dod5003d_dust(icol,k) = bint500du(icol,k)*deltah + dod5503d_dust(icol,k) = bint550du(icol,k)*deltah + abs5503d_dust(icol,k) = baint550du(icol,k)*deltah + dod6703d_dust(icol,k) = bint670du(icol,k)*deltah + dod8703d_dust(icol,k) = bint870du(icol,k)*deltah + !SO4 + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + dod4403d_so4(icol,k) = (besu440tot(icol,k) & ! condensate ) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5003d_so4(icol,k) = (besu500tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5503d_so4(icol,k) = (besu550tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + abs5503d_so4(icol,k) = (basu550tot(icol,k) & ! condensate ) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod6703d_so4(icol,k) = (besu670tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod8703d_so4(icol,k) = (besu870tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + !BC + vaitbcarr(icol,k) = faitbc(icol,k)/(faitbc(icol,k) & + +(1.0_r8-faitbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) + vaitbc = vaitbcarr(icol,k) + dod4403d_bc(icol,k) = (bebc440tot(icol,k)+bebc440xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg440(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5003d_bc(icol,k) = (bebc500tot(icol,k)+bebc500xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg500(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5503d_bc(icol,k) = (bebc550tot(icol,k)+bebc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + abs5503d_bc(icol,k) = (babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*babg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod6703d_bc(icol,k) = (bebc670tot(icol,k)+bebc670xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg670(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod8703d_bc(icol,k) = (bebc870tot(icol,k)+bebc870xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg870(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) + !OC + !soa + v_soana part of mode 11 for the OC volume fraction of that mode + ! v_soana(icol,k) + dod4403d_pom(icol,k) = (beoc440tot(icol,k)+beoc440xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg440(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) + dod5003d_pom(icol,k) = (beoc500tot(icol,k)+beoc500xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg500(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) + dod5503d_pom(icol,k) = (beoc550tot(icol,k)+beoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg550(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) + abs5503d_pom(icol,k) = (baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*babg550(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) + dod6703d_pom(icol,k) = (beoc670tot(icol,k)+beoc670xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg670(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) + dod8703d_pom(icol,k) = (beoc870tot(icol,k)+beoc870xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg870(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) + + ec550_so4(icol,k) = 1.e-3*dod5503d_so4(icol,k)/deltah + ec550_bc(icol,k) = 1.e-3*dod5503d_bc(icol,k)/deltah + ec550_pom(icol,k) = 1.e-3*dod5503d_pom(icol,k)/deltah + ec550_ss(icol,k) = 1.e-3*dod5503d_ss(icol,k)/deltah + ec550_du(icol,k) = 1.e-3*dod5503d_dust(icol,k)/deltah + ec550_aer(icol,k) = ec550_so4(icol,k)+ec550_bc(icol,k)+ec550_pom(icol,k) & + + ec550_ss(icol,k) +ec550_du(icol,k) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! Total 3D optical depths/abs. for column integrations + dod4403d(icol,k) = dod4403d_ss(icol,k)+dod4403d_dust(icol,k) & + +dod4403d_so4(icol,k)+dod4403d_bc(icol,k) & + +dod4403d_pom(icol,k) + dod5003d(icol,k) = dod5003d_ss(icol,k)+dod5003d_dust(icol,k) & + +dod5003d_so4(icol,k)+dod5003d_bc(icol,k) & + +dod5003d_pom(icol,k) + dod5503d(icol,k) = dod5503d_ss(icol,k)+dod5503d_dust(icol,k) & + +dod5503d_so4(icol,k)+dod5503d_bc(icol,k) & + +dod5503d_pom(icol,k) + dod6703d(icol,k) = dod6703d_ss(icol,k)+dod6703d_dust(icol,k) & + +dod6703d_so4(icol,k)+dod6703d_bc(icol,k) & + +dod6703d_pom(icol,k) + dod8703d(icol,k) = dod8703d_ss(icol,k)+dod8703d_dust(icol,k) & + +dod8703d_so4(icol,k)+dod8703d_bc(icol,k) & + +dod8703d_pom(icol,k) + abs5503d(icol,k) = abs5503d_ss(icol,k)+abs5503d_dust(icol,k) & + +abs5503d_so4(icol,k)+abs5503d_bc(icol,k) & + +abs5503d_pom(icol,k) + ! (Note: Local abs550alt is up to 6% larger (annually averaged) in typical b.b. + ! regions, compared to abs550. This is most likely most correct, but should be checked!) + do i=0,10 abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i)*deltah abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i)*deltah abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i)*deltah abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i)*deltah abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i)*deltah - enddo - do i=11,14 + enddo + do i=11,14 abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440n(icol,k,i-10)*deltah abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500n(icol,k,i-10)*deltah abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670n(icol,k,i-10)*deltah abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870n(icol,k,i-10)*deltah abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550n(icol,k,i-10)*deltah - enddo -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! optical depths for d<1um and d>1um (r<0.5um and r>0.5um) -!SS - dod5503dlt1_ss(icol,k) = besslt1(icol,k)*deltah - dod5503dgt1_ss(icol,k) = bessgt1(icol,k)*deltah -!DUST - dod5503dlt1_dust(icol,k) = bedustlt1(icol,k)*deltah - dod5503dgt1_dust(icol,k) = bedustgt1(icol,k)*deltah - -!soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - dod5503dlt1_so4(icol,k) = (bes4lt1t(icol,k) & ! condensate - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebglt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5503dgt1_so4(icol,k) = (bes4gt1t(icol,k) & ! condensate + n-mode (11) - + Nnatk(icol,k,1)*bebggt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebggt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) -!BC - dod5503dlt1_bc(icol,k) = (bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebglt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebglt1(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5503dgt1_bc(icol,k) = (bebcgt1t(icol,k)+bbcgt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebggt1(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebggt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebggt1(icol,k,0))*deltah ! background, BC(ax) mode (0) -!OC -!soa + v_soana part of mode 11 for the OC volume fraction of that mode - dod5503dlt1_pom(icol,k) = (beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 -!-3 + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebglt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5503dgt1_pom(icol,k) = (beocgt1t(icol,k)+bocgt1xt(icol,k) & ! coagulated + n-mode OC&OC (14) - + Nnatk(icol,k,1)*bebggt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 -!-3 + Nnatk(icol,k,3)*bebggt1(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebggt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! Column integrated optical depths/abs., total and for each constituent - dod440(icol) = dod440(icol)+dod4403d(icol,k) - abs440(icol) = abs440(icol)+abs4403d(icol,k) - dod500(icol) = dod500(icol)+dod5003d(icol,k) - abs500(icol) = abs500(icol)+abs5003d(icol,k) - dod550(icol) = dod550(icol)+dod5503d(icol,k) - abs550(icol) = abs550(icol)+abs5503d(icol,k) - abs550alt(icol) = abs550alt(icol)+abs5503dalt(icol,k) - dod670(icol) = dod670(icol)+dod6703d(icol,k) - abs670(icol) = abs670(icol)+abs6703d(icol,k) - dod870(icol) = dod870(icol)+dod8703d(icol,k) - abs870(icol) = abs870(icol)+abs8703d(icol,k) -! Added abs components - abs550_ss(icol) = abs550_ss(icol)+abs5503d_ss(icol,k) - abs550_dust(icol) = abs550_dust(icol)+abs5503d_dust(icol,k) - abs550_so4(icol) = abs550_so4(icol)+abs5503d_so4(icol,k) - abs550_bc(icol) = abs550_bc(icol)+abs5503d_bc(icol,k) - abs550_pom(icol) = abs550_pom(icol)+abs5503d_pom(icol,k) -! - dod440_ss(icol) = dod440_ss(icol)+dod4403d_ss(icol,k) - dod440_dust(icol) = dod440_dust(icol)+dod4403d_dust(icol,k) - dod440_so4(icol) = dod440_so4(icol)+dod4403d_so4(icol,k) - dod440_bc(icol) = dod440_bc(icol)+dod4403d_bc(icol,k) - dod440_pom(icol) = dod440_pom(icol)+dod4403d_pom(icol,k) - dod500_ss(icol) = dod500_ss(icol)+dod5003d_ss(icol,k) - dod500_dust(icol) = dod500_dust(icol)+dod5003d_dust(icol,k) - dod500_so4(icol) = dod500_so4(icol)+dod5003d_so4(icol,k) - dod500_bc(icol) = dod500_bc(icol)+dod5003d_bc(icol,k) - dod500_pom(icol) = dod500_pom(icol)+dod5003d_pom(icol,k) - dod550_ss(icol) = dod550_ss(icol)+dod5503d_ss(icol,k) - dod550_dust(icol) = dod550_dust(icol)+dod5503d_dust(icol,k) - dod550_so4(icol) = dod550_so4(icol)+dod5503d_so4(icol,k) - dod550_bc(icol) = dod550_bc(icol)+dod5503d_bc(icol,k) - dod550_pom(icol) = dod550_pom(icol)+dod5503d_pom(icol,k) - dod670_ss(icol) = dod670_ss(icol)+dod6703d_ss(icol,k) - dod670_dust(icol) = dod670_dust(icol)+dod6703d_dust(icol,k) - dod670_so4(icol) = dod670_so4(icol)+dod6703d_so4(icol,k) - dod670_bc(icol) = dod670_bc(icol)+dod6703d_bc(icol,k) - dod670_pom(icol) = dod670_pom(icol)+dod6703d_pom(icol,k) - dod870_ss(icol) = dod870_ss(icol)+dod8703d_ss(icol,k) - dod870_dust(icol) = dod870_dust(icol)+dod8703d_dust(icol,k) - dod870_so4(icol) = dod870_so4(icol)+dod8703d_so4(icol,k) - dod870_bc(icol) = dod870_bc(icol)+dod8703d_bc(icol,k) - dod870_pom(icol) = dod870_pom(icol)+dod8703d_pom(icol,k) - dod550lt1_ss(icol) = dod550lt1_ss(icol)+dod5503dlt1_ss(icol,k) - dod550gt1_ss(icol) = dod550gt1_ss(icol)+dod5503dgt1_ss(icol,k) - dod550lt1_dust(icol) = dod550lt1_dust(icol)+dod5503dlt1_dust(icol,k) - dod550gt1_dust(icol) = dod550gt1_dust(icol)+dod5503dgt1_dust(icol,k) - dod550lt1_so4(icol) = dod550lt1_so4(icol)+dod5503dlt1_so4(icol,k) - dod550gt1_so4(icol) = dod550gt1_so4(icol)+dod5503dgt1_so4(icol,k) - dod550lt1_bc(icol) = dod550lt1_bc(icol)+dod5503dlt1_bc(icol,k) - dod550gt1_bc(icol) = dod550gt1_bc(icol)+dod5503dgt1_bc(icol,k) - dod550lt1_pom(icol) = dod550lt1_pom(icol)+dod5503dlt1_pom(icol,k) - dod550gt1_pom(icol) = dod550gt1_pom(icol)+dod5503dgt1_pom(icol,k) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - enddo ! k - - enddo ! icol - -! extinction, absorption (m-1) and backscatter coefficients (m-1 sr-1) - call outfld('EC550AER',ec550_aer,pcols,lchnk) - call outfld('ABS550_A',abs550_aer,pcols,lchnk) - call outfld('BS550AER',bs550_aer,pcols,lchnk) -! -! speciated extinction coefficients (m-1) - call outfld('EC550SO4',ec550_so4,pcols,lchnk) - call outfld('EC550BC ',ec550_bc ,pcols,lchnk) - call outfld('EC550POM',ec550_pom,pcols,lchnk) - call outfld('EC550SS ',ec550_ss ,pcols,lchnk) - call outfld('EC550DU ',ec550_du ,pcols,lchnk) -! -! optical depths and absorption as requested by AeroCom -! notation: 3=3D, D=DOD, A=ABS, LT=d<1um, GT=d>1um - call outfld('DOD440 ',dod440 ,pcols,lchnk) - call outfld('ABS440 ',abs440 ,pcols,lchnk) - call outfld('DOD500 ',dod500 ,pcols,lchnk) - call outfld('ABS500 ',abs500 ,pcols,lchnk) - call outfld('DOD550 ',dod550 ,pcols,lchnk) - call outfld('ABS550 ',abs550 ,pcols,lchnk) - call outfld('ABS550AL',abs550alt,pcols,lchnk) - call outfld('DOD670 ',dod670 ,pcols,lchnk) - call outfld('ABS670 ',abs670 ,pcols,lchnk) - call outfld('DOD870 ',dod870 ,pcols,lchnk) - call outfld('ABS870 ',abs870 ,pcols,lchnk) - call outfld('A550_SS ',abs550_ss ,pcols,lchnk) - call outfld('A550_DU ',abs550_dust,pcols,lchnk) - call outfld('A550_SO4',abs550_so4 ,pcols,lchnk) - call outfld('A550_BC ',abs550_bc ,pcols,lchnk) - call outfld('A550_POM',abs550_pom ,pcols,lchnk) -! - call outfld('D440_SS ',dod440_ss ,pcols,lchnk) - call outfld('D440_DU ',dod440_dust,pcols,lchnk) - call outfld('D440_SO4',dod440_so4 ,pcols,lchnk) - call outfld('D440_BC ',dod440_bc ,pcols,lchnk) - call outfld('D440_POM',dod440_pom ,pcols,lchnk) - call outfld('D500_SS ',dod500_ss ,pcols,lchnk) - call outfld('D500_DU ',dod500_dust,pcols,lchnk) - call outfld('D500_SO4',dod500_so4 ,pcols,lchnk) - call outfld('D500_BC ',dod500_bc ,pcols,lchnk) - call outfld('D500_POM',dod500_pom ,pcols,lchnk) - call outfld('D550_SS ',dod550_ss ,pcols,lchnk) - call outfld('D550_DU ',dod550_dust,pcols,lchnk) - call outfld('D550_SO4',dod550_so4 ,pcols,lchnk) - call outfld('D550_BC ',dod550_bc ,pcols,lchnk) - call outfld('D550_POM',dod550_pom ,pcols,lchnk) - call outfld('D670_SS ',dod670_ss ,pcols,lchnk) - call outfld('D670_DU ',dod670_dust,pcols,lchnk) - call outfld('D670_SO4',dod670_so4 ,pcols,lchnk) - call outfld('D670_BC ',dod670_bc ,pcols,lchnk) - call outfld('D670_POM',dod670_pom ,pcols,lchnk) - call outfld('D870_SS ',dod870_ss ,pcols,lchnk) - call outfld('D870_DU ',dod870_dust,pcols,lchnk) - call outfld('D870_SO4',dod870_so4 ,pcols,lchnk) - call outfld('D870_BC ',dod870_bc ,pcols,lchnk) - call outfld('D870_POM',dod870_pom ,pcols,lchnk) - call outfld('DLT_SS ',dod550lt1_ss,pcols,lchnk) - call outfld('DGT_SS ',dod550gt1_ss,pcols,lchnk) - call outfld('DLT_DUST',dod550lt1_dust,pcols,lchnk) - call outfld('DGT_DUST',dod550gt1_dust,pcols,lchnk) - call outfld('DLT_SO4 ',dod550lt1_so4,pcols,lchnk) - call outfld('DGT_SO4 ',dod550gt1_so4,pcols,lchnk) - call outfld('DLT_BC ',dod550lt1_bc,pcols,lchnk) - call outfld('DGT_BC ',dod550gt1_bc,pcols,lchnk) - call outfld('DLT_POM ',dod550lt1_pom,pcols,lchnk) - call outfld('DGT_POM ',dod550gt1_pom,pcols,lchnk) -!tst -! call outfld('DOD5503D',dod5503d,pcols,lchnk) -!tst -!- call outfld('ABS5503D',abs5503d,pcols,lchnk) -!- call outfld('D443_SS ',dod4403d_ss ,pcols,lchnk) -!- call outfld('D443_DU ',dod4403d_dust,pcols,lchnk) -!- call outfld('D443_SO4',dod4403d_so4 ,pcols,lchnk) -!- call outfld('D443_BC ',dod4403d_bc ,pcols,lchnk) -!- call outfld('D443_POM',dod4403d_pom ,pcols,lchnk) -!- call outfld('D503_SS ',dod5003d_ss ,pcols,lchnk) -!- call outfld('D503_DU ',dod5003d_dust,pcols,lchnk) -!- call outfld('D503_SO4',dod5003d_so4 ,pcols,lchnk) -!- call outfld('D503_BC ',dod5003d_bc ,pcols,lchnk) -!- call outfld('D503_POM',dod5003d_pom ,pcols,lchnk) -!- call outfld('D553_SS ',dod5503d_ss ,pcols,lchnk) -!- call outfld('D553_DU ',dod5503d_dust,pcols,lchnk) -!- call outfld('D553_SO4',dod5503d_so4 ,pcols,lchnk) -!- call outfld('D553_BC ',dod5503d_bc ,pcols,lchnk) -!- call outfld('D553_POM',dod5503d_pom ,pcols,lchnk) -!- call outfld('D673_SS ',dod6703d_ss ,pcols,lchnk) -!- call outfld('D673_DU ',dod6703d_dust,pcols,lchnk) -!- call outfld('D673_SO4',dod6703d_so4 ,pcols,lchnk) -!- call outfld('D673_BC ',dod6703d_bc ,pcols,lchnk) -!- call outfld('D673_POM',dod6703d_pom ,pcols,lchnk) -!- call outfld('D873_SS ',dod8703d_ss ,pcols,lchnk) -!- call outfld('D873_DU ',dod8703d_dust,pcols,lchnk) -!- call outfld('D873_SO4',dod8703d_so4 ,pcols,lchnk) -!- call outfld('D873_BC ',dod8703d_bc ,pcols,lchnk) -!- call outfld('D873_POM',dod8703d_pom ,pcols,lchnk) - - -!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - -! Dry parameters of each aerosol component -! BC(ax) mode - call intdrypar0(lchnk, ncol, Nnatk, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - cknorm,cknlt05,ckngt125) -! SO4&SOA(Ait,n) mode - call intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, & - xct, ict1, xfac, ifac1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) -! BC(Ait,n) and OC(Ait,n) modes - call intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) -! BC&OC(Ait,n) mode ------ fcm not valid here (=0). Use faitbc or fnbc instead - call intdrypar4(lchnk, ncol, Nnatk, & - xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & - xct, ict1, xfac, ifac1, xfaq, ifaq1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & - aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) -! SO4(Ait75) (5), mineral (6-7) and Sea-salt (8-10) modes: - call intdrypar5to10(lchnk, ncol, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - cknorm,cknlt05,ckngt125) - - do k=1,pver - do icol=1,ncol - c_ss(icol,k)=0.0_r8 - c_mi(icol,k)=0.0_r8 - enddo - enddo - - do k=1,pver - do icol=1,ncol -! mineral and sea-salt background concentrations, internally mixed - c_mi(icol,k) = Nnatk(icol,k,6)*cintbg(icol,k,6) & - +Nnatk(icol,k,7)*cintbg(icol,k,7) - c_mi05(icol,k) = Nnatk(icol,k,6)*cintbg05(icol,k,6) & - +Nnatk(icol,k,7)*cintbg05(icol,k,7) - c_mi125(icol,k) = Nnatk(icol,k,6)*cintbg125(icol,k,6)& - +Nnatk(icol,k,7)*cintbg125(icol,k,7) - c_ss(icol,k) = Nnatk(icol,k,8)*cintbg(icol,k,8) & - +Nnatk(icol,k,9)*cintbg(icol,k,9) & - +Nnatk(icol,k,10)*cintbg(icol,k,10) - c_ss05(icol,k) = Nnatk(icol,k,8)*cintbg05(icol,k,8) & - +Nnatk(icol,k,9)*cintbg05(icol,k,9) & - +Nnatk(icol,k,10)*cintbg05(icol,k,10) - c_ss125(icol,k) = Nnatk(icol,k,8)*cintbg125(icol,k,8)& - +Nnatk(icol,k,9)*cintbg125(icol,k,9) & - +Nnatk(icol,k,10)*cintbg125(icol,k,10) -! internally mixed bc and oc (from coagulation) and so4 concentrations -! (sa=so4(aq) and sc=so4(cond+coag), separated because of different density: -! necessary for calculation of volume fractions!), and total aerosol surface -! areas and volumes. - c_bc(icol,k)=0.0_r8 - c_bc05(icol,k)=0.0_r8 - c_bc125(icol,k)=0.0_r8 - c_oc(icol,k)=0.0_r8 - c_oc05(icol,k)=0.0_r8 - c_oc125(icol,k)=0.0_r8 - c_s4(icol,k)=0.0_r8 - c_s4_a(icol,k)=0.0_r8 - c_s4_1(icol,k)=0.0_r8 - c_s4_5(icol,k)=0.0_r8 - c_sa(icol,k)=0.0_r8 - c_sa05(icol,k)=0.0_r8 - c_sa125(icol,k)=0.0_r8 - c_sc(icol,k)=0.0_r8 - c_sc05(icol,k)=0.0_r8 - c_sc125(icol,k)=0.0_r8 - aaeros_tot(icol,k)=0.0_r8 - aaerol_tot(icol,k)=0.0_r8 - vaeros_tot(icol,k)=0.0_r8 - vaerol_tot(icol,k)=0.0_r8 - c_bc_0(icol,k)=0.0_r8 - c_bc_2(icol,k)=0.0_r8 - c_bc_4(icol,k)=0.0_r8 - c_bc_12(icol,k)=0.0_r8 - c_bc_14(icol,k)=0.0_r8 - c_oc_4(icol,k)=0.0_r8 - c_oc_14(icol,k)=0.0_r8 -!akc6+ - c_tot(icol,k)=0.0_r8 - c_tot125(icol,k)=0.0_r8 - c_tot05(icol,k)=0.0_r8 - c_pm25(icol,k)=0.0_r8 - c_pm1(icol,k)=0.0_r8 - mmr_pm25(icol,k)=0.0_r8 - mmr_pm1(icol,k)=0.0_r8 -!akc6- - - do i=0,nbmodes - if(i.ne.3) then - c_bc(icol,k) = c_bc(icol,k) & - +Nnatk(icol,k,i)*cintbc(icol,k,i) - c_bc05(icol,k) = c_bc05(icol,k) & - +Nnatk(icol,k,i)*cintbc05(icol,k,i) - c_bc125(icol,k) = c_bc125(icol,k) & - +Nnatk(icol,k,i)*cintbc125(icol,k,i) - c_oc(icol,k) = c_oc(icol,k) & - +Nnatk(icol,k,i)*cintoc(icol,k,i) - c_oc05(icol,k) = c_oc05(icol,k) & - +Nnatk(icol,k,i)*cintoc05(icol,k,i) - c_oc125(icol,k) = c_oc125(icol,k) & - +Nnatk(icol,k,i)*cintoc125(icol,k,i) - c_sa(icol,k) = c_sa(icol,k) & - +Nnatk(icol,k,i)*cintsa(icol,k,i) - c_sa05(icol,k) = c_sa05(icol,k) & - +Nnatk(icol,k,i)*cintsa05(icol,k,i) - c_sa125(icol,k) = c_sa125(icol,k) & - +Nnatk(icol,k,i)*cintsa125(icol,k,i) - c_sc(icol,k) = c_sc(icol,k) & - +Nnatk(icol,k,i)*cintsc(icol,k,i) - c_sc05(icol,k) = c_sc05(icol,k) & - +Nnatk(icol,k,i)*cintsc05(icol,k,i) - c_sc125(icol,k) = c_sc125(icol,k) & - +Nnatk(icol,k,i)*cintsc125(icol,k,i) - aaeros_tot(icol,k) = aaeros_tot(icol,k) & - +Nnatk(icol,k,i)*aaeros(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) & - +Nnatk(icol,k,i)*aaerol(icol,k,i) - vaeros_tot(icol,k) =vaeros_tot(icol,k) & - +Nnatk(icol,k,i)*vaeros(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) & - +Nnatk(icol,k,i)*vaerol(icol,k,i) - endif - enddo -! add dry aerosol area and volume of externally mixed modes - do i=nbmp1,nmodes - aaeros_tot(icol,k) = aaeros_tot(icol,k) & - +Nnatk(icol,k,i)*aaerosn(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) & - +Nnatk(icol,k,i)*aaeroln(icol,k,i) - vaeros_tot(icol,k) =vaeros_tot(icol,k) & - +Nnatk(icol,k,i)*vaerosn(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) & - +Nnatk(icol,k,i)*vaeroln(icol,k,i) - end do -!c_er3d -! Effective radii for particles smaller and greater than 0.5um, -! and for all radii, in each layer (er=3*V/A): - erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) & - /(aaeros_tot(icol,k)+eps) - ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) & - /(aaerol_tot(icol,k)+eps) - er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) & - /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) -!c_er3d -! column integrated dry aerosol surface areas and volumes -! for r<0.5um and r>0.5um (s and l, respectively). - aaercols(icol)=aaercols(icol)+aaeros_tot(icol,k) - aaercoll(icol)=aaercoll(icol)+aaerol_tot(icol,k) - vaercols(icol)=vaercols(icol)+vaeros_tot(icol,k) - vaercoll(icol)=vaercoll(icol)+vaerol_tot(icol,k) -! then add background and externally mixed BC, OC and SO4 to mass concentrations - c_bc_ac(icol,k)= c_bc(icol,k) - c_bc_0(icol,k) = Nnatk(icol,k,0)*cintbg(icol,k,0) - c_bc_2(icol,k) = Nnatk(icol,k,2)*cintbg(icol,k,2) - c_bc_4(icol,k) = Nnatk(icol,k,4)*cintbg(icol,k,4)*faitbc(icol,k) - c_bc_12(icol,k)= Nnatk(icol,k,12)*cknorm(icol,k,12) - c_bc_14(icol,k)= Nnatk(icol,k,14)*cknorm(icol,k,14)*fnbc(icol,k) - c_bc(icol,k) = c_bc(icol,k) & - +Nnatk(icol,k,2)*cintbg(icol,k,2) & - +Nnatk(icol,k,4)*cintbg(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0)*cintbg(icol,k,0) & - +Nnatk(icol,k,12)*cknorm(icol,k,12) & - +Nnatk(icol,k,14)*cknorm(icol,k,14)*fnbc(icol,k) - c_bc05(icol,k) = c_bc05(icol,k) & - +Nnatk(icol,k,2)*cintbg05(icol,k,2) & - +Nnatk(icol,k,4)*cintbg05(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0)*cintbg05(icol,k,0) & - +Nnatk(icol,k,12)*cknlt05(icol,k,12) & - +Nnatk(icol,k,14)*cknlt05(icol,k,14)*fnbc(icol,k) - c_bc125(icol,k) = c_bc125(icol,k) & - +Nnatk(icol,k,2)*cintbg125(icol,k,2) & - +Nnatk(icol,k,4)*cintbg125(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0)*cintbg125(icol,k,0) & - +Nnatk(icol,k,12)*ckngt125(icol,k,12) & - +Nnatk(icol,k,14)*ckngt125(icol,k,14)*fnbc(icol,k) - c_oc_ac(icol,k)= c_oc(icol,k) - c_oc_4(icol,k) = Nnatk(icol,k,4)*cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) - c_oc_14(icol,k) = Nnatk(icol,k,14)*cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc(icol,k) = c_oc(icol,k) & - +Nnatk(icol,k,1)*cintbg(icol,k,1)*f_soana(icol,k) & -!-3 +Nnatk(icol,k,3)*cintbg(icol,k,3) & - +Nnatk(icol,k,4)*cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14)*cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc05(icol,k) = c_oc05(icol,k) & - +Nnatk(icol,k,1)*cintbg05(icol,k,1)*f_soana(icol,k) & -!-3 +Nnatk(icol,k,3)*cintbg05(icol,k,3) & - +Nnatk(icol,k,4)*cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14)*cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc125(icol,k) = c_oc125(icol,k) & - +Nnatk(icol,k,1)*cintbg125(icol,k,1)*f_soana(icol,k) & -!-3 +Nnatk(icol,k,3)*cintbg125(icol,k,3) & - +Nnatk(icol,k,4)*cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14)*ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_s4(icol,k) = c_sa(icol,k)+c_sc(icol,k) & - +Nnatk(icol,k,1)*cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5)*cintbg(icol,k,5) - c_s405(icol,k) = c_sa05(icol,k)+c_sc05(icol,k) & - +Nnatk(icol,k,1)*cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5)*cintbg05(icol,k,5) - c_s4125(icol,k) = c_sa125(icol,k)+c_sc125(icol,k) & - +Nnatk(icol,k,1)*cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5)*cintbg125(icol,k,5) - -!akc6+ - c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) & - + c_mi(icol,k) + c_ss(icol,k) - c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) & - + c_mi125(icol,k) + c_ss125(icol,k) - c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) & - + c_mi05(icol,k) + c_ss05(icol,k) - c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) - c_pm1(icol,k) = c_tot05(icol,k) -! mass mixing ratio: - mmr_pm25(icol,k) = 1.e-9*c_pm25(icol,k)/rhoda(icol,k) - mmr_pm1(icol,k) = 1.e-9*c_pm1(icol,k)/rhoda(icol,k) -!akc6- - -! converting from S to SO4 concentrations is no longer necessary, since -! sc=H2SO4 and sa=(NH4)2SO4 now, not SO4 as in CAM4-Oslo -! c_s4(icol,k)=c_s4(icol,k)/3._r8 -! c_s405(icol,k)=c_s405(icol,k)/3._r8 -! c_s4125(icol,k)=c_s4125(icol,k)/3._r8 - - c_s4_a(icol,k) = c_sa(icol,k)+c_sc(icol,k) - c_s4_1(icol,k) = Nnatk(icol,k,1)*cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) - c_s4_5(icol,k) = Nnatk(icol,k,5)*cintbg05(icol,k,5) - - end do ! icol - enddo ! k - -! Total PM and PM2.5 (dry r>1.25um), surface values (ug/m3) - do icol=1,ncol -! c_tots(icol) = c_s4(icol,pver) + c_oc(icol,pver) + c_bc(icol,pver) & -! + c_mi(icol,pver) + c_ss(icol,pver) -! c_tot125s(icol) = c_s4125(icol,pver) + c_oc125(icol,pver) + c_bc125(icol,pver) & -! + c_mi125(icol,pver) + c_ss125(icol,pver) -! c_pm25s(icol) = c_tots(icol) - c_tot125s(icol) -!akc6+ - c_tots(icol) = c_tot(icol,pver) - c_tot125s(icol) = c_tot125(icol,pver) - c_pm25s(icol) = c_pm25(icol,pver) -!akc6- - enddo - -! Effective, column integrated, radii for particles -! smaller and greater than 0.5um, and for all radii - do icol=1,ncol - derlt05(icol)=3.0_r8*vaercols(icol)/(aaercols(icol)+eps) - dergt05(icol)=3.0_r8*vaercoll(icol)/(aaercoll(icol)+eps) - der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) & - /(aaercols(icol)+aaercoll(icol)+eps) - enddo - - do icol=1,ncol - dload_s4(icol)=0.0_r8 - dload_s4_a(icol)=0.0_r8 - dload_s4_1(icol)=0.0_r8 - dload_s4_5(icol)=0.0_r8 - dload_oc(icol)=0.0_r8 - dload_bc(icol)=0.0_r8 - dload_bc_ac(icol)=0.0_r8 - dload_bc_0(icol)=0.0_r8 - dload_bc_2(icol)=0.0_r8 - dload_bc_4(icol)=0.0_r8 - dload_bc_12(icol)=0.0_r8 - dload_bc_14(icol)=0.0_r8 - dload_oc_ac(icol)=0.0_r8 - dload_oc_4(icol)=0.0_r8 - dload_oc_14(icol)=0.0_r8 - do k=1,pver -! Layer thickness, unit km -!- deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) + enddo + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! optical depths for d<1um and d>1um (r<0.5um and r>0.5um) + !SS + dod5503dlt1_ss(icol,k) = besslt1(icol,k)*deltah + dod5503dgt1_ss(icol,k) = bessgt1(icol,k)*deltah + !DUST + dod5503dlt1_dust(icol,k) = bedustlt1(icol,k)*deltah + dod5503dgt1_dust(icol,k) = bedustgt1(icol,k)*deltah + + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + dod5503dlt1_so4(icol,k) = (bes4lt1t(icol,k) & ! condensate + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebglt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5503dgt1_so4(icol,k) = (bes4gt1t(icol,k) & ! condensate + n-mode (11) + + Nnatk(icol,k,1)*bebggt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebggt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + !BC + dod5503dlt1_bc(icol,k) = (bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebglt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebglt1(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5503dgt1_bc(icol,k) = (bebcgt1t(icol,k)+bbcgt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebggt1(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebggt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebggt1(icol,k,0))*deltah ! background, BC(ax) mode (0) + !OC + !soa + v_soana part of mode 11 for the OC volume fraction of that mode + dod5503dlt1_pom(icol,k) = (beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebglt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5503dgt1_pom(icol,k) = (beocgt1t(icol,k)+bocgt1xt(icol,k) & ! coagulated + n-mode OC&OC (14) + + Nnatk(icol,k,1)*bebggt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*bebggt1(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebggt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! Column integrated optical depths/abs., total and for each constituent + dod440(icol) = dod440(icol)+dod4403d(icol,k) + abs440(icol) = abs440(icol)+abs4403d(icol,k) + dod500(icol) = dod500(icol)+dod5003d(icol,k) + abs500(icol) = abs500(icol)+abs5003d(icol,k) + dod550(icol) = dod550(icol)+dod5503d(icol,k) + abs550(icol) = abs550(icol)+abs5503d(icol,k) + abs550alt(icol) = abs550alt(icol)+abs5503dalt(icol,k) + dod670(icol) = dod670(icol)+dod6703d(icol,k) + abs670(icol) = abs670(icol)+abs6703d(icol,k) + dod870(icol) = dod870(icol)+dod8703d(icol,k) + abs870(icol) = abs870(icol)+abs8703d(icol,k) + ! Added abs components + abs550_ss(icol) = abs550_ss(icol)+abs5503d_ss(icol,k) + abs550_dust(icol) = abs550_dust(icol)+abs5503d_dust(icol,k) + abs550_so4(icol) = abs550_so4(icol)+abs5503d_so4(icol,k) + abs550_bc(icol) = abs550_bc(icol)+abs5503d_bc(icol,k) + abs550_pom(icol) = abs550_pom(icol)+abs5503d_pom(icol,k) + ! + dod440_ss(icol) = dod440_ss(icol)+dod4403d_ss(icol,k) + dod440_dust(icol) = dod440_dust(icol)+dod4403d_dust(icol,k) + dod440_so4(icol) = dod440_so4(icol)+dod4403d_so4(icol,k) + dod440_bc(icol) = dod440_bc(icol)+dod4403d_bc(icol,k) + dod440_pom(icol) = dod440_pom(icol)+dod4403d_pom(icol,k) + dod500_ss(icol) = dod500_ss(icol)+dod5003d_ss(icol,k) + dod500_dust(icol) = dod500_dust(icol)+dod5003d_dust(icol,k) + dod500_so4(icol) = dod500_so4(icol)+dod5003d_so4(icol,k) + dod500_bc(icol) = dod500_bc(icol)+dod5003d_bc(icol,k) + dod500_pom(icol) = dod500_pom(icol)+dod5003d_pom(icol,k) + dod550_ss(icol) = dod550_ss(icol)+dod5503d_ss(icol,k) + dod550_dust(icol) = dod550_dust(icol)+dod5503d_dust(icol,k) + dod550_so4(icol) = dod550_so4(icol)+dod5503d_so4(icol,k) + dod550_bc(icol) = dod550_bc(icol)+dod5503d_bc(icol,k) + dod550_pom(icol) = dod550_pom(icol)+dod5503d_pom(icol,k) + dod670_ss(icol) = dod670_ss(icol)+dod6703d_ss(icol,k) + dod670_dust(icol) = dod670_dust(icol)+dod6703d_dust(icol,k) + dod670_so4(icol) = dod670_so4(icol)+dod6703d_so4(icol,k) + dod670_bc(icol) = dod670_bc(icol)+dod6703d_bc(icol,k) + dod670_pom(icol) = dod670_pom(icol)+dod6703d_pom(icol,k) + dod870_ss(icol) = dod870_ss(icol)+dod8703d_ss(icol,k) + dod870_dust(icol) = dod870_dust(icol)+dod8703d_dust(icol,k) + dod870_so4(icol) = dod870_so4(icol)+dod8703d_so4(icol,k) + dod870_bc(icol) = dod870_bc(icol)+dod8703d_bc(icol,k) + dod870_pom(icol) = dod870_pom(icol)+dod8703d_pom(icol,k) + dod550lt1_ss(icol) = dod550lt1_ss(icol)+dod5503dlt1_ss(icol,k) + dod550gt1_ss(icol) = dod550gt1_ss(icol)+dod5503dgt1_ss(icol,k) + dod550lt1_dust(icol) = dod550lt1_dust(icol)+dod5503dlt1_dust(icol,k) + dod550gt1_dust(icol) = dod550gt1_dust(icol)+dod5503dgt1_dust(icol,k) + dod550lt1_so4(icol) = dod550lt1_so4(icol)+dod5503dlt1_so4(icol,k) + dod550gt1_so4(icol) = dod550gt1_so4(icol)+dod5503dgt1_so4(icol,k) + dod550lt1_bc(icol) = dod550lt1_bc(icol)+dod5503dlt1_bc(icol,k) + dod550gt1_bc(icol) = dod550gt1_bc(icol)+dod5503dgt1_bc(icol,k) + dod550lt1_pom(icol) = dod550lt1_pom(icol)+dod5503dlt1_pom(icol,k) + dod550gt1_pom(icol) = dod550gt1_pom(icol)+dod5503dgt1_pom(icol,k) + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + enddo ! k + + enddo ! icol + + ! extinction, absorption (m-1) and backscatter coefficients (m-1 sr-1) + call outfld('EC550AER',ec550_aer,pcols,lchnk) + call outfld('ABS550_A',abs550_aer,pcols,lchnk) + call outfld('BS550AER',bs550_aer,pcols,lchnk) + ! + ! speciated extinction coefficients (m-1) + call outfld('EC550SO4',ec550_so4,pcols,lchnk) + call outfld('EC550BC ',ec550_bc ,pcols,lchnk) + call outfld('EC550POM',ec550_pom,pcols,lchnk) + call outfld('EC550SS ',ec550_ss ,pcols,lchnk) + call outfld('EC550DU ',ec550_du ,pcols,lchnk) + ! + ! optical depths and absorption as requested by AeroCom + ! notation: 3=3D, D=DOD, A=ABS, LT=d<1um, GT=d>1um + call outfld('DOD440 ',dod440 ,pcols,lchnk) + call outfld('ABS440 ',abs440 ,pcols,lchnk) + call outfld('DOD500 ',dod500 ,pcols,lchnk) + call outfld('ABS500 ',abs500 ,pcols,lchnk) + call outfld('DOD550 ',dod550 ,pcols,lchnk) + call outfld('ABS550 ',abs550 ,pcols,lchnk) + call outfld('ABS550AL',abs550alt,pcols,lchnk) + call outfld('DOD670 ',dod670 ,pcols,lchnk) + call outfld('ABS670 ',abs670 ,pcols,lchnk) + call outfld('DOD870 ',dod870 ,pcols,lchnk) + call outfld('ABS870 ',abs870 ,pcols,lchnk) + call outfld('A550_SS ',abs550_ss ,pcols,lchnk) + call outfld('A550_DU ',abs550_dust,pcols,lchnk) + call outfld('A550_SO4',abs550_so4 ,pcols,lchnk) + call outfld('A550_BC ',abs550_bc ,pcols,lchnk) + call outfld('A550_POM',abs550_pom ,pcols,lchnk) + ! + call outfld('D440_SS ',dod440_ss ,pcols,lchnk) + call outfld('D440_DU ',dod440_dust,pcols,lchnk) + call outfld('D440_SO4',dod440_so4 ,pcols,lchnk) + call outfld('D440_BC ',dod440_bc ,pcols,lchnk) + call outfld('D440_POM',dod440_pom ,pcols,lchnk) + call outfld('D500_SS ',dod500_ss ,pcols,lchnk) + call outfld('D500_DU ',dod500_dust,pcols,lchnk) + call outfld('D500_SO4',dod500_so4 ,pcols,lchnk) + call outfld('D500_BC ',dod500_bc ,pcols,lchnk) + call outfld('D500_POM',dod500_pom ,pcols,lchnk) + call outfld('D550_SS ',dod550_ss ,pcols,lchnk) + call outfld('D550_DU ',dod550_dust,pcols,lchnk) + call outfld('D550_SO4',dod550_so4 ,pcols,lchnk) + call outfld('D550_BC ',dod550_bc ,pcols,lchnk) + call outfld('D550_POM',dod550_pom ,pcols,lchnk) + call outfld('D670_SS ',dod670_ss ,pcols,lchnk) + call outfld('D670_DU ',dod670_dust,pcols,lchnk) + call outfld('D670_SO4',dod670_so4 ,pcols,lchnk) + call outfld('D670_BC ',dod670_bc ,pcols,lchnk) + call outfld('D670_POM',dod670_pom ,pcols,lchnk) + call outfld('D870_SS ',dod870_ss ,pcols,lchnk) + call outfld('D870_DU ',dod870_dust,pcols,lchnk) + call outfld('D870_SO4',dod870_so4 ,pcols,lchnk) + call outfld('D870_BC ',dod870_bc ,pcols,lchnk) + call outfld('D870_POM',dod870_pom ,pcols,lchnk) + call outfld('DLT_SS ',dod550lt1_ss,pcols,lchnk) + call outfld('DGT_SS ',dod550gt1_ss,pcols,lchnk) + call outfld('DLT_DUST',dod550lt1_dust,pcols,lchnk) + call outfld('DGT_DUST',dod550gt1_dust,pcols,lchnk) + call outfld('DLT_SO4 ',dod550lt1_so4,pcols,lchnk) + call outfld('DGT_SO4 ',dod550gt1_so4,pcols,lchnk) + call outfld('DLT_BC ',dod550lt1_bc,pcols,lchnk) + call outfld('DGT_BC ',dod550gt1_bc,pcols,lchnk) + call outfld('DLT_POM ',dod550lt1_pom,pcols,lchnk) + call outfld('DGT_POM ',dod550gt1_pom,pcols,lchnk) + !tst + ! call outfld('DOD5503D',dod5503d,pcols,lchnk) + !tst + !- call outfld('ABS5503D',abs5503d,pcols,lchnk) + !- call outfld('D443_SS ',dod4403d_ss ,pcols,lchnk) + !- call outfld('D443_DU ',dod4403d_dust,pcols,lchnk) + !- call outfld('D443_SO4',dod4403d_so4 ,pcols,lchnk) + !- call outfld('D443_BC ',dod4403d_bc ,pcols,lchnk) + !- call outfld('D443_POM',dod4403d_pom ,pcols,lchnk) + !- call outfld('D503_SS ',dod5003d_ss ,pcols,lchnk) + !- call outfld('D503_DU ',dod5003d_dust,pcols,lchnk) + !- call outfld('D503_SO4',dod5003d_so4 ,pcols,lchnk) + !- call outfld('D503_BC ',dod5003d_bc ,pcols,lchnk) + !- call outfld('D503_POM',dod5003d_pom ,pcols,lchnk) + !- call outfld('D553_SS ',dod5503d_ss ,pcols,lchnk) + !- call outfld('D553_DU ',dod5503d_dust,pcols,lchnk) + !- call outfld('D553_SO4',dod5503d_so4 ,pcols,lchnk) + !- call outfld('D553_BC ',dod5503d_bc ,pcols,lchnk) + !- call outfld('D553_POM',dod5503d_pom ,pcols,lchnk) + !- call outfld('D673_SS ',dod6703d_ss ,pcols,lchnk) + !- call outfld('D673_DU ',dod6703d_dust,pcols,lchnk) + !- call outfld('D673_SO4',dod6703d_so4 ,pcols,lchnk) + !- call outfld('D673_BC ',dod6703d_bc ,pcols,lchnk) + !- call outfld('D673_POM',dod6703d_pom ,pcols,lchnk) + !- call outfld('D873_SS ',dod8703d_ss ,pcols,lchnk) + !- call outfld('D873_DU ',dod8703d_dust,pcols,lchnk) + !- call outfld('D873_SO4',dod8703d_so4 ,pcols,lchnk) + !- call outfld('D873_BC ',dod8703d_bc ,pcols,lchnk) + !- call outfld('D873_POM',dod8703d_pom ,pcols,lchnk) + + + !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + + ! Dry parameters of each aerosol component + ! BC(ax) mode + aerodry_prop%intdrypar0(lchnk, ncol, Nnatk) + + ! SO4&SOA(Ait,n) mode + aerodry_prop%intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) + + ! BC(Ait,n) and OC(Ait,n) modes + aerodry_prop%intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1) + + ! BC&OC(Ait,n) mode ------ fcm not valid here (=0). Use faitbc or fnbc instead + aerodry_prop%intdrypar4(lchnk, ncol, Nnatk, & + xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & + xct, ict1, xfac, ifac1, xfaq, ifaq1) + + ! SO4(Ait75) (5), mineral (6-7) and Sea-salt (8-10) modes: + aerodry_prop%intdrypar5to10(lchnk, ncol, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) + + do k=1,pver + do icol=1,ncol + c_ss(icol,k)=0.0_r8 + c_mi(icol,k)=0.0_r8 + enddo + enddo + + do k=1,pver + do icol=1,ncol + ! mineral and sea-salt background concentrations, internally mixed + c_mi(icol,k) = Nnatk(icol,k,6) * aerdry_prop%cintbg(icol,k,6) + & + Nnatk(icol,k,7) * aerdry_prop%cintbg(icol,k,7) + c_mi05(icol,k) = Nnatk(icol,k,6) * aerdry_prop%cintbg05(icol,k,6) + & + Nnatk(icol,k,7) * aerdry_prop%cintbg05(icol,k,7) + c_mi125(icol,k) = Nnatk(icol,k,6) * aerdry_prop%cintbg125(icol,k,6) + & + Nnatk(icol,k,7) * aerdry_prop%cintbg125(icol,k,7) + c_ss(icol,k) = Nnatk(icol,k,8) * aerdry_prop%cintbg(icol,k,8) + & + Nnatk(icol,k,9) * aerdry_prop%cintbg(icol,k,9) + & + Nnatk(icol,k,10)* aerdry_prop%cintbg(icol,k,10) + c_ss05(icol,k) = Nnatk(icol,k,8) * aerdry_prop%cintbg05(icol,k,8) + & + Nnatk(icol,k,9) * aerdry_prop%cintbg05(icol,k,9) + & + Nnatk(icol,k,10)* aerdry_prop%cintbg05(icol,k,10) + c_ss125(icol,k) = Nnatk(icol,k,8) * aerdry_prop%cintbg125(icol,k,8) + & + Nnatk(icol,k,9) * aerdry_prop%cintbg125(icol,k,9) + & + Nnatk(icol,k,10)* aerdry_prop%cintbg125(icol,k,10) + + ! internally mixed bc and oc (from coagulation) and so4 concentrations + ! (sa=so4(aq) and sc=so4(cond+coag), separated because of different density: + ! necessary for calculation of volume fractions!), and total aerosol surface + ! areas and volumes. + c_bc(icol,k) = 0.0_r8 + c_bc05(icol,k) = 0.0_r8 + c_bc125(icol,k) = 0.0_r8 + c_oc(icol,k) = 0.0_r8 + c_oc05(icol,k) = 0.0_r8 + c_oc125(icol,k) = 0.0_r8 + c_s4(icol,k) = 0.0_r8 + c_s4_a(icol,k) = 0.0_r8 + c_s4_1(icol,k) = 0.0_r8 + c_s4_5(icol,k) = 0.0_r8 + c_sa(icol,k) = 0.0_r8 + c_sa05(icol,k) = 0.0_r8 + c_sa125(icol,k) = 0.0_r8 + c_sc(icol,k) = 0.0_r8 + c_sc05(icol,k) = 0.0_r8 + c_sc125(icol,k) = 0.0_r8 + aaeros_tot(icol,k) = 0.0_r8 + aaerol_tot(icol,k) = 0.0_r8 + vaeros_tot(icol,k) = 0.0_r8 + vaerol_tot(icol,k) = 0.0_r8 + c_bc_0(icol,k) = 0.0_r8 + c_bc_2(icol,k) = 0.0_r8 + c_bc_4(icol,k) = 0.0_r8 + c_bc_12(icol,k) = 0.0_r8 + c_bc_14(icol,k) = 0.0_r8 + c_oc_4(icol,k) = 0.0_r8 + c_oc_14(icol,k) = 0.0_r8 + c_tot(icol,k) = 0.0_r8 + c_tot125(icol,k) = 0.0_r8 + c_tot05(icol,k) = 0.0_r8 + c_pm25(icol,k) = 0.0_r8 + c_pm1(icol,k) = 0.0_r8 + mmr_pm25(icol,k) = 0.0_r8 + mmr_pm1(icol,k) = 0.0_r8 + + do i=0,nbmodes + if(i.ne.3) then + c_bc(icol,k) = c_bc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc(icol,k,i) + c_bc05(icol,k) = c_bc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc05(icol,k,i) + c_bc125(icol,k) = c_bc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc125(icol,k,i) + c_oc(icol,k) = c_oc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc(icol,k,i) + c_oc05(icol,k) = c_oc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc05(icol,k,i) + c_oc125(icol,k) = c_oc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc125(icol,k,i) + c_sa(icol,k) = c_sa(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa(icol,k,i) + c_sa05(icol,k) = c_sa05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa05(icol,k,i) + c_sa125(icol,k) = c_sa125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa125(icol,k,i) + c_sc(icol,k) = c_sc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc(icol,k,i) + c_sc05(icol,k) = c_sc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc05(icol,k,i) + c_sc125(icol,k) = c_sc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc125(icol,k,i) + aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeros(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerol(icol,k,i) + vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeros(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerol(icol,k,i) + endif + enddo + + ! add dry aerosol area and volume of externally mixed modes + do i=nbmp1,nmodes + aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerosn(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeroln(icol,k,i) + vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerosn(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeroln(icol,k,i) + end do + + !c_er3d + ! Effective radii for particles smaller and greater than 0.5um, + ! and for all radii, in each layer (er=3*V/A): + erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) /(aaeros_tot(icol,k)+eps) + ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) /(aaerol_tot(icol,k)+eps) + er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) + !c_er3d + + ! column integrated dry aerosol surface areas and volumes + ! for r<0.5um and r>0.5um (s and l, respectively). + aaercols(icol)=aaercols(icol)+aaeros_tot(icol,k) + aaercoll(icol)=aaercoll(icol)+aaerol_tot(icol,k) + vaercols(icol)=vaercols(icol)+vaeros_tot(icol,k) + vaercoll(icol)=vaercoll(icol)+vaerol_tot(icol,k) + + ! then add background and externally mixed BC, OC and SO4 to mass concentrations + c_bc_ac(icol,k)= c_bc(icol,k) + c_bc_0(icol,k) = Nnatk(icol,k,0)*aerodry_prop%cintbg(icol,k,0) + c_bc_2(icol,k) = Nnatk(icol,k,2)*aerodry_prop%cintbg(icol,k,2) + c_bc_4(icol,k) = Nnatk(icol,k,4)*aerodry_prop%cintbg(icol,k,4)*faitbc(icol,k) + c_bc_12(icol,k)= Nnatk(icol,k,12)*aerodry_prop%cknorm(icol,k,12) + c_bc_14(icol,k)= Nnatk(icol,k,14)*aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) + c_bc(icol,k) = c_bc(icol,k) & + +Nnatk(icol,k,2)*aerodry_prop%cintbg(icol,k,2) & + +Nnatk(icol,k,4)*aerodry_prop%cintbg(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0)*aerodry_prop%cintbg(icol,k,0) & + +Nnatk(icol,k,12)*aerodry_prop%cknorm(icol,k,12) & + +Nnatk(icol,k,14)*aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) + c_bc05(icol,k) = c_bc05(icol,k) & + +Nnatk(icol,k,2)*aerodry_prop%cintbg05(icol,k,2) & + +Nnatk(icol,k,4)*aerodry_prop%cintbg05(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0)*aerodry_prop%cintbg05(icol,k,0) & + +Nnatk(icol,k,12)*aerodry_prop%cknlt05(icol,k,12) & + +Nnatk(icol,k,14)*aerodry_prop%cknlt05(icol,k,14)*fnbc(icol,k) + c_bc125(icol,k) = c_bc125(icol,k) & + +Nnatk(icol,k,2)*aerodry_prop%cintbg125(icol,k,2) & + +Nnatk(icol,k,4)*aerodry_prop%cintbg125(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0)*aerodry_prop%cintbg125(icol,k,0) & + +Nnatk(icol,k,12)*ckngt125(icol,k,12) & + +Nnatk(icol,k,14)*ckngt125(icol,k,14)*fnbc(icol,k) + c_oc_ac(icol,k)= c_oc(icol,k) + c_oc_4(icol,k) = Nnatk(icol,k,4)*aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) + c_oc_14(icol,k) = Nnatk(icol,k,14)*aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc(icol,k) = c_oc(icol,k) & + +Nnatk(icol,k,1)*aerodry_prop%cintbg(icol,k,1)*f_soana(icol,k) & + +Nnatk(icol,k,4)*aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14)*aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc05(icol,k) = c_oc05(icol,k) & + +Nnatk(icol,k,1)*aerodry_prop%cintbg05(icol,k,1)*f_soana(icol,k) & + +Nnatk(icol,k,4)*aerodry_prop%cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14)*aerodry_prop%cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc125(icol,k) = c_oc125(icol,k) & + +Nnatk(icol,k,1)*aerodry_prop%cintbg125(icol,k,1)*f_soana(icol,k) & + +Nnatk(icol,k,4)*aerodry_prop%cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14)*ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_s4(icol,k) = c_sa(icol,k)+c_sc(icol,k) & + +Nnatk(icol,k,1)*aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5)*aerodry_prop%cintbg(icol,k,5) + c_s405(icol,k) = c_sa05(icol,k)+c_sc05(icol,k) & + +Nnatk(icol,k,1)*aerodry_prop%cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5)*aerodry_prop%cintbg05(icol,k,5) + c_s4125(icol,k) = c_sa125(icol,k)+c_sc125(icol,k) & + +Nnatk(icol,k,1)*aerodry_prop%cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5)*aerodry_prop%cintbg125(icol,k,5) + + !akc6+ + c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) + c_mi(icol,k) + c_ss(icol,k) + c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) + c_mi125(icol,k) + c_ss125(icol,k) + c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) + c_mi05(icol,k) + c_ss05(icol,k) + c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) + c_pm1(icol,k) = c_tot05(icol,k) + ! mass mixing ratio: + mmr_pm25(icol,k) = 1.e-9*c_pm25(icol,k)/rhoda(icol,k) + mmr_pm1(icol,k) = 1.e-9*c_pm1(icol,k)/rhoda(icol,k) + !akc6- + + ! converting from S to SO4 concentrations is no longer necessary, since + ! sc=H2SO4 and sa=(NH4)2SO4 now, not SO4 as in CAM4-Oslo + ! c_s4(icol,k)=c_s4(icol,k)/3._r8 + ! c_s405(icol,k)=c_s405(icol,k)/3._r8 + ! c_s4125(icol,k)=c_s4125(icol,k)/3._r8 + + c_s4_a(icol,k) = c_sa(icol,k)+c_sc(icol,k) + c_s4_1(icol,k) = Nnatk(icol,k,1)*aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) + c_s4_5(icol,k) = Nnatk(icol,k,5)*aerodry_prop%cintbg05(icol,k,5) + + end do ! icol + enddo ! k + + ! Total PM and PM2.5 (dry r>1.25um), surface values (ug/m3) + do icol=1,ncol + ! c_tots(icol) = c_s4(icol,pver) + c_oc(icol,pver) + c_bc(icol,pver) & + ! + c_mi(icol,pver) + c_ss(icol,pver) + ! c_tot125s(icol) = c_s4125(icol,pver) + c_oc125(icol,pver) + c_bc125(icol,pver) & + ! + c_mi125(icol,pver) + c_ss125(icol,pver) + ! c_pm25s(icol) = c_tots(icol) - c_tot125s(icol) + !akc6+ + c_tots(icol) = c_tot(icol,pver) + c_tot125s(icol) = c_tot125(icol,pver) + c_pm25s(icol) = c_pm25(icol,pver) + !akc6- + enddo + + ! Effective, column integrated, radii for particles + ! smaller and greater than 0.5um, and for all radii + do icol=1,ncol + derlt05(icol)=3.0_r8*vaercols(icol)/(aaercols(icol)+eps) + dergt05(icol)=3.0_r8*vaercoll(icol)/(aaercoll(icol)+eps) + der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) / (aaercols(icol)+aaercoll(icol)+eps) + enddo + + do icol=1,ncol + dload_s4(icol)=0.0_r8 + dload_s4_a(icol)=0.0_r8 + dload_s4_1(icol)=0.0_r8 + dload_s4_5(icol)=0.0_r8 + dload_oc(icol)=0.0_r8 + dload_bc(icol)=0.0_r8 + dload_bc_ac(icol)=0.0_r8 + dload_bc_0(icol)=0.0_r8 + dload_bc_2(icol)=0.0_r8 + dload_bc_4(icol)=0.0_r8 + dload_bc_12(icol)=0.0_r8 + dload_bc_14(icol)=0.0_r8 + dload_oc_ac(icol)=0.0_r8 + dload_oc_4(icol)=0.0_r8 + dload_oc_14(icol)=0.0_r8 + do k=1,pver + ! Layer thickness, unit km + !- deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) deltah=deltah_km(icol,k) -! Modal and total mass concentrations for clean and dry aerosol, -! i.e. not including coag./cond./Aq. BC,OC,SO4 or condensed water. -! Units: ug/m3 for concentrations and mg/m2 (--> kg/m2 later) for mass loading. + ! Modal and total mass concentrations for clean and dry aerosol, + ! i.e. not including coag./cond./Aq. BC,OC,SO4 or condensed water. + ! Units: ug/m3 for concentrations and mg/m2 (--> kg/m2 later) for mass loading. do i=0,nmodes - ck(icol,k,i)=cknorm(icol,k,i)*Nnatk(icol,k,i) - dload3d(icol,k,i)=ck(icol,k,i)*deltah - dload(icol,i)=dload(icol,i)+dload3d(icol,k,i) + ck(icol,k,i)=aerodry_prop%cknorm(icol,k,i)*Nnatk(icol,k,i) + dload3d(icol,k,i)=ck(icol,k,i)*deltah + dload(icol,i)=dload(icol,i)+dload3d(icol,k,i) enddo nnat_0(icol,k) =Nnatk(icol,k,0) nnat_1(icol,k) =Nnatk(icol,k,1) @@ -2323,19 +2108,19 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & nnat_10(icol,k)=Nnatk(icol,k,10) nnat_12(icol,k)=Nnatk(icol,k,12) nnat_14(icol,k)=Nnatk(icol,k,14) -! mineral and sea-salt mass concentrations + ! mineral and sea-salt mass concentrations cmin(icol,k)=ck(icol,k,6)+ck(icol,k,7) cseas(icol,k)=ck(icol,k,8)+ck(icol,k,9)+ck(icol,k,10) -! Aerocom: Condensed water loading (mg_m2) + ! Aerocom: Condensed water loading (mg_m2) daerh2o(icol)=daerh2o(icol)+Cwater(icol,k)*deltah -! just for checking purposes: + ! just for checking purposes: dload_s4(icol)=dload_s4(icol)+c_s4(icol,k)*deltah dload_s4_a(icol)=dload_s4_a(icol)+c_s4_a(icol,k)*deltah dload_s4_1(icol)=dload_s4_1(icol)+c_s4_1(icol,k)*deltah dload_s4_5(icol)=dload_s4_5(icol)+c_s4_5(icol,k)*deltah dload_oc(icol)=dload_oc(icol)+c_oc(icol,k)*deltah dload_bc(icol)=dload_bc(icol)+c_bc(icol,k)*deltah -! + ! dload_bc_ac(icol)=dload_bc_ac(icol)+c_bc_ac(icol,k)*deltah dload_bc_0(icol)=dload_bc_0(icol)+c_bc_0(icol,k)*deltah dload_bc_2(icol)=dload_bc_2(icol)+c_bc_2(icol,k)*deltah @@ -2345,165 +2130,146 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & dload_oc_ac(icol)=dload_oc_ac(icol)+c_oc_ac(icol,k)*deltah dload_oc_4(icol)=dload_oc_4(icol)+c_oc_4(icol,k)*deltah dload_oc_14(icol)=dload_oc_14(icol)+c_oc_14(icol,k)*deltah -! - end do ! k - dload_mi(icol)=dload(icol,6)+dload(icol,7) - dload_ss(icol)=dload(icol,8)+dload(icol,9)+dload(icol,10) - end do ! icol + ! + end do ! k + dload_mi(icol)=dload(icol,6)+dload(icol,7) + dload_ss(icol)=dload(icol,8)+dload(icol,9)+dload(icol,10) + end do ! icol #ifdef COLTST4INTCONS -! Testing column burdens for internal consistency between intdrypar* -! (use of aerodryk*.out look-up tables) and calculations directly -! from the qm1 array. Will only work with #define AEROCOM. -! - call coltst4intcons (lchnk, ncol, qm1, deltah_km, rhoda, fnbc, & - dload_mi, dload_ss, dload_s4, dload_oc, dload_bc, & - dload_bc_0, dload_bc_2, dload_bc_4, dload_bc_12, dload_bc_14, dload_bc_ac, & - dload_oc_4, dload_oc_14, dload_oc_ac, dload_s4_a, dload_s4_1, dload_s4_5) -! + ! Testing column burdens for internal consistency between intdrypar* + ! (use of aerodryk*.out look-up tables) and calculations directly + ! from the qm1 array. Will only work with #define AEROCOM. + ! + call coltst4intcons (lchnk, ncol, qm1, deltah_km, rhoda, fnbc, & + dload_mi, dload_ss, dload_s4, dload_oc, dload_bc, & + dload_bc_0, dload_bc_2, dload_bc_4, dload_bc_12, dload_bc_14, dload_bc_ac, & + dload_oc_4, dload_oc_14, dload_oc_ac, dload_s4_a, dload_s4_1, dload_s4_5) + ! #ifdef AEROCOM - call outfld('CMDRY0 ',cmdry0 ,pcols,lchnk) - call outfld('CMDRY1 ',cmdry1 ,pcols,lchnk) - call outfld('CMDRY2 ',cmdry2 ,pcols,lchnk) - call outfld('CMDRY4 ',cmdry4 ,pcols,lchnk) - call outfld('CMDRY5 ',cmdry5 ,pcols,lchnk) - call outfld('CMDRY6 ',cmdry6 ,pcols,lchnk) - call outfld('CMDRY7 ',cmdry7 ,pcols,lchnk) - call outfld('CMDRY8 ',cmdry8 ,pcols,lchnk) - call outfld('CMDRY9 ',cmdry9 ,pcols,lchnk) - call outfld('CMDRY10 ',cmdry10 ,pcols,lchnk) - call outfld('CMDRY12 ',cmdry12 ,pcols,lchnk) - call outfld('CMDRY14 ',cmdry14 ,pcols,lchnk) + call outfld('CMDRY0 ',cmdry0 ,pcols,lchnk) + call outfld('CMDRY1 ',cmdry1 ,pcols,lchnk) + call outfld('CMDRY2 ',cmdry2 ,pcols,lchnk) + call outfld('CMDRY4 ',cmdry4 ,pcols,lchnk) + call outfld('CMDRY5 ',cmdry5 ,pcols,lchnk) + call outfld('CMDRY6 ',cmdry6 ,pcols,lchnk) + call outfld('CMDRY7 ',cmdry7 ,pcols,lchnk) + call outfld('CMDRY8 ',cmdry8 ,pcols,lchnk) + call outfld('CMDRY9 ',cmdry9 ,pcols,lchnk) + call outfld('CMDRY10 ',cmdry10 ,pcols,lchnk) + call outfld('CMDRY12 ',cmdry12 ,pcols,lchnk) + call outfld('CMDRY14 ',cmdry14 ,pcols,lchnk) #endif #endif ! COLTST4INTCONS -! Internally and externally mixed dry concentrations (ug/m3) of -! SO4, BC and OC, for all r, r<0.5um and r>1.25um... -! call outfld('C_BCPM ',c_bc ,pcols,lchnk) -! call outfld('C_BC05 ',c_bc05 ,pcols,lchnk) -! call outfld('C_BC125 ',c_bc125,pcols,lchnk) -! call outfld('C_OCPM ',c_oc ,pcols,lchnk) -! call outfld('C_OC05 ',c_oc05 ,pcols,lchnk) -! call outfld('C_OC125 ',c_oc125,pcols,lchnk) -! call outfld('C_S4PM ',c_s4 ,pcols,lchnk) -! call outfld('C_S405 ',c_s405 ,pcols,lchnk) -! call outfld('C_S4125 ',c_s4125,pcols,lchnk) -! ... and of background components for all r, r<0.5um and r>1.25um -! call outfld('C_MIPM ',c_mi ,pcols,lchnk) -! call outfld('C_MI05 ',c_mi05 ,pcols,lchnk) -! call outfld('C_MI125 ',c_mi125,pcols,lchnk) -! call outfld('C_SSPM ',c_ss ,pcols,lchnk) -! call outfld('C_SS05 ',c_ss05 ,pcols,lchnk) -! call outfld('C_SS125 ',c_ss125,pcols,lchnk) - call outfld('PMTOT ',c_tots ,pcols,lchnk) - call outfld('PM25 ',c_pm25s ,pcols,lchnk) -!akc6+ - call outfld('PM2P5 ',c_pm25 ,pcols,lchnk) - call outfld('MMRPM2P5',mmr_pm25,pcols,lchnk) - call outfld('MMRPM1 ',mmr_pm1 ,pcols,lchnk) - call outfld('MMRPM2P5_SRF',mmr_pm25(:pcols,pver),pcols,lchnk) -!akc6- -! total (all r) dry concentrations (ug/m3) and loadings (mg/m2) - call outfld('DLOAD_MI',dload_mi,pcols,lchnk) - call outfld('DLOAD_SS',dload_ss,pcols,lchnk) - call outfld('DLOAD_S4',dload_s4,pcols,lchnk) - call outfld('DLOAD_OC',dload_oc,pcols,lchnk) - call outfld('DLOAD_BC',dload_bc,pcols,lchnk) - - call outfld('LOADBCAC',dload_bc_ac,pcols,lchnk) - call outfld('LOADBC0 ',dload_bc_0,pcols,lchnk) - call outfld('LOADBC2 ',dload_bc_2,pcols,lchnk) - call outfld('LOADBC4 ',dload_bc_4,pcols,lchnk) - call outfld('LOADBC12',dload_bc_12,pcols,lchnk) - call outfld('LOADBC14',dload_bc_14,pcols,lchnk) - call outfld('LOADOCAC',dload_oc_ac,pcols,lchnk) - call outfld('LOADOC4 ',dload_oc_4,pcols,lchnk) - call outfld('LOADOC14',dload_oc_14,pcols,lchnk) -! condensed water mmr (kg/kg) - call outfld('MMR_AH2O',mmr_aerh2o,pcols,lchnk) -! condensed water loading (mg/m2) - call outfld('DAERH2O ',daerh2o ,pcols,lchnk) -! number concentrations (1/cm3) - call outfld('NNAT_0 ',nnat_0 ,pcols,lchnk) - call outfld('NNAT_1 ',nnat_1 ,pcols,lchnk) - call outfld('NNAT_2 ',nnat_2 ,pcols,lchnk) -!=0 call outfld('NNAT_3 ',nnat_3 ,pcols,lchnk) - call outfld('NNAT_4 ',nnat_4 ,pcols,lchnk) - call outfld('NNAT_5 ',nnat_5 ,pcols,lchnk) - call outfld('NNAT_6 ',nnat_6 ,pcols,lchnk) - call outfld('NNAT_7 ',nnat_7 ,pcols,lchnk) - call outfld('NNAT_8 ',nnat_8 ,pcols,lchnk) - call outfld('NNAT_9 ',nnat_9 ,pcols,lchnk) - call outfld('NNAT_10 ',nnat_10,pcols,lchnk) -!=0 call outfld('NNAT_11 ',nnat_11,pcols,lchnk) - call outfld('NNAT_12 ',nnat_12,pcols,lchnk) -!=0 call outfld('NNAT_13 ',nnat_13,pcols,lchnk) - call outfld('NNAT_14 ',nnat_14,pcols,lchnk) -!akc6 call outfld('AIRMASSL',airmassl,pcols,lchnk) - call outfld('AIRMASSL',airmassl,pcols,lchnk) - call outfld('AIRMASS ',airmass,pcols,lchnk) !akc6 - -!c_er3d -! effective dry radii (um) in each layer -! call outfld('ERLT053D',erlt053d,pcols,lchnk) -! call outfld('ERGT053D',ergt053d,pcols,lchnk) -! call outfld('ER3D ',er3d ,pcols,lchnk) -!c_er3d -! column integrated effective dry radii (um) - call outfld('DERLT05 ',derlt05,pcols,lchnk) - call outfld('DERGT05 ',dergt05,pcols,lchnk) - call outfld('DER ',der ,pcols,lchnk) -! - -!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - -! Extra AeroCom diagnostics requiring table look-ups with RH = constant + ! Internally and externally mixed dry concentrations (ug/m3) of + ! SO4, BC and OC, for all r, r<0.5um and r>1.25um... + ! call outfld('C_BCPM ',c_bc ,pcols,lchnk) + ! call outfld('C_BC05 ',c_bc05 ,pcols,lchnk) + ! call outfld('C_BC125 ',c_bc125,pcols,lchnk) + ! call outfld('C_OCPM ',c_oc ,pcols,lchnk) + ! call outfld('C_OC05 ',c_oc05 ,pcols,lchnk) + ! call outfld('C_OC125 ',c_oc125,pcols,lchnk) + ! call outfld('C_S4PM ',c_s4 ,pcols,lchnk) + ! call outfld('C_S405 ',c_s405 ,pcols,lchnk) + ! call outfld('C_S4125 ',c_s4125,pcols,lchnk) + ! ... and of background components for all r, r<0.5um and r>1.25um + ! call outfld('C_MIPM ',c_mi ,pcols,lchnk) + ! call outfld('C_MI05 ',c_mi05 ,pcols,lchnk) + ! call outfld('C_MI125 ',c_mi125,pcols,lchnk) + ! call outfld('C_SSPM ',c_ss ,pcols,lchnk) + ! call outfld('C_SS05 ',c_ss05 ,pcols,lchnk) + ! call outfld('C_SS125 ',c_ss125,pcols,lchnk) + call outfld('PMTOT ',c_tots ,pcols,lchnk) + call outfld('PM25 ',c_pm25s ,pcols,lchnk) + !akc6+ + call outfld('PM2P5 ',c_pm25 ,pcols,lchnk) + call outfld('MMRPM2P5',mmr_pm25,pcols,lchnk) + call outfld('MMRPM1 ',mmr_pm1 ,pcols,lchnk) + call outfld('MMRPM2P5_SRF',mmr_pm25(:pcols,pver),pcols,lchnk) + !akc6- + ! total (all r) dry concentrations (ug/m3) and loadings (mg/m2) + call outfld('DLOAD_MI',dload_mi,pcols,lchnk) + call outfld('DLOAD_SS',dload_ss,pcols,lchnk) + call outfld('DLOAD_S4',dload_s4,pcols,lchnk) + call outfld('DLOAD_OC',dload_oc,pcols,lchnk) + call outfld('DLOAD_BC',dload_bc,pcols,lchnk) + + call outfld('LOADBCAC',dload_bc_ac,pcols,lchnk) + call outfld('LOADBC0 ',dload_bc_0,pcols,lchnk) + call outfld('LOADBC2 ',dload_bc_2,pcols,lchnk) + call outfld('LOADBC4 ',dload_bc_4,pcols,lchnk) + call outfld('LOADBC12',dload_bc_12,pcols,lchnk) + call outfld('LOADBC14',dload_bc_14,pcols,lchnk) + call outfld('LOADOCAC',dload_oc_ac,pcols,lchnk) + call outfld('LOADOC4 ',dload_oc_4,pcols,lchnk) + call outfld('LOADOC14',dload_oc_14,pcols,lchnk) + ! condensed water mmr (kg/kg) + call outfld('MMR_AH2O',mmr_aerh2o,pcols,lchnk) + ! condensed water loading (mg/m2) + call outfld('DAERH2O ',daerh2o ,pcols,lchnk) + ! number concentrations (1/cm3) + call outfld('NNAT_0 ',nnat_0 ,pcols,lchnk) + call outfld('NNAT_1 ',nnat_1 ,pcols,lchnk) + call outfld('NNAT_2 ',nnat_2 ,pcols,lchnk) + !=0 call outfld('NNAT_3 ',nnat_3 ,pcols,lchnk) + call outfld('NNAT_4 ',nnat_4 ,pcols,lchnk) + call outfld('NNAT_5 ',nnat_5 ,pcols,lchnk) + call outfld('NNAT_6 ',nnat_6 ,pcols,lchnk) + call outfld('NNAT_7 ',nnat_7 ,pcols,lchnk) + call outfld('NNAT_8 ',nnat_8 ,pcols,lchnk) + call outfld('NNAT_9 ',nnat_9 ,pcols,lchnk) + call outfld('NNAT_10 ',nnat_10,pcols,lchnk) + !=0 call outfld('NNAT_11 ',nnat_11,pcols,lchnk) + call outfld('NNAT_12 ',nnat_12,pcols,lchnk) + !=0 call outfld('NNAT_13 ',nnat_13,pcols,lchnk) + call outfld('NNAT_14 ',nnat_14,pcols,lchnk) + !akc6 call outfld('AIRMASSL',airmassl,pcols,lchnk) + call outfld('AIRMASSL',airmassl,pcols,lchnk) + call outfld('AIRMASS ',airmass,pcols,lchnk) !akc6 + + !c_er3d + ! effective dry radii (um) in each layer + ! call outfld('ERLT053D',erlt053d,pcols,lchnk) + ! call outfld('ERGT053D',ergt053d,pcols,lchnk) + ! call outfld('ER3D ',er3d ,pcols,lchnk) + !c_er3d + ! column integrated effective dry radii (um) + call outfld('DERLT05 ',derlt05,pcols,lchnk) + call outfld('DERGT05 ',dergt05,pcols,lchnk) + call outfld('DER ',der ,pcols,lchnk) + ! + + !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + + ! Extra AeroCom diagnostics requiring table look-ups with RH = constant #ifdef AEROCOM_INSITU - irfmax=6 + irfmax=6 #else - irfmax=1 + irfmax=1 #endif ! AEROCOM_INSITU -! Note: using xrhnull etc as proxy for constant RH input values (see opttab.F90) - do irf=1,irfmax + ! Note: using xrhnull etc as proxy for constant RH input values (see opttab.F90) + do irf=1,irfmax do k=1,pver - do icol=1,ncol - xrhnull(icol,k)=xrhrf(irf) - irh1null(icol,k)=irhrf1(irf) - end do - enddo - call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrhnull, irh1null, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana, & - bext440, bext500, bext550, bext670, bext870, & - bebg440, bebg500, bebg550, bebg670, bebg870, & - bebc440, bebc500, bebc550, bebc670, bebc870, & - beoc440, beoc500, beoc550, beoc670, beoc870, & - besu440, besu500, besu550, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebglt1, bebggt1, bebclt1, bebcgt1, & - beoclt1, beocgt1, bes4lt1, bes4gt1, & - backsc550, babg550, babc550, baoc550, basu550, & - bext440n, bext500n, bext550n, bext670n, bext870n, & - bebg440n, bebg500n, bebg550n, bebg670n, bebg870n, & - bebc440n, bebc500n, bebc550n, bebc670n, bebc870n, & - beoc440n, beoc500n, beoc550n, beoc670n, beoc870n, & - besu440n, besu500n, besu550n, besu670n, besu870n, & - babs440n, babs500n, babs550n, babs670n, babs870n, & - bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & - beoclt1n, beocgt1n, bes4lt1n, bes4gt1n, & - backsc550n, babg550n, babc550n, baoc550n, basu550n) - end do ! irf - -!000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - - -#endif ! ***********AEROCOM***********AEROCOM**************AEROCOM***************above - - - return -end subroutine pmxsub - + do icol=1,ncol + xrhnull(icol,k)=xrhrf(irf) + irh1null(icol,k)=irhrf1(irf) + end do + enddo + call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrhnull, irh1null, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) + end do ! irf + + !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + + + ! ***********AEROCOM***********AEROCOM**************AEROCOM***************above + + return + end subroutine pmxsub + end module pmxsub_mod diff --git a/src/physics/cam_oslo/update_aeropt_mod.F90 b/src/physics/cam_oslo/update_aeropt_mod.F90 deleted file mode 100644 index 57b9004818..0000000000 --- a/src/physics/cam_oslo/update_aeropt_mod.F90 +++ /dev/null @@ -1,768 +0,0 @@ -module update_aeropt_mod - - use shr_kind_mod , only : r8 => shr_kind_r8 - use ppgrid , only : pcols, pver - use commondefinitions , only : nmodes, nbmodes - use opttab , only : cate, cat, fac, faq, fbc - use aeropt_mod , only : bep1, beg2to3, beb4, beg5to10 - use aeropt_mod , only : bex440, bax440, bex500, bax500, bax550 - use aeropt_mod , only : bex670, bax670, bex870, bax870 - use aeropt_mod , only : bex550lt1, bex550gt1, backscx550 - - implicit none - - type, public :: extinction_coeffs_type - ! Modal total and absorption extiction coefficients (for AeroCom) - ! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). - ! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). - - real(r8) :: bext440(pcols,pver,0:nbmodes) - real(r8) :: babs440(pcols,pver,0:nbmodes) - real(r8) :: bext500(pcols,pver,0:nbmodes) - real(r8) :: babs500(pcols,pver,0:nbmodes) - real(r8) :: bext550(pcols,pver,0:nbmodes) - real(r8) :: babs550(pcols,pver,0:nbmodes) - real(r8) :: bext670(pcols,pver,0:nbmodes) - real(r8) :: babs670(pcols,pver,0:nbmodes) - real(r8) :: bext870(pcols,pver,0:nbmodes) - real(r8) :: babs870(pcols,pver,0:nbmodes) - real(r8) :: bebg440(pcols,pver,0:nbmodes) - real(r8) :: bebg500(pcols,pver,0:nbmodes) - real(r8) :: bebg550(pcols,pver,0:nbmodes) - real(r8) :: babg550(pcols,pver,0:nbmodes) - real(r8) :: bebg670(pcols,pver,0:nbmodes) - real(r8) :: bebg870(pcols,pver,0:nbmodes) - real(r8) :: bebc440(pcols,pver,0:nbmodes) - real(r8) :: bebc500(pcols,pver,0:nbmodes) - real(r8) :: bebc550(pcols,pver,0:nbmodes) - real(r8) :: babc550(pcols,pver,0:nbmodes) - real(r8) :: bebc670(pcols,pver,0:nbmodes) - real(r8) :: bebc870(pcols,pver,0:nbmodes) - real(r8) :: beoc440(pcols,pver,0:nbmodes) - real(r8) :: beoc500(pcols,pver,0:nbmodes) - real(r8) :: beoc550(pcols,pver,0:nbmodes) - real(r8) :: baoc550(pcols,pver,0:nbmodes) - real(r8) :: beoc670(pcols,pver,0:nbmodes) - real(r8) :: beoc870(pcols,pver,0:nbmodes) - real(r8) :: besu440(pcols,pver,0:nbmodes) - real(r8) :: besu500(pcols,pver,0:nbmodes) - real(r8) :: besu550(pcols,pver,0:nbmodes) - real(r8) :: basu550(pcols,pver,0:nbmodes) - real(r8) :: besu670(pcols,pver,0:nbmodes) - real(r8) :: besu870(pcols,pver,0:nbmodes) - real(r8) :: bebg550lt1(pcols,pver,0:nbmodes) - real(r8) :: bebg550gt1(pcols,pver,0:nbmodes) - real(r8) :: bebc550lt1(pcols,pver,0:nbmodes) - real(r8) :: bebc550gt1(pcols,pver,0:nbmodes) - real(r8) :: beoc550lt1(pcols,pver,0:nbmodes) - real(r8) :: beoc550gt1(pcols,pver,0:nbmodes) - real(r8) :: besu550lt1(pcols,pver,0:nbmodes) - real(r8) :: besu550gt1(pcols,pver,0:nbmodes) - real(r8) :: backsc550(pcols,pver,0:nbmodes) - - contains - - procedure :: zero_coeffs - procedure :: update_coeffs - - end type extinction_coeffs_type - - type(extinction_coeffs_type), public :: extinction_coeffs - type(extinction_coeffs_type), public :: extinction_coeffsn - - public :: intaeropt0 - public :: intaeropt1 - public :: intaeropt2to3 - public :: intaeropt4 - public :: intaeropt5to10 - -! ========================================================== -contains -! ========================================================== - - subroutine zero_coeffs(this, kcomp, ncol) - - class(extinction_coeffs_type) :: this - integer , intent(in) :: kcomp - integer , intent(in) :: ncol - - integer :: k - integer :: icol - - ! initialize all output fields to zero - do k=1,pver - do icol=1,ncol - this%bext440(icol,k,kcomp) = 0.0_r8 - this%babs440(icol,k,kcomp) = 0.0_r8 - this%bext500(icol,k,kcomp) = 0.0_r8 - this%babs500(icol,k,kcomp) = 0.0_r8 - this%bext550(icol,k,kcomp) = 0.0_r8 - this%babs550(icol,k,kcomp) = 0.0_r8 - this%bext670(icol,k,kcomp) = 0.0_r8 - this%babs670(icol,k,kcomp) = 0.0_r8 - this%bext870(icol,k,kcomp) = 0.0_r8 - this%babs870(icol,k,kcomp) = 0.0_r8 - this%bebg440(icol,k,kcomp) = 0.0_r8 - this%bebg500(icol,k,kcomp) = 0.0_r8 - this%bebg550(icol,k,kcomp) = 0.0_r8 - this%babg550(icol,k,kcomp) = 0.0_r8 - this%bebg670(icol,k,kcomp) = 0.0_r8 - this%bebg870(icol,k,kcomp) = 0.0_r8 - this%bebc440(icol,k,kcomp) = 0.0_r8 - this%bebc500(icol,k,kcomp) = 0.0_r8 - this%bebc550(icol,k,kcomp) = 0.0_r8 - this%babc550(icol,k,kcomp) = 0.0_r8 - this%bebc670(icol,k,kcomp) = 0.0_r8 - this%bebc870(icol,k,kcomp) = 0.0_r8 - this%beoc440(icol,k,kcomp) = 0.0_r8 - this%beoc500(icol,k,kcomp) = 0.0_r8 - this%beoc550(icol,k,kcomp) = 0.0_r8 - this%baoc550(icol,k,kcomp) = 0.0_r8 - this%beoc670(icol,k,kcomp) = 0.0_r8 - this%beoc870(icol,k,kcomp) = 0.0_r8 - this%besu440(icol,k,kcomp) = 0.0_r8 - this%besu500(icol,k,kcomp) = 0.0_r8 - this%besu550(icol,k,kcomp) = 0.0_r8 - this%basu550(icol,k,kcomp) = 0.0_r8 - this%besu670(icol,k,kcomp) = 0.0_r8 - this%besu870(icol,k,kcomp) = 0.0_r8 - this%bebg550lt1(icol,k,kcomp) = 0.0_r8 - this%bebg550gt1(icol,k,kcomp) = 0.0_r8 - this%bebc550lt1(icol,k,kcomp) = 0.0_r8 - this%bebc550gt1(icol,k,kcomp) = 0.0_r8 - this%beoc550lt1(icol,k,kcomp) = 0.0_r8 - this%beoc550gt1(icol,k,kcomp) = 0.0_r8 - this%besu550lt1(icol,k,kcomp) = 0.0_r8 - this%besu550gt1(icol,k,kcomp) = 0.0_r8 - this%backsc550(icol,k,kcomp) = 0.0_r8 - end do - end do - - end subroutine zero_coeffs - - ! ========================================================== - subroutine update_coeffs(this, icol, k, kcomp) - - class(extinction_coeffs_type) :: this - integer , intent(in) :: icol - integer , intent(in) :: k - integer , intent(in) :: kcomp - real(r8) , intent(in) :: opt(:) - - this%bext440(icol,k,kcomp) = opt(1) - this%bext500(icol,k,kcomp) = opt(2) - this%bext670(icol,k,kcomp) = opt(3) - this%bext870(icol,k,kcomp) = opt(4) - this%bebg440(icol,k,kcomp) = opt(5) - this%bebg500(icol,k,kcomp) = opt(6) - this%bebg670(icol,k,kcomp) = opt(7) - this%bebg870(icol,k,kcomp) = opt(8) - this%bebc440(icol,k,kcomp) = opt(9) - this%bebc500(icol,k,kcomp) = opt(10) - this%bebc670(icol,k,kcomp) = opt(11) - this%bebc870(icol,k,kcomp) = opt(12) - this%beoc440(icol,k,kcomp) = opt(13) - this%beoc500(icol,k,kcomp) = opt(14) - this%beoc670(icol,k,kcomp) = opt(15) - this%beoc870(icol,k,kcomp) = opt(16) - this%besu440(icol,k,kcomp) = opt(17) - this%besu500(icol,k,kcomp) = opt(18) - this%besu670(icol,k,kcomp) = opt(19) - this%besu870(icol,k,kcomp) = opt(20) - this%babs440(icol,k,kcomp) = opt(21) - this%babs500(icol,k,kcomp) = opt(22) - this%babs550(icol,k,kcomp) = opt(23) - this%babs670(icol,k,kcomp) = opt(24) - this%babs870(icol,k,kcomp) = opt(25) - this%bebg550lt1(icol,k,kcomp) = opt(26) - this%bebg550gt1(icol,k,kcomp) = opt(27) - this%bebc550lt1(icol,k,kcomp) = opt(28) - this%bebc550gt1(icol,k,kcomp) = opt(29) - this%beoc550lt1(icol,k,kcomp) = opt(30) - this%beoc550gt1(icol,k,kcomp) = opt(31) - this%besu550lt1(icol,k,kcomp) = opt(32) - this%besu550gt1(icol,k,kcomp) = opt(33) - this%backsc550(icol,k,kcomp) = opt(34) - this%babg550(icol,k,kcomp) = opt(35) - this%babc550(icol,k,kcomp) = opt(36) - this%baoc550(icol,k,kcomp) = opt(37) - this%basu550(icol,k,kcomp) = opt(38) - this%bebg550(icol,k,kcomp) = opt(26)+opt(27) - this%bebc550(icol,k,kcomp) = opt(28)+opt(29) - this%beoc550(icol,k,kcomp) = opt(30)+opt(31) - this%besu550(icol,k,kcomp) = opt(32)+opt(33) - this%bext550(icol,k,kcomp) = bebg550(icol,k,kcomp)+bebc550(icol,k,kcomp) & - +beoc550(icol,k,kcomp)+besu550(icol,k,kcomp) - - end subroutine update_coeffs - - ! ========================================================== - subroutine intaeropt0 (lchnk, ncol, Nnatk, extinction_coeffs) - - ! Arguments - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - type(extinction_coeffs), intent(inout) :: extinction_coeffs - - ! Local variables - integer i, iv, ierr, k, kcomp, icol - - kcomp=0 - extinction_coeffs%zero_coeffs(kcomp, ncol) - - ! BC(ax) mode: update below to non-xero values - do k = 1,pver - do icol = 1,ncol - if(Nnatk(icol,k,kcomp).gt.0) then - bext440(icol,k,kcomp)=bex440 - babs440(icol,k,kcomp)=bax440 - bext500(icol,k,kcomp)=bex500 - babs500(icol,k,kcomp)=bax500 - bext550(icol,k,kcomp)=bex550lt1+bex550gt1 - babs550(icol,k,kcomp)=bax550 - bext670(icol,k,kcomp)=bex670 - babs670(icol,k,kcomp)=bax670 - bext870(icol,k,kcomp)=bex870 - babs870(icol,k,kcomp)=bax870 - bebg440(icol,k,kcomp)=bex440 - bebg500(icol,k,kcomp)=bex500 - bebg550(icol,k,kcomp)=bex550lt1+bex550gt1 - babg550(icol,k,kcomp)=bax550 - bebg670(icol,k,kcomp)=bex670 - bebg870(icol,k,kcomp)=bex870 - bebg550lt1(icol,k,kcomp)=bex550lt1 - bebg550gt1(icol,k,kcomp)=bex550gt1 - backsc550(icol,k,kcomp)=backscx550 - endif - end do ! icol - end do ! k - - end subroutine intaeropt0 - - ! ========================================================== - subroutine intaeropt1 (lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & - extinction_coeffs) - - ! arguments - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode - integer , intent(in) :: ifombg1(pcols,pver) - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - type(extinction_coeffs) , intent(inout) :: extinction_coeffs - - ! local variables - real(r8) :: a, b, e, eps - integer :: i, iv, ierr, irelh, ifombg, ictot, ifac, kcomp, k, icol, kc10 - ! Temporary storage of often used array elements - integer :: t_irh1, t_irh2, t_ifo1, t_ifo2, t_ict1, t_ict2, t_ifc1, t_ifc2 - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_xrh, t_rh1, t_rh2, t_fombg1, t_fombg2, t_xfombg - real(r8) :: t_xct, t_cat1, t_cat2 - real(r8) :: d2mx(4), dxm1(4), invd(4) - real(r8) :: opt4d(2,2,2,2) - real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) :: opt1, opt2, opt(38) - - parameter :: (e=2.718281828_r8, eps=1.0e-60_r8) - - ! SO4/SOA(Ait) mode: - kcomp = 1 - extinction_coeffs%zero_coeffs(kcomp, ncol) - - if(mplus10 == 0) then - kc10 = kcomp - else - write(*,*) "mplus10=1 is no loger an option for kcomp=1." - stop - endif - - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kc10).gt.0) then - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ifo1 = ifombg1(icol,k) - t_ifo2 = t_ifo1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_fombg1 = fombg(t_ifo1) - t_fombg2 = fombg(t_ifo2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - t_xfombg = xfombg(icol,k) - - ! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fombg2-t_xfombg) - dxm1(2) = (t_xfombg-t_fombg1) - invd(2) = 1.0_r8/(t_fombg2-t_fombg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - - do iv=1,38 ! variable number - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1) = bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2) = bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1) = bep1(iv,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2) = bep1(iv,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1) = bep1(iv,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2) = bep1(iv,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1) = bep1(iv,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2) = bep1(iv,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1) = bep1(iv,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2) = bep1(iv,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1) = bep1(iv,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2) = bep1(iv,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1) = bep1(iv,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2) = bep1(iv,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1) = bep1(iv,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2) = bep1(iv,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) - - ! finally, interpolation in the rh dimension - opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) / (t_rh2-t_rh1) - end do ! iv=1,38 - - ! determin extinction coefficient - extinction_coeffs%update_coeffs(icol, k, kcomp, opt) - - end if - end do ! end of icol loop - end do ! end of k loop - - end subroutine intaeropt1 - - ! ========================================================== - subroutine intaeropt2to3 (lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, extinction_coeffs) - - ! Extended by Alf Kirkevaag to include SOA in September 2015 - - ! Arguments - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - - ! Local variables - real(r8) :: a, b, e, eps - integer :: i, iv, kcomp, k, icol, kc10 - ! Temporary storage of often used array elements - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 - real(r8) :: t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 - real(r8) :: d2mx(3), dxm1(3), invd(3) - real(r8) :: opt3d(2,2,2) - real(r8) :: opt1, opt2, opt(38) - - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! SO4(Ait), BC(Ait) and OC(Ait) modes: - - do kcomp=2,3 - extinction_coeffs%zero_coeffs(kcomp, ncol) - end do - - kcomp = 2 ! kcomp=3 is no longer used - do k=1,pver - do icol=1,ncol - - if(Nnatk(icol,k,kc10).gt.0) then - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - - ! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - - do iv=1,38 ! variable number - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=bep2to3(iv,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=bep2to3(iv,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=bep2to3(iv,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=bep2to3(iv,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=bep2to3(iv,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=bep2to3(iv,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=bep2to3(iv,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=bep2to3(iv,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, opt1, opt2) - - ! finally, interpolation in the rh dimension - opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - - end do ! iv=1,38 - - ! determine extinction coefficient - extinction_coeffs%update_coeffs(icol, k, kcomp, opt) - - end if ! Nnatk > 0 - end do ! icol - end do ! k - - end subroutine intaeropt2to3 - - ! ========================================================== - subroutine intaeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1, & - extinction_coeffs) - - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xfbcbg(pcols,pver) - integer , intent(in) :: ifbcbg1(pcols,pver) - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer , intent(in) :: ifaq1(pcols,pver,nbmodes) - type(extinction_coeffs), intent(inout) :: extinction_coeffs - - ! Local variables - real(r8) :: a, b, e, eps - integer :: i, iv, kcomp, k, icol, kc10 - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 - real(r8) :: t_fbcbg1, t_fbcbg2 - integer :: t_ifb1, t_ifb2 - real(r8) :: t_faq1, t_faq2, t_xfaq - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 - real(r8) :: t_cat1, t_cat2 - real(r8) :: t_xfbcbg - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: opt1, opt2, opt(38) - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! BC&OC(Ait) mode: - kcomp = 4 - extinction_coeffs%zero_coeffs(kcomp, ncol) - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kc10).gt.0) then - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ifb1 = ifbcbg1(icol,k) - t_ifb2 = t_ifb1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xfbcbg = xfbcbg(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fbcbg2-t_xfbcbg) - dxm1(2) = (t_xfbcbg-t_fbcbg1) - invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - do iv=1,38 ! variable number - - opt5d(1,1,1,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - - ! finally, interpolation in the rh dimension - opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - - end do ! iv=1,38 - - ! determine extinction coefficient - extinction_coeffs%update_coeffs(icol, k, kcomp, opt) - - end if ! Nnatk > 0 - end do ! icol - end do ! k - - end subroutine intaeropt4 - - ! ========================================================== - subroutine intaeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - extinction_coeffs) - - ! Arguments - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) - integer , intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer , intent(in) :: ifaq1(pcols,pver,nbmodes) - - ! Local variables - real(r8) :: a, b, e, eps - integer :: i, iv, kcomp, k, icol - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 - integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) :: t_faq1, t_faq2, t_xfaq - real(r8) :: t_fbc1, t_fbc2, t_xfbc - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 - real(r8) :: t_cat1, t_cat2 - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: opt1, opt2, opt(38) - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): - - do kcomp=5,10 - ! zero extinction coefficients for this kcomp - extinction_coeffs%zero_coeffs(kcomp, ncol) - - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kcomp).gt.0) then - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - t_ifb1 = ifbc1(icol,k,kcomp) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cat(kcomp,t_ict1) - t_cat2 = cat(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbc1 = fbc(t_ifb1) - t_fbc2 = fbc(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfbc = xfbc(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - d2mx(4) = (t_fbc2-t_xfbc) - dxm1(4) = (t_xfbc-t_fbc1) - invd(4) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - do iv=1,38 ! variable number - opt5d(1,1,1,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - - ! finally, interpolation in the rh dimension - opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - - end do ! iv=1,38 - - ! determine extinction coefficient - extinction_coeffs%update_coeffs(icol, k, kcomp, opt) - - end if ! Nnatk > 0 - end do ! icol - end do ! k - end do ! kcomp - - end subroutine intaeropt5to10 - -end module update_aeropt_mod - From 821542a2a3ca4d20611fc982e62f1e7aebc72b6f Mon Sep 17 00:00:00 2001 From: mvertens Date: Mon, 14 Aug 2023 10:38:13 +0200 Subject: [PATCH 04/71] back up refactor of pmxsub --- src/physics/cam_oslo/aeroopt_mod.F90 | 129 +- src/physics/cam_oslo/opticsAtConstRh.F90 | 20 +- src/physics/cam_oslo/pmxsub.F90 | 3344 +++++++++++----------- 3 files changed, 1701 insertions(+), 1792 deletions(-) diff --git a/src/physics/cam_oslo/aeroopt_mod.F90 b/src/physics/cam_oslo/aeroopt_mod.F90 index d3afbe5d69..5f49362755 100644 --- a/src/physics/cam_oslo/aeroopt_mod.F90 +++ b/src/physics/cam_oslo/aeroopt_mod.F90 @@ -98,34 +98,34 @@ module aeroopt_mod subroutine init_aeropt - !Purpose: To read in the AeroCom look-up tables for aerosol optical properties. - ! The grid for discrete input-values in the look-up tables is defined in opptab. + !Purpose: To read in the AeroCom look-up tables for aerosol optical properties. + ! The grid for discrete input-values in the look-up tables is defined in opptab. ! Tabulating the 'aerocomk'-files to save computing time. ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 ! Extended for new SOA treatment - Alf Kirkevaag, September 2015. - ! Modified for optimized added masses and mass fractions for - ! concentrations from condensation, coagulation or cloud-processing - ! - Alf Kirkevaag, May 2016. - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + ! Modified for optimized added masses and mass fractions for + ! concentrations from condensation, coagulation or cloud-processing + ! - Alf Kirkevaag, May 2016. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. integer :: ic, ifil, lin, iv integer :: kcomp, irelh, ictot, ifac, ifbc, ifaq integer :: ifombg, ifbcbg - real(r8) :: catot, relh, frbcbg, frac, fabc, fraq - real(r8) :: bext440, babs440, bext500, babs500, babs550 - real(r8) :: bext670, babs670, bext870, babs870 - real(r8) :: bebg440, babg440, bebg500, babg500, babg550 - real(r8) :: bebg670, babg670, bebg870, babg870 - real(r8) :: bebc440, babc440, bebc500, babc500, babc550 - real(r8) :: bebc670, babc670, bebc870, babc870 - real(r8) :: beoc440, baoc440, beoc500, baoc500, baoc550 - real(r8) :: beoc670, baoc670, beoc870, baoc870 - real(r8) :: besu440, basu440, besu500, basu500, basu550 - real(r8) :: besu670, basu670, besu870, basu870 - real(r8) :: bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1 - real(r8) :: beoc550lt1, beoc550gt1, besu550lt1, besu550gt1 + real(r8) :: catot, relh, frbcbg, frac, fabc, fraq + real(r8) :: bext440, babs440, bext500, babs500, babs550 + real(r8) :: bext670, babs670, bext870, babs870 + real(r8) :: bebg440, babg440, bebg500, babg500, babg550 + real(r8) :: bebg670, babg670, bebg870, babg870 + real(r8) :: bebc440, babc440, bebc500, babc500, babc550 + real(r8) :: bebc670, babc670, bebc870, babc870 + real(r8) :: beoc440, baoc440, beoc500, baoc500, baoc550 + real(r8) :: beoc670, baoc670, beoc870, baoc870 + real(r8) :: besu440, basu440, besu500, basu500, basu550 + real(r8) :: besu670, basu670, besu870 + real(r8) :: bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1 + real(r8) :: beoc550lt1, beoc550gt1, besu550lt1, besu550gt1 real(r8) :: backscat550 real(r8) :: eps2 = 1.e-2_r8 real(r8) :: eps4 = 1.e-4_r8 @@ -213,7 +213,7 @@ subroutine init_aeropt bep1(1,irelh,ifombg,ictot,ifac) = bext440 ! unit km^-1 bep1(2,irelh,ifombg,ictot,ifac) = bext500 - bep1(3,irelh,ifombg,ictot,ifac) = bext670 + bep1(3,irelh,ifombg,ictot,ifac) = bext670 bep1(4,irelh,ifombg,ictot,ifac) = bext870 bep1(5,irelh,ifombg,ictot,ifac) = bebg440 bep1(6,irelh,ifombg,ictot,ifac) = bebg500 @@ -265,8 +265,8 @@ subroutine init_aeropt enddo enddo enddo - write(iulog,*)'aerocom mode 1 ok' - ! + write(iulog,*)'aerocom mode 1 ok' + ! !------------------------------------------- ! Mode 2 (BC/OC + condesate from H2SO4 and SOA) ! Note that mode 3 is no longer active @@ -306,7 +306,7 @@ subroutine init_aeropt bep2to3(1,irelh,ictot,ifac,kcomp) = bext440 ! unit km^-1 bep2to3(2,irelh,ictot,ifac,kcomp) = bext500 - bep2to3(3,irelh,ictot,ifac,kcomp) = bext670 + bep2to3(3,irelh,ictot,ifac,kcomp) = bext670 bep2to3(4,irelh,ictot,ifac,kcomp) = bext870 bep2to3(5,irelh,ictot,ifac,kcomp) = bebg440 bep2to3(6,irelh,ictot,ifac,kcomp) = bebg500 @@ -369,7 +369,7 @@ subroutine init_aeropt enddo enddo enddo - write(iulog,*)'aerocom mode 2-3 ok' + write(iulog,*)'aerocom mode 2-3 ok' ! !------------------------------------------- ! Mode 4 (BC&OC + condesate from H2SO4 and SOA + wetphase (NH4)2SO4) @@ -422,7 +422,7 @@ subroutine init_aeropt bep4(1,irelh,ifbcbg,ictot,ifac,ifaq) = bext440 ! unit km^-1 bep4(2,irelh,ifbcbg,ictot,ifac,ifaq) = bext500 - bep4(3,irelh,ifbcbg,ictot,ifac,ifaq) = bext670 + bep4(3,irelh,ifbcbg,ictot,ifac,ifaq) = bext670 bep4(4,irelh,ifbcbg,ictot,ifac,ifaq) = bext870 bep4(5,irelh,ifbcbg,ictot,ifac,ifaq) = bebg440 bep4(6,irelh,ifbcbg,ictot,ifac,ifaq) = bebg500 @@ -477,7 +477,7 @@ subroutine init_aeropt enddo enddo write(iulog,*)'aerocom mode 4 ok' - ! + ! !------------------------------------------- ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.) !------------------------------------------- @@ -529,7 +529,7 @@ subroutine init_aeropt bep5to10(1,irelh,ictot,ifac,ifbc,ifaq,kcomp) = bext440 ! unit km^-1 bep5to10(2,irelh,ictot,ifac,ifbc,ifaq,kcomp) = bext500 - bep5to10(3,irelh,ictot,ifac,ifbc,ifaq,kcomp) = bext670 + bep5to10(3,irelh,ictot,ifac,ifbc,ifaq,kcomp) = bext670 bep5to10(4,irelh,ictot,ifac,ifbc,ifaq,kcomp) = bext870 bep5to10(5,irelh,ictot,ifac,ifbc,ifaq,kcomp) = bebg440 bep5to10(6,irelh,ictot,ifac,ifbc,ifaq,kcomp) = bebg500 @@ -608,7 +608,7 @@ subroutine intaeropt0 (this, lchnk, ncol, Nnatk) kcomp=0 extinction_coeffs%zero_coeffs(kcomp, ncol) - ! Mode 0 BC(ax) + ! Mode 0 BC(ax) do k = 1,pver do icol = 1,ncol if(Nnatk(icol,k,kcomp).gt.0) then @@ -683,7 +683,7 @@ subroutine update_aeropt1 (lchnk, ncol, xrh, irh1, mplus10, & stop endif - do k=1,pver + do k=1,pver do icol=1,ncol if(Nnatk(icol,k,kc10).gt.0) then @@ -714,7 +714,7 @@ subroutine update_aeropt1 (lchnk, ncol, xrh, irh1, mplus10, & t_xfac = xfac(icol,k,kcomp) t_xfombg = xfombg(icol,k) - ! partial lengths along each dimension (1-4) for interpolation + ! partial lengths along each dimension (1-4) for interpolation d2mx(1) = (t_rh2-t_xrh) dxm1(1) = (t_xrh-t_rh1) invd(1) = 1.0_r8/(t_rh2-t_rh1) @@ -729,7 +729,7 @@ subroutine update_aeropt1 (lchnk, ncol, xrh, irh1, mplus10, & invd(4) = 1.0_r8/(t_fac2-t_fac1) do iv=1,38 ! variable number - ! end points as basis for multidimentional linear interpolation + ! end points as basis for multidimentional linear interpolation opt4d(1,1,1,1) = bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc1) opt4d(1,1,1,2) = bep1(iv,t_irh1,t_ifo1,t_ict1,t_ifc2) opt4d(1,1,2,1) = bep1(iv,t_irh1,t_ifo1,t_ict2,t_ifc1) @@ -750,9 +750,9 @@ subroutine update_aeropt1 (lchnk, ncol, xrh, irh1, mplus10, & ! interpolation in the fac, cat and fombg dimensions call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) - ! finally, interpolation in the rh dimension - opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) / (t_rh2-t_rh1) - end do ! iv=1,38 + ! finally, interpolation in the rh dimension + opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) / (t_rh2-t_rh1) + end do ! iv=1,38 ! determine extinction coefficient extinction_coeffs%update_coeffs(icol, k, kcomp, opt) @@ -775,11 +775,11 @@ subroutine update_aeropt2to3 (lchnk, ncol, xrh, irh1, mplus10, & integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) + integer , intent(in) :: ict1(pcols,pver,nmodes) real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) ! Local variables real(r8) :: a, b, e, eps @@ -795,12 +795,12 @@ subroutine update_aeropt2to3 (lchnk, ncol, xrh, irh1, mplus10, & ! SO4(Ait), BC(Ait) and OC(Ait) modes: - do kcomp=2,3 + do kcomp=2,3 extinction_coeffs%zero_coeffs(kcomp, ncol) end do - kcomp = 2 ! kcomp=3 is no longer used - do k=1,pver + kcomp = 2 ! kcomp=3 is no longer used + do k=1,pver do icol=1,ncol if(Nnatk(icol,k,kc10).gt.0) then @@ -824,7 +824,7 @@ subroutine update_aeropt2to3 (lchnk, ncol, xrh, irh1, mplus10, & t_xct = xct(icol,k,kc10) t_xfac = xfac(icol,k,kcomp) - ! partial lengths along each dimension (1-4) for interpolation + ! partial lengths along each dimension (1-4) for interpolation d2mx(1) = (t_rh2-t_xrh) dxm1(1) = (t_xrh-t_rh1) invd(1) = 1.0_r8/(t_rh2-t_rh1) @@ -837,7 +837,7 @@ subroutine update_aeropt2to3 (lchnk, ncol, xrh, irh1, mplus10, & do iv=1,38 ! variable number - ! end points as basis for multidimentional linear interpolation + ! end points as basis for multidimentional linear interpolation opt3d(1,1,1)=bep2to3(iv,t_irh1,t_ict1,t_ifc1,kcomp) opt3d(1,1,2)=bep2to3(iv,t_irh1,t_ict1,t_ifc2,kcomp) opt3d(1,2,1)=bep2to3(iv,t_irh1,t_ict2,t_ifc1,kcomp) @@ -851,9 +851,9 @@ subroutine update_aeropt2to3 (lchnk, ncol, xrh, irh1, mplus10, & call lininterpol3dim (d2mx, dxm1, invd, opt3d, opt1, opt2) ! finally, interpolation in the rh dimension - opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + opt(iv)=((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - end do ! iv=1,38 + end do ! iv=1,38 ! determine extinction coefficient extinction_coeffs%update_coeffs(icol, k, kcomp, opt) @@ -874,13 +874,13 @@ subroutine update_aeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration real(r8) , intent(in) :: xfbcbg(pcols,pver) integer , intent(in) :: ifbcbg1(pcols,pver) real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) + integer , intent(in) :: ict1(pcols,pver,nmodes) real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) + integer , intent(in) :: ifac1(pcols,pver,nbmodes) real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 integer , intent(in) :: ifaq1(pcols,pver,nbmodes) type(extinction_coeffs), intent(inout) :: extinction_coeffs @@ -889,7 +889,7 @@ subroutine update_aeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & real(r8) :: a, b, e, eps integer :: i, iv, kcomp, k, icol, kc10 integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 - real(r8) :: t_fbcbg1, t_fbcbg2 + real(r8) :: t_fbcbg1, t_fbcbg2 integer :: t_ifb1, t_ifb2 real(r8) :: t_faq1, t_faq2, t_xfaq real(r8) :: t_fac1, t_fac2, t_xfac @@ -901,7 +901,7 @@ subroutine update_aeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & real(r8) :: opt1, opt2, opt(38) parameter (e=2.718281828_r8, eps=1.0e-60_r8) - ! BC&OC(Ait) mode: + ! BC&OC(Ait) mode: kcomp = 4 extinction_coeffs%zero_coeffs(kcomp, ncol) @@ -911,7 +911,7 @@ subroutine update_aeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & kc10=kcomp+10 endif - do k=1,pver + do k=1,pver do icol=1,ncol if(Nnatk(icol,k,kc10).gt.0) then ! Collect all the vector elements into temporary storage @@ -945,7 +945,7 @@ subroutine update_aeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & t_xfac = xfac(icol,k,kcomp) t_xfaq = xfaq(icol,k,kcomp) - ! partial lengths along each dimension (1-5) for interpolation + ! partial lengths along each dimension (1-5) for interpolation d2mx(1) = (t_rh2-t_xrh) dxm1(1) = (t_xrh-t_rh1) invd(1) = 1.0_r8/(t_rh2-t_rh1) @@ -1001,10 +1001,10 @@ subroutine update_aeropt4 (lchnk, ncol, xrh, irh1, mplus10, Nnatk, & ! interpolation in the faq, fac, cat and fbcbg dimensions call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - ! finally, interpolation in the rh dimension - opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + ! finally, interpolation in the rh dimension + opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - end do ! iv=1,38 + end do ! iv=1,38 ! determine extinction coefficient extinction_coeffs%update_coeffs(icol, k, kcomp, opt) @@ -1025,9 +1025,9 @@ subroutine update_aeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & integer , intent(in) :: ncol ! number of atmospheric columns real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) + integer , intent(in) :: ict1(pcols,pver,nmodes) real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) integer , intent(in) :: ifac1(pcols,pver,nbmodes) real(r8) , intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) @@ -1052,11 +1052,11 @@ subroutine update_aeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): - do kcomp=5,10 + do kcomp=5,10 ! zero extinction coefficients for this kcomp extinction_coeffs%zero_coeffs(kcomp, ncol) - do k=1,pver + do k=1,pver do icol=1,ncol if(Nnatk(icol,k,kcomp).gt.0) then ! Collect all the vector elements into temporary storage @@ -1090,8 +1090,8 @@ subroutine update_aeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & t_xfac = xfac(icol,k,kcomp) t_xfbc = xfbc(icol,k,kcomp) t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation + + ! partial lengths along each dimension (1-5) for interpolation d2mx(1) = (t_rh2-t_xrh) dxm1(1) = (t_xrh-t_rh1) invd(1) = 1.0_r8/(t_rh2-t_rh1) @@ -1146,10 +1146,10 @@ subroutine update_aeropt5to10 (lchnk, ncol, xrh, irh1, Nnatk, & ! interpolation in the faq, fbc, fac and cat dimensions call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - ! finally, interpolation in the rh dimension - opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) + ! finally, interpolation in the rh dimension + opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - end do ! iv=1,38 + end do ! iv=1,38 ! determine extinction coefficient extinction_coeffs%update_coeffs(icol, k, kcomp, opt) @@ -1278,4 +1278,3 @@ subroutine update_coeffs(this, icol, k, kcomp) end subroutine update_coeffs end module aeroopt_mod - diff --git a/src/physics/cam_oslo/opticsAtConstRh.F90 b/src/physics/cam_oslo/opticsAtConstRh.F90 index f4790c2cbf..ec061daf79 100644 --- a/src/physics/cam_oslo/opticsAtConstRh.F90 +++ b/src/physics/cam_oslo/opticsAtConstRh.F90 @@ -28,27 +28,27 @@ subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & integer, intent(in) :: ncol ! number of atmospheric columns real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) real(r8), intent(in) :: rhoda(pcols,pver) ! Density of dry air (kg/m^3) + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) integer, intent(in) :: irh1(pcols,pver) integer, intent(in) :: irf - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration - real(r8), intent(in) :: vnbc(pcols,pver) - real(r8), intent(in) :: vaitbc(pcols,pver) - real(r8), intent(in) :: v_soana(pcols,pver) - real(r8), intent(in) :: xfombg(pcols,pver) - integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) real(r8), intent(in) :: xfbcbg(pcols,pver) integer, intent(in) :: ifbcbg1(pcols,pver) real(r8), intent(in) :: xfbcbgn(pcols,pver) integer, intent(in) :: ifbcbgn1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! facm for use in the interpolations integer, intent(in) :: ifac1(pcols,pver,nbmodes) real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations integer, intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfombg(pcols,pver) + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: vnbc(pcols,pver) + real(r8), intent(in) :: vaitbc(pcols,pver) + real(r8), intent(in) :: v_soana(pcols,pver) ! !---------------------------Local variables----------------------------- ! diff --git a/src/physics/cam_oslo/pmxsub.F90 b/src/physics/cam_oslo/pmxsub.F90 index 188b46726e..e8793273fd 100644 --- a/src/physics/cam_oslo/pmxsub.F90 +++ b/src/physics/cam_oslo/pmxsub.F90 @@ -1,6 +1,12 @@ module pmxsub_mod -!#include + implicit none + +#ifdef AEROCOM + logical :: do_aerocom = .true. +#else + logical :: do_aerocom = .false. +#endif !=============================================================================== contains @@ -10,7 +16,11 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & volc_ext_sun, volc_omega_sun, volc_g_sun, & volc_ext_earth, volc_omega_earth, & +#ifdef AEROCOM aodvis, absvis, dod440, dod550, dod870, abs550, abs550alt) +#else + aodvis, absvis) +#endif ! Optical parameters for a composite aerosol is calculated by interpolation ! from the tables kcomp1.out-kcomp14.out. @@ -30,141 +40,158 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & use cam_history, only: outfld use constituents, only: pcnst use physconst, only: rair,pi - use opttab, only : cate, cat + use opttab use oslo_utils, only: calculateNumberConcentration use parmix_progncdnc, only: calculateBulkProperties, partitionMass - use opttab_lw , only : ka0, ka1, ka2to3, ka4, ka5to10 + use opttab_lw use const use aerosoldef - use commondefinitions , only : nmodes, nbmodes - use optinterpol, only: inputForInterpol + use commondefinitions use optinterpol, only: interpol0,interpol1,interpol2to3,interpol4,interpol5to10 use physics_types, only: physics_state use wv_saturation, only: qsat_water - implicit none - ! - ! Arguments + ! Input arguments + + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle + real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) + real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures (Pa) + real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures (K) + real(r8), intent(in) :: cld(pcols,pver) ! cloud fraction + real(r8), intent(in) :: qm1(pcols,pver,pcnst) ! Specific humidity and tracers (kg/kg) + real(r8), intent(in) :: volc_ext_sun(pcols,pver,nbands) ! volcanic aerosol extinction for solar bands, CMIP6 + real(r8), intent(in) :: volc_omega_sun(pcols,pver,nbands) ! volcanic aerosol SSA for solar bands, CMIP6 + real(r8), intent(in) :: volc_g_sun(pcols,pver,nbands) ! volcanic aerosol g for solar bands, CMIP6 + real(r8), intent(in) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 + real(r8), intent(in) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 + ! real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) ! for testing bare ! - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - real(r8) , intent(in) :: coszrs(pcols) ! Cosine solar zenith angle - type(physics_state) , intent(in), target :: state - real(r8) , intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) - real(r8) , intent(in) :: pmid(pcols,pver) ! Model level pressures (Pa) - real(r8) , intent(in) :: t(pcols,pver) ! Model level temperatures (K) - real(r8) , intent(in) :: cld(pcols,pver) ! cloud fraction - real(r8) , intent(in) :: qm1(pcols,pver,pcnst) ! Specific humidity and tracers (kg/kg) - real(r8) , intent(in) :: volc_ext_sun(pcols,pver,nbands) ! volcanic aerosol extinction for solar bands, CMIP6 - real(r8) , intent(in) :: volc_omega_sun(pcols,pver,nbands) ! volcanic aerosol SSA for solar bands, CMIP6 - real(r8) , intent(in) :: volc_g_sun(pcols,pver,nbands) ! volcanic aerosol g for solar bands, CMIP6 - real(r8) , intent(in) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 - real(r8) , intent(in) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 - real(r8) , intent(inout) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration - real(r8) , intent(out) :: per_tau (pcols,0:pver,nbands) ! aerosol extinction optical depth - real(r8) , intent(out) :: per_tau_w (pcols,0:pver,nbands) ! aerosol single scattering albedo * tau - real(r8) , intent(out) :: per_tau_w_g(pcols,0:pver,nbands) ! aerosol assymetry parameter * w * tau - real(r8) , intent(out) :: per_tau_w_f(pcols,0:pver,nbands) ! aerosol forward scattered fraction * w * tau - real(r8) , intent(out) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optical depth (LW) - ! AOD and absorptive AOD for visible wavelength closest to 0.55 um (0.442-0.625) - ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values - real(r8) , intent(out) :: aodvis(pcols) ! AOD vis - real(r8) , intent(out) :: absvis(pcols) ! AAOD vis + ! Input-output arguments + real(r8), intent(inout) :: Nnatk(pcols,pver,0:nmodes)! aerosol mode number concentration + + ! Output arguments ! - ! Local variables - ! - integer :: i, k, ib, icol, mplus10 - integer :: iloop - logical :: daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. - real(r8) :: aodvisvolc(pcols) ! AOD vis for CMIP6 volcanic aerosol - real(r8) :: absvisvolc(pcols) ! AAOD vis for CMIP6 volcanic aerosol - real(r8) :: bevisvolc(pcols,pver) ! Extinction in vis wavelength band for CMIP6 volcanic aerosol - real(r8) :: rhum(pcols,pver) ! (trimmed) relative humidity for the aerosol calculations - real(r8) :: deltah_km(pcols,pver) ! Layer thickness, unit km - - real(r8) :: deltah, airmassl(pcols,pver), airmass(pcols) !akc6 - real(r8) :: Ca(pcols,pver), f_c(pcols,pver), f_bc(pcols,pver), f_aq(pcols,pver) - real(r8) :: fnbc(pcols,pver), faitbc(pcols,pver), f_so4_cond(pcols,pver) - real(r8) :: f_soa(pcols,pver),f_soana(pcols,pver), vnbc, vaitbc - real(r8) :: v_soana(pcols,pver), vnbcarr(pcols,pver), vaitbcarr(pcols,pver) - real(r8) :: dCtot(pcols,pver), Ctot(pcols,pver) - real(r8) :: Cam(pcols,pver,nbmodes), fbcm(pcols,pver,nbmodes), fcm(pcols,pver,nbmodes) - real(r8) :: faqm(pcols,pver,nbmodes), f_condm(pcols,pver,nbmodes) - real(r8) :: f_soam(pcols, pver,nbmodes), faqm4(pcols,pver) - real(r8) :: xrh(pcols,pver), xrhnull(pcols,pver) - integer :: irh1(pcols,pver), irh2(pcols,pver), irh1null(pcols,pver), irh2null(pcols,pver) - real(r8) :: focm(pcols,pver,4) - real(r8) :: ssa(pcols,pver,0:nmodes,nbands), asym(pcols,pver,0:nmodes,nbands) - real(r8) :: be(pcols,pver,0:nmodes,nbands), ke(pcols,pver,0:nmodes,nbands) - real(r8) :: betotvis(pcols,pver), batotvis(pcols,pver) - real(r8) :: ssatot(pcols,pver,nbands) ! spectral aerosol single scattering albedo - real(r8) :: asymtot(pcols,pver,nbands) ! spectral aerosol asymmetry factor - real(r8) :: betot(pcols,pver,nbands) ! spectral aerosol extinction coefficient - real(r8) :: batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW - real(r8) :: kalw(pcols,pver,0:nmodes,nlwbands) - real(r8) :: balw(pcols,pver,0:nmodes,nlwbands) - logical :: lw_on ! LW calculations are performed in interpol* if true - real(r8) :: volc_balw(pcols,0:pver,nlwbands) ! volcanic aerosol absorption coefficient for terrestrial bands, CMIP6 - -#ifdef COLTST4INTCONS - real(r8) :: bekc1(pcols,pver), bekc2(pcols,pver), bekc4(pcols,pver), & - bekc5(pcols,pver), bekc6(pcols,pver), bekc7(pcols,pver), bekc8(pcols,pver), & - bekc9(pcols,pver), bekc10(pcols,pver), & - bekc12(pcols,pver), bekc14(pcols,pver), bekc0(pcols,pver) - real(r8) :: taukc1(pcols), taukc2(pcols), taukc3(pcols), taukc4(pcols), taukc5(pcols), & - taukc6(pcols), taukc7(pcols), taukc8(pcols), taukc9(pcols), taukc10(pcols), & - taukc11(pcols), taukc12(pcols), taukc13(pcols), taukc14(pcols), taukc0(pcols) - real(r8) :: kekc1(pcols,pver), kekc2(pcols,pver), kekc4(pcols,pver), & - kekc5(pcols,pver), kekc6(pcols,pver), kekc7(pcols,pver), kekc8(pcols,pver), & - kekc9(pcols,pver), kekc10(pcols,pver), & - kekc12(pcols,pver), kekc14(pcols,pver), kekc0(pcols,pver) - real(r8) :: cmodedry(pcols,pver,0:nmodes), & - cmdry0(pcols), cmdry1(pcols), cmdry2(pcols), cmdry4(pcols), & - cmdry5(pcols), cmdry6(pcols), cmdry7(pcols), cmdry8(pcols), & - cmdry9(pcols), cmdry10(pcols), cmdry12(pcols), cmdry14(pcols) + real(r8), intent(out) :: per_tau (pcols,0:pver,nbands) ! aerosol extinction optical depth + real(r8), intent(out) :: per_tau_w (pcols,0:pver,nbands) ! aerosol single scattering albedo * tau + real(r8), intent(out) :: per_tau_w_g(pcols,0:pver,nbands) ! aerosol assymetry parameter * w * tau + real(r8), intent(out) :: per_tau_w_f(pcols,0:pver,nbands) ! aerosol forward scattered fraction * w * tau + real(r8), intent(out) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optical depth (LW) + ! AOD and absorptive AOD for visible wavelength closest to 0.55 um (0.442-0.625) + ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values + real(r8), intent(out) :: aodvis(pcols) ! AOD vis + real(r8), intent(out) :: absvis(pcols) ! AAOD vis +#ifdef AEROCOM + real(r8), intent(out) :: dod440(pcols) + real(r8), intent(out) :: dod550(pcols) + real(r8), intent(out) :: dod870(pcols) + real(r8), intent(out) :: abs550(pcols) + real(r8), intent(out) :: abs550alt(pcols) #endif - real(r8) :: rh0(pcols,pver), rhoda(pcols,pver) - real(r8) :: ssavis(pcols,pver), asymmvis(pcols,pver), extvis(pcols,pver), dayfoc(pcols,pver) - real(r8) :: n_aerorig(pcols,pver), n_aer(pcols,pver) + ! + !---------------------------Local variables----------------------------- + ! + integer i, k, ib, icol, mplus10 + integer iloop + logical daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. + + real(r8) aodvisvolc(pcols) ! AOD vis for CMIP6 volcanic aerosol + real(r8) absvisvolc(pcols) ! AAOD vis for CMIP6 volcanic aerosol + !akc6+ + real(r8) bevisvolc(pcols,pver) ! Extinction in vis wavelength band for CMIP6 volcanic aerosol + !akc6- + real(r8) rhum(pcols,pver) ! (trimmed) relative humidity for the aerosol calculations + !tst + ! real(r8) aodvis3d(pcols,pver) ! 3D AOD in VIS + !tst + + real(r8) deltah_km(pcols,pver) ! Layer thickness, unit km + + !akc6 real(r8) deltah, airmass(pcols,pver) + real(r8) deltah, airmassl(pcols,pver), airmass(pcols) !akc6 + real(r8) Ca(pcols,pver), f_c(pcols,pver), f_bc(pcols,pver), f_aq(pcols,pver) + real(r8) fnbc(pcols,pver), faitbc(pcols,pver), f_so4_cond(pcols,pver), & + f_soa(pcols,pver),f_soana(pcols,pver), vnbc, vaitbc + real(r8) v_soana(pcols,pver), vnbcarr(pcols,pver), vaitbcarr(pcols,pver) + real(r8) dCtot(pcols,pver), Ctot(pcols,pver) + real(r8) Cam(pcols,pver,nbmodes), fbcm(pcols,pver,nbmodes), fcm(pcols,pver,nbmodes), & + faqm(pcols,pver,nbmodes), f_condm(pcols,pver,nbmodes), & + f_soam(pcols, pver,nbmodes), faqm4(pcols,pver) + real(r8) xrh(pcols,pver), xrhnull(pcols,pver) + integer irh1(pcols,pver), irh2(pcols,pver), irh1null(pcols,pver), irh2null(pcols,pver) + real(r8) focm(pcols,pver,4) + ! real(r8) akso4c(pcols), akbcc(pcols), akocc(pcols) + real(r8) ssa(pcols,pver,0:nmodes,nbands), asym(pcols,pver,0:nmodes,nbands), & + be(pcols,pver,0:nmodes,nbands), ke(pcols,pver,0:nmodes,nbands), & + betotvis(pcols,pver), batotvis(pcols,pver) + real(r8) ssatot(pcols,pver,nbands) ! spectral aerosol single scattering albedo + real(r8) asymtot(pcols,pver,nbands) ! spectral aerosol asymmetry factor + real(r8) betot(pcols,pver,nbands) ! spectral aerosol extinction coefficient + real(r8) batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW + real(r8) kalw(pcols,pver,0:nmodes,nlwbands) + real(r8) balw(pcols,pver,0:nmodes,nlwbands) + logical lw_on ! LW calculations are performed in interpol* if true + real(r8) volc_balw(pcols,0:pver,nlwbands) ! volcanic aerosol absorption coefficient for terrestrial bands, CMIP6 + + real(r8) rh0(pcols,pver), rhoda(pcols,pver) + real(r8) ssavis(pcols,pver), asymmvis(pcols,pver), extvis(pcols,pver), dayfoc(pcols,pver) + real(r8) n_aerorig(pcols,pver), n_aer(pcols,pver) + type(physics_state), intent(in), target :: state real(r8) :: es(pcols,pver) ! saturation vapor pressure real(r8) :: qs(pcols,pver) ! saturation specific humidity real(r8) :: rht(pcols,pver) ! relative humidity (fraction) (rh is already used in opptab) real(r8) :: rh_temp(pcols,pver) ! relative humidity (fraction) for input to LUT - real(r8) :: xfombg(pcols,pver) - integer :: ifombg1(pcols,pver), ifombg2(pcols,pver) - real(r8) :: xct(pcols,pver,nmodes) - integer :: ict1(pcols,pver,nmodes) - real(r8) :: xfac(pcols,pver,nbmodes) - integer :: ifac1(pcols,pver,nbmodes) - real(r8) :: xfbc(pcols,pver,nbmodes) - integer :: ifbc1(pcols,pver,nbmodes) - real(r8) :: xfaq(pcols,pver,nbmodes) - integer :: ifaq1(pcols,pver,nbmodes) - real(r8) :: xfbcbg(pcols,pver) - integer :: ifbcbg1(pcols,pver) - real(r8) :: xfbcbgn(pcols,pver) - integer :: ifbcbgn1(pcols,pver) - - real(r8) :: Ctotdry(pcols,pver), Cwater(pcols,pver), mmr_aerh2o(pcols,pver), & + real(r8) xfombg(pcols,pver) + integer ifombg1(pcols,pver), ifombg2(pcols,pver) + real(r8) xct(pcols,pver,nmodes) + integer ict1(pcols,pver,nmodes) + real(r8) xfac(pcols,pver,nbmodes) + integer ifac1(pcols,pver,nbmodes) + real(r8) xfbc(pcols,pver,nbmodes) + integer ifbc1(pcols,pver,nbmodes) + real(r8) xfaq(pcols,pver,nbmodes) + integer ifaq1(pcols,pver,nbmodes) + real(r8) xfbcbg(pcols,pver) + integer ifbcbg1(pcols,pver) + real(r8) xfbcbgn(pcols,pver) + integer ifbcbgn1(pcols,pver) + + ! -------begin do_aerocom----------- + real(r8) Ctotdry(pcols,pver), Cwater(pcols,pver), mmr_aerh2o(pcols,pver), & dod550dry(pcols), abs550dry(pcols) - real(r8) :: daerh2o(pcols), dload(pcols,0:nmodes), dload3d(pcols,pver,0:nmodes), & + real(r8) daerh2o(pcols), dload(pcols,0:nmodes), dload3d(pcols,pver,0:nmodes), & dload_mi(pcols), dload_ss(pcols), & dload_s4(pcols), dload_oc(pcols), dload_bc(pcols), & dload_s4_a(pcols), dload_s4_1(pcols), dload_s4_5(pcols) - real(r8) :: dload_bc_0(pcols), dload_bc_ac(pcols), dload_oc_ac(pcols), & + real(r8) dload_bc_0(pcols), dload_bc_ac(pcols), dload_oc_ac(pcols), & dload_bc_2(pcols), dload_bc_4(pcols), dload_bc_12(pcols), dload_bc_14(pcols), & dload_oc_4(pcols), dload_oc_14(pcols) - real(r8) :: cmin(pcols,pver), cseas(pcols,pver) - real(r8) :: nnat_1(pcols,pver), nnat_2(pcols,pver), nnat_3(pcols,pver), & + real(r8) cmin(pcols,pver), cseas(pcols,pver) + real(r8) nnat_1(pcols,pver), nnat_2(pcols,pver), nnat_3(pcols,pver), & nnat_4(pcols,pver), nnat_5(pcols,pver), nnat_6(pcols,pver), & nnat_7(pcols,pver), nnat_8(pcols,pver), nnat_9(pcols,pver), & nnat_10(pcols,pver), nnat_12(pcols,pver), & nnat_14(pcols,pver), nnat_0(pcols,pver) - real(r8) :: ck(pcols,pver,0:nmodes) - - real(r8) :: c_mi(pcols,pver), c_mi05(pcols,pver), c_mi125(pcols,pver), & + real(r8) ck(pcols,pver,0:nmodes), cknorm(pcols,pver,0:nmodes), & + cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) + real(r8) aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & + vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & + aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & + vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) + real(r8) cintbg(pcols,pver,0:nbmodes), & + cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & + cintbc(pcols,pver,0:nbmodes), & + cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & + cintoc(pcols,pver,0:nbmodes), & + cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & + cintsc(pcols,pver,0:nbmodes), & + cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & + cintsa(pcols,pver,0:nbmodes), & + cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes) + real(r8) c_mi(pcols,pver), c_mi05(pcols,pver), c_mi125(pcols,pver), & c_ss(pcols,pver), c_ss05(pcols,pver), c_ss125(pcols,pver), & c_bc(pcols,pver), c_bc05(pcols,pver), c_bc125(pcols,pver), & c_oc(pcols,pver), c_oc05(pcols,pver), c_oc125(pcols,pver), & @@ -172,163 +199,168 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & c_sc(pcols,pver), c_sc05(pcols,pver), c_sc125(pcols,pver), & c_s4(pcols,pver), c_s405(pcols,pver), c_s4125(pcols,pver), & c_s4_a(pcols,pver), c_s4_1(pcols,pver), c_s4_5(pcols,pver) - - real(r8) :: c_bc_0(pcols,pver), c_bc_ac(pcols,pver), c_oc_ac(pcols,pver), & + real(r8) c_bc_0(pcols,pver), c_bc_ac(pcols,pver), c_oc_ac(pcols,pver), & c_bc_2(pcols,pver), c_bc_4(pcols,pver), c_bc_12(pcols,pver), c_bc_14(pcols,pver), & c_oc_4(pcols,pver), c_oc_14(pcols,pver) - - real(r8) :: c_tots(pcols), c_tot125s(pcols), c_pm25s(pcols) ! = PM all sizes, PM>2.5um and PM<2.5um (PM2.5) - - real(r8) :: c_tot(pcols,pver), c_tot125(pcols,pver), c_pm25(pcols,pver), & + real(r8) c_tots(pcols), c_tot125s(pcols), c_pm25s(pcols) ! = PM all sizes, PM>2.5um and PM<2.5um (PM2.5) + !akc6+ + real(r8) c_tot(pcols,pver), c_tot125(pcols,pver), c_pm25(pcols,pver), & mmr_pm25(pcols,pver), c_tot05(pcols,pver), c_pm1(pcols,pver), mmr_pm1(pcols,pver) - - real(r8) :: aaeros_tot(pcols,pver), aaerol_tot(pcols,pver), vaeros_tot(pcols,pver), & + !akc6- + real(r8) aaeros_tot(pcols,pver), aaerol_tot(pcols,pver), vaeros_tot(pcols,pver), & vaerol_tot(pcols,pver), aaercols(pcols), aaercoll(pcols), vaercols(pcols), & vaercoll(pcols), derlt05(pcols), dergt05(pcols), der(pcols), & erlt053d(pcols,pver), ergt053d(pcols,pver), er3d(pcols,pver) - real(r8) :: bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & + real(r8) bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & backsc550(pcols,pver,0:nbmodes), backsc550x(pcols,pver,nbmp1:nmodes), & backsc550tot(pcols,pver), ec550_aer(pcols,pver), abs550_aer(pcols,pver), & bs550_aer(pcols,pver) - real(r8) :: bext440tot(pcols,pver), babs440tot(pcols,pver), & + + ! Additional AeroCom Phase III output: + real(r8) asydry_aer(pcols,pver) ! dry asymtot in the visible band + ! + real(r8) ec550_so4(pcols,pver),ec550_bc(pcols,pver), ec550_pom(pcols,pver), & + ec550_ss(pcols,pver), ec550_du(pcols,pver) + + real(r8) bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & + bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & + beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & + bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & + backsc550n(pcols,pver,0:nbmodes) + + real(r8) bext440tot(pcols,pver), babs440tot(pcols,pver), & bext500tot(pcols,pver), babs500tot(pcols,pver), & bext550tot(pcols,pver), babs550tot(pcols,pver), & bext670tot(pcols,pver), babs670tot(pcols,pver), & bext870tot(pcols,pver), babs870tot(pcols,pver), & - bebg440tot(pcols,pver), babg440tot(pcols,pver), & - bebg500tot(pcols,pver), babg500tot(pcols,pver), & + bebg440tot(pcols,pver), & + bebg500tot(pcols,pver), & bebg550tot(pcols,pver), babg550tot(pcols,pver), & - bebg670tot(pcols,pver), babg670tot(pcols,pver), & - bebg870tot(pcols,pver), babg870tot(pcols,pver), & - bebc440tot(pcols,pver), babc440tot(pcols,pver), & - bebc500tot(pcols,pver), babc500tot(pcols,pver), & + bebg670tot(pcols,pver), & + bebg870tot(pcols,pver), & + bebc440tot(pcols,pver), & + bebc500tot(pcols,pver), & bebc550tot(pcols,pver), babc550tot(pcols,pver), & - bebc670tot(pcols,pver), babc670tot(pcols,pver), & - bebc870tot(pcols,pver), babc870tot(pcols,pver), & - beoc440tot(pcols,pver), baoc440tot(pcols,pver), & - beoc500tot(pcols,pver), baoc500tot(pcols,pver), & + bebc670tot(pcols,pver), & + bebc870tot(pcols,pver), & + beoc440tot(pcols,pver), & + beoc500tot(pcols,pver), & beoc550tot(pcols,pver), baoc550tot(pcols,pver), & - beoc670tot(pcols,pver), baoc670tot(pcols,pver), & - beoc870tot(pcols,pver), baoc870tot(pcols,pver), & - besu440tot(pcols,pver), basu440tot(pcols,pver), & - besu500tot(pcols,pver), basu500tot(pcols,pver), & + beoc670tot(pcols,pver), & + beoc870tot(pcols,pver), & + besu440tot(pcols,pver), & + besu500tot(pcols,pver), & besu550tot(pcols,pver), basu550tot(pcols,pver), & - besu670tot(pcols,pver), basu670tot(pcols,pver), & - besu870tot(pcols,pver), basu870tot(pcols,pver) - ! Additional AeroCom Phase III output: - real(r8) :: asydry_aer(pcols,pver) ! dry asymtot in the visible band - ! - real(r8) :: ec550_so4(pcols,pver),ec550_bc(pcols,pver), ec550_pom(pcols,pver), & - ec550_ss(pcols,pver), ec550_du(pcols,pver) - real(r8) :: bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & - bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & - beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & - bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & - backsc550n(pcols,pver,0:nbmodes) - real(r8) :: bebglt1t(pcols,pver), bebggt1t(pcols,pver), bebclt1t(pcols,pver), & + besu670tot(pcols,pver), & + besu870tot(pcols,pver) + + real(r8) bebglt1t(pcols,pver), bebggt1t(pcols,pver), bebclt1t(pcols,pver), & bebcgt1t(pcols,pver), beoclt1t(pcols,pver), beocgt1t(pcols,pver), & bes4lt1t(pcols,pver), bes4gt1t(pcols,pver) - real(r8) :: be440x(pcols,pver,nbmp1:nmodes), ba440x(pcols,pver,nbmp1:nmodes), & + + real(r8) be440x(pcols,pver,nbmp1:nmodes), ba440x(pcols,pver,nbmp1:nmodes), & be500x(pcols,pver,nbmp1:nmodes), ba500x(pcols,pver,nbmp1:nmodes), & be550x(pcols,pver,nbmp1:nmodes), ba550x(pcols,pver,nbmp1:nmodes), & be670x(pcols,pver,nbmp1:nmodes), ba670x(pcols,pver,nbmp1:nmodes), & be870x(pcols,pver,nbmp1:nmodes), ba870x(pcols,pver,nbmp1:nmodes), & belt1x(pcols,pver,nbmp1:nmodes), begt1x(pcols,pver,nbmp1:nmodes) - real(r8) :: bebc440xt(pcols,pver),babc440xt(pcols,pver), & - bebc500xt(pcols,pver),babc500xt(pcols,pver), & + + real(r8) bebc440xt(pcols,pver), & + bebc500xt(pcols,pver), & bebc550xt(pcols,pver),babc550xt(pcols,pver), & - bebc670xt(pcols,pver),babc670xt(pcols,pver), & - bebc870xt(pcols,pver),babc870xt(pcols,pver), & - beoc440xt(pcols,pver),baoc440xt(pcols,pver), & - beoc500xt(pcols,pver),baoc500xt(pcols,pver), & + bebc670xt(pcols,pver), & + bebc870xt(pcols,pver), & + beoc440xt(pcols,pver), & + beoc500xt(pcols,pver), & beoc550xt(pcols,pver),baoc550xt(pcols,pver), & - beoc670xt(pcols,pver),baoc670xt(pcols,pver), & - beoc870xt(pcols,pver),baoc870xt(pcols,pver) - real(r8) :: bbclt1xt(pcols,pver), & + beoc670xt(pcols,pver), & + beoc870xt(pcols,pver) + real(r8) bbclt1xt(pcols,pver), & bbcgt1xt(pcols,pver), boclt1xt(pcols,pver), bocgt1xt(pcols,pver) - real(r8) :: bint440du(pcols,pver), bint500du(pcols,pver), bint550du(pcols,pver), & + real(r8) bint440du(pcols,pver), bint500du(pcols,pver), bint550du(pcols,pver), & bint670du(pcols,pver), bint870du(pcols,pver), & bint440ss(pcols,pver), bint500ss(pcols,pver), bint550ss(pcols,pver), & bint670ss(pcols,pver), bint870ss(pcols,pver), & baint550du(pcols,pver), baint550ss(pcols,pver) - real(r8) :: bedustlt1(pcols,pver), bedustgt1(pcols,pver) - real(r8) :: besslt1(pcols,pver), bessgt1(pcols,pver) - - real(r8) :: dod4403d(pcols,pver), abs4403d(pcols,pver) - real(r8) :: dod4403d_ss(pcols,pver) - real(r8) :: dod4403d_dust(pcols,pver) - real(r8) :: dod4403d_so4(pcols,pver) - real(r8) :: dod4403d_bc(pcols,pver) - real(r8) :: dod4403d_pom(pcols,pver) - - real(r8) :: dod5003d(pcols,pver), abs5003d(pcols,pver) - real(r8) :: dod5003d_ss(pcols,pver) - real(r8) :: dod5003d_dust(pcols,pver) - real(r8) :: dod5003d_so4(pcols,pver) - real(r8) :: dod5003d_bc(pcols,pver) - real(r8) :: dod5003d_pom(pcols,pver) - real(r8) :: dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver) - real(r8) :: dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver) - real(r8) :: dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver) - real(r8) :: dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver) - real(r8) :: dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver) - real(r8) :: dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver) - real(r8) :: dod6703d(pcols,pver), abs6703d(pcols,pver) - real(r8) :: dod6703d_ss(pcols,pver) - real(r8) :: dod6703d_dust(pcols,pver) - real(r8) :: dod6703d_so4(pcols,pver) - real(r8) :: dod6703d_bc(pcols,pver) - real(r8) :: dod6703d_pom(pcols,pver) - real(r8) :: dod8703d(pcols,pver), abs8703d(pcols,pver) - real(r8) :: dod8703d_ss(pcols,pver) - real(r8) :: dod8703d_dust(pcols,pver) - real(r8) :: dod8703d_so4(pcols,pver) - real(r8) :: dod8703d_bc(pcols,pver) - real(r8) :: dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) - real(r8) :: dod5503dlt1_ss(pcols,pver), dod5503dgt1_ss(pcols,pver) - real(r8) :: dod5503dlt1_dust(pcols,pver), dod5503dgt1_dust(pcols,pver) - real(r8) :: dod5503dlt1_so4(pcols,pver), dod5503dgt1_so4(pcols,pver) - real(r8) :: dod5503dlt1_bc(pcols,pver), dod5503dgt1_bc(pcols,pver) - real(r8) :: dod5503dlt1_pom(pcols,pver), dod5503dgt1_pom(pcols,pver) - real(r8) :: dod440(pcols), abs440(pcols), dod500(pcols), abs500(pcols) - real(r8) :: dod550(pcols), abs550(pcols), abs550alt(pcols), dod670(pcols) - real(r8) :: abs670(pcols), dod870(pcols), abs870(pcols) - real(r8) :: dod440_ss(pcols), dod440_dust(pcols), dod440_so4(pcols) - real(r8) :: dod440_bc(pcols), dod440_pom(pcols) - real(r8) :: dod500_ss(pcols), dod500_dust(pcols), dod500_so4(pcols) - real(r8) :: dod500_bc(pcols), dod500_pom(pcols) - real(r8) :: dod550_ss(pcols), dod550_dust(pcols), dod550_so4(pcols) - real(r8) :: dod550_bc(pcols), dod550_pom(pcols) - real(r8) :: dod670_ss(pcols), dod670_dust(pcols), dod670_so4(pcols) - real(r8) :: dod670_bc(pcols), dod670_pom(pcols) - real(r8) :: dod870_ss(pcols), dod870_dust(pcols), dod870_so4(pcols) - real(r8) :: dod870_bc(pcols), dod870_pom(pcols) - real(r8) :: dod550lt1_ss(pcols), dod550gt1_ss(pcols), dod550lt1_dust(pcols) - real(r8) :: dod550gt1_dust(pcols), dod550lt1_so4(pcols) - real(r8) :: dod550gt1_so4(pcols), dod550lt1_bc(pcols), dod550gt1_bc(pcols) - real(r8) :: dod550lt1_pom(pcols), dod550gt1_pom(pcols) - real(r8) :: abs550_ss(pcols), abs550_dust(pcols) - real(r8) :: abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) - real(r8) :: batotsw13(pcols,pver), batotlw01(pcols,pver) - + real(r8) bedustlt1(pcols,pver), bedustgt1(pcols,pver), & + besslt1(pcols,pver), bessgt1(pcols,pver) + real(r8) dod4403d(pcols,pver), abs4403d(pcols,pver), & + dod4403d_ss(pcols,pver), & ! abs4403d_ss(pcols,pver), & + dod4403d_dust(pcols,pver), & ! abs4403d_dust(pcols,pver), & + dod4403d_so4(pcols,pver), & ! abs4403d_so4(pcols,pver), & + dod4403d_bc(pcols,pver), & ! abs4403d_bc(pcols,pver), & + dod4403d_pom(pcols,pver), & ! abs4403d_pom(pcols,pver), & + dod5003d(pcols,pver), abs5003d(pcols,pver), & + dod5003d_ss(pcols,pver), & ! abs5003d_ss(pcols,pver), & + dod5003d_dust(pcols,pver), & ! abs5003d_dust(pcols,pver), & + dod5003d_so4(pcols,pver), & ! abs5003d_so4(pcols,pver), & + dod5003d_bc(pcols,pver), & ! abs5003d_bc(pcols,pver), & + dod5003d_pom(pcols,pver), & ! abs5003d_pom(pcols,pver), & + dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver), & + dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver), & + dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver), & + dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver), & + dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver), & + dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver), & + dod6703d(pcols,pver), abs6703d(pcols,pver), & + dod6703d_ss(pcols,pver), & ! abs6703d_ss(pcols,pver), & + dod6703d_dust(pcols,pver), & ! abs6703d_dust(pcols,pver), & + dod6703d_so4(pcols,pver), & ! abs6703d_so4(pcols,pver), & + dod6703d_bc(pcols,pver), & ! abs6703d_bc(pcols,pver), & + dod6703d_pom(pcols,pver), & ! abs6703d_pom(pcols,pver), & + dod8703d(pcols,pver), abs8703d(pcols,pver), & + dod8703d_ss(pcols,pver), & ! abs8703d_ss(pcols,pver), & + dod8703d_dust(pcols,pver), & ! abs8703d_dust(pcols,pver), & + dod8703d_so4(pcols,pver), & ! abs8703d_so4(pcols,pver), & + dod8703d_bc(pcols,pver), & ! abs8703d_bc(pcols,pver), & + dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) + real(r8) dod5503dlt1_ss(pcols,pver), dod5503dgt1_ss(pcols,pver), & + dod5503dlt1_dust(pcols,pver), dod5503dgt1_dust(pcols,pver), & + dod5503dlt1_so4(pcols,pver), dod5503dgt1_so4(pcols,pver), & + dod5503dlt1_bc(pcols,pver), dod5503dgt1_bc(pcols,pver), & + dod5503dlt1_pom(pcols,pver), dod5503dgt1_pom(pcols,pver) + real(r8) abs440(pcols), dod500(pcols), abs500(pcols), & + dod670(pcols),& + abs670(pcols), abs870(pcols), & + dod440_ss(pcols), dod440_dust(pcols), dod440_so4(pcols), & + dod440_bc(pcols), dod440_pom(pcols), & + dod500_ss(pcols), dod500_dust(pcols), dod500_so4(pcols), & + dod500_bc(pcols), dod500_pom(pcols), & + dod550_ss(pcols), dod550_dust(pcols), dod550_so4(pcols), & + dod550_bc(pcols), dod550_pom(pcols), & + dod670_ss(pcols), dod670_dust(pcols), dod670_so4(pcols), & + dod670_bc(pcols), dod670_pom(pcols), & + dod870_ss(pcols), dod870_dust(pcols), dod870_so4(pcols), & + dod870_bc(pcols), dod870_pom(pcols), & + dod550lt1_ss(pcols), dod550gt1_ss(pcols), dod550lt1_dust(pcols), & + dod550gt1_dust(pcols), dod550lt1_so4(pcols), & + dod550gt1_so4(pcols), dod550lt1_bc(pcols), dod550gt1_bc(pcols), & + dod550lt1_pom(pcols), dod550gt1_pom(pcols) + real(r8) abs550_ss(pcols), abs550_dust(pcols), & + abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) + real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) character(len=10) :: modeString character(len=20) :: varname - integer :: irf,irfmax - real(r8) :: Camrel(pcols,pver,nbmodes) - real(r8) :: Camtot(pcols,nbmodes) - real(r8) :: cxsmtot(pcols,nbmodes) - real(r8) :: cxsmrel(pcols,nbmodes) - real(r8) :: xctrel,camdiff,cxsm - real(r8) :: cxs(pcols,pver), cxstot(pcols,pver), akcxs(pcols) + integer irf,irfmax + real(r8) Camrel(pcols,pver,nbmodes) + real(r8) Camtot(pcols,nbmodes) + real(r8) cxsmtot(pcols,nbmodes) + real(r8) cxsmrel(pcols,nbmodes) + real(r8) xctrel,camdiff,cxsm + real(r8) cxs(pcols,pver), cxstot(pcols,pver), akcxs(pcols) + ! --------end do_aerocom----------- + !- + + ! !------------------------------------------------------------------------- ! !test: hentet fra aer_rad_props, saa modifisert/rettet (!x) ! calculate relative humidity for table lookup into rh grid - !x call qsat(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver) + !x call qsat(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & call qsat_water(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & es(1:ncol,1:pver), qs(1:ncol,1:pver)) rht(1:ncol,1:pver) = state%q(1:ncol,1:pver,1) / qs(1:ncol,1:pver) @@ -337,7 +369,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & do k=1,pver do icol=1,ncol - ! Set upper and lower relative humidity for the aerosol calculations + ! Set upper and lower relative humidity for the aerosol calculations rhum(icol,k) = min(0.995_r8, max(rh_temp(icol,k), 0.01_r8)) rhoda(icol,k) = pmid(icol,k)/(rair*t(icol,k)) ! unit kg/m^3 !test rhum(icol,k) = 0.01_r8 @@ -348,21 +380,31 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do end do - ! Layer thickness with unit km + ! Layer thickness with unit km do icol=1,ncol do k=1,pver deltah_km(icol,k)=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) end do end do - ! interpol-calculations only when daylight or not: - do icol=1,ncol - daylight(icol) = .true. - end do + ! interpol-calculations only when daylight or not: + if (do_aerocom) then + do icol=1,ncol + daylight(icol) = .true. + end do + else + do icol=1,ncol + if (coszrs(icol) > 0.0_r8) then + daylight(icol) = .true. + else + daylight(icol) = .false. + endif + end do + end if - ! Set SO4, BC and OC concentrations: + ! Set SO4, BC and OC concentrations: - ! initialize concentration fields + ! initialize concentration fields do i=0,nmodes do k=1,pver do icol=1,ncol @@ -381,12 +423,12 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & ke(:,:,:,:)=0._r8 asym(:,:,:,:)=0._r8 ssa(:,:,:,:)=0._r8 - ! Find process tagged bulk aerosol properies (from the life cycle module): + ! Find process tagged bulk aerosol properies (from the life cycle module): call calculateBulkProperties(ncol, qm1, rhoda, Nnatk, Ca, f_c, f_bc, & f_aq, f_so4_cond, f_soa, faitbc, fnbc, f_soana) - ! calculating vulume fractions from mass fractions: + ! calculating vulume fractions from mass fractions: do k=1,pver do icol=1,ncol v_soana(icol,k) = f_soana(icol,k)/(f_soana(icol,k) & @@ -394,7 +436,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do end do - ! Avoid very small numbers + ! Avoid very small numbers do k=1,pver do icol=1,ncol Ca(icol,k) = max(eps,Ca(icol,k)) @@ -406,8 +448,8 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do end do - ! Calculation of the apportionment of internally mixed SO4, BC and OC - ! mass between the various background modes. + ! Calculation of the apportionment of internally mixed SO4, BC and OC + ! mass between the various background modes. !==> calls modalapp to partition the mass call partitionMass(ncol, nnatk, Ca, f_c, f_bc, f_aq, f_so4_cond, f_soa , & @@ -417,8 +459,8 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & Nnatk(:ncol,:,:) = Nnatk(:ncol,:,:)*1.e-6_r8 cam(:ncol,:,:)=cam(:ncol,:,:)*1.e9_r8 - ! Calculate fraction of added mass which is either SOA condensate or OC coagulate, - ! which in AeroTab are both treated as condensate for kcomp=1-4. + ! Calculate fraction of added mass which is either SOA condensate or OC coagulate, + ! which in AeroTab are both treated as condensate for kcomp=1-4. do i=1,4 do k=1,pver do icol=1,ncol @@ -432,13 +474,14 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do enddo - ! find common input parameters for use in the interpolation routines + ! find common input parameters for use in the interpolation routines + call inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & f_soana, xfombg, ifombg1, faitbc, xfbcbg, ifbcbg1, & fnbc, xfbcbgn, ifbcbgn1, Nnatk, Cam, xct, ict1, & focm, fcm, xfac, ifac1, fbcm, xfbc, ifbc1, faqm, xfaq, ifaq1) - ! and define the respective RH input variables for dry aerosols + ! and define the respective RH input variables for dry aerosols do k=1,pver do icol=1,ncol xrhnull(icol,k)=rh(1) @@ -446,233 +489,235 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do enddo - ! Initialize overshooting mass summed over all modes - do k=1,pver - do icol=1,ncol - cxstot(icol,k)=0.0_r8 - enddo - enddo - do icol=1,ncol - akcxs(icol)=0.0_r8 - enddo - ! Initializing total and relative exessive (overshooting w.r.t. - ! look-up table maxima) added mass column: - do i=1,nbmodes - do icol=1,ncol - Camtot(icol,i)=0.0_r8 - cxsmtot(icol,i)=0.0_r8 - cxsmrel(icol,i)=0.0_r8 - enddo - enddo - ! Calculating added internally mixed mass onto each mode 1-10, relative to - ! maximum mass which can be added w.r.t. the look-up tables (for level k), - ! as well as the relative exessive added mass column: - do i=1,4 + if (do_aerocom) then + + ! Initialize overshooting mass summed over all modes do k=1,pver do icol=1,ncol - Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cate(i,16) - xctrel=min(max(Camrel(icol,k,i),cate(i,1)/cate(i,16)),1.0_r8) - camdiff=Cam(icol,k,i)-xctrel*cate(i,16)*(Nnatk(icol,k,i)+eps) - cxsm=max(0.0_r8,camdiff) - cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) - Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) - !t - camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) - cxs(icol,k)=max(0.0_r8,camdiff) - cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) - !t + cxstot(icol,k)=0.0_r8 enddo enddo - enddo - do i=5,nbmodes - do k=1,pver + do icol=1,ncol + akcxs(icol)=0.0_r8 + enddo + + ! Initializing total and relative exessive (overshooting w.r.t. + ! look-up table maxima) added mass column: + do i=1,nbmodes do icol=1,ncol - Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cat(i,6) - xctrel=min(max(Camrel(icol,k,i),cat(i,1)/cat(i,6)),1.0_r8) - camdiff=Cam(icol,k,i)-xctrel*cat(i,6)*(Nnatk(icol,k,i)+eps) - cxsm=max(0.0_r8,camdiff) - cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) - Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) - !t - camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) - cxs(icol,k)=max(0.0_r8,camdiff) - cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) - !t + Camtot(icol,i)=0.0_r8 + cxsmtot(icol,i)=0.0_r8 + cxsmrel(icol,i)=0.0_r8 enddo enddo - enddo - - ! Total overshooting mass summed over all modes and all levels - do icol=1,ncol - do k=1,pver - akcxs(icol) =akcxs(icol)+cxstot(icol,k)*deltah_km(icol,k) + ! Calculating added internally mixed mass onto each mode 1-10, relative to + ! maximum mass which can be added w.r.t. the look-up tables (for level k), + ! as well as the relative exessive added mass column: + do i=1,4 + do k=1,pver + do icol=1,ncol + Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cate(i,16) + xctrel=min(max(Camrel(icol,k,i),cate(i,1)/cate(i,16)),1.0_r8) + camdiff=Cam(icol,k,i)-xctrel*cate(i,16)*(Nnatk(icol,k,i)+eps) + cxsm=max(0.0_r8,camdiff) + cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) + Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) + !t + camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) + cxs(icol,k)=max(0.0_r8,camdiff) + cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) + !t + enddo + enddo + enddo + do i=5,nbmodes + do k=1,pver + do icol=1,ncol + Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cat(i,6) + xctrel=min(max(Camrel(icol,k,i),cat(i,1)/cat(i,6)),1.0_r8) + camdiff=Cam(icol,k,i)-xctrel*cat(i,6)*(Nnatk(icol,k,i)+eps) + cxsm=max(0.0_r8,camdiff) + cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) + Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) + !t + camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) + cxs(icol,k)=max(0.0_r8,camdiff) + cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) + !t + enddo + enddo enddo - enddo - call outfld('AKCXS ',akcxs ,pcols,lchnk) - do i=1,nbmodes + ! Total overshooting mass summed over all modes and all levels do icol=1,ncol - cxsmrel(icol,i)=cxsmtot(icol,i)/(Camtot(icol,i)+eps) + do k=1,pver + akcxs(icol) =akcxs(icol)+cxstot(icol,k)*deltah_km(icol,k) + enddo enddo - enddo + call outfld('AKCXS ',akcxs ,pcols,lchnk) - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Camrel"//trim(modeString) - if(i.ne.3) call outfld(varName,Camrel(:,:,i),pcols,lchnk) - enddo + do i=1,nbmodes + do icol=1,ncol + cxsmrel(icol,i)=cxsmtot(icol,i)/(Camtot(icol,i)+eps) + enddo + enddo - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Cxsrel"//trim(modeString) - if(i.ne.3) call outfld(varName,cxsmrel(:,i),pcols,lchnk) - enddo + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Camrel"//trim(modeString) + if(i.ne.3) call outfld(varName,Camrel(:,:,i),pcols,lchnk) + enddo - ! AeroCom: Find dry aerosol asymmetry factor and mass for subsequent - ! calculation of condensed water mass below... + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Cxsrel"//trim(modeString) + if(i.ne.3) call outfld(varName,cxsmrel(:,i),pcols,lchnk) + enddo - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! AeroCom: Find dry aerosol asymmetry factor and mass for subsequent + ! calculation of condensed water mass below... - do k=1,pver - do icol=1,ncol - Ctotdry(icol,k)=0.0_r8 - rh0(icol,k)=0.0_r8 - asydry_aer(icol,k)=0.0_r8 - end do - enddo + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - lw_on = .false. ! No LW optics needed for RH=0 (interpol returns 0-values) + do k=1,pver + do icol=1,ncol + Ctotdry(icol,k)=0.0_r8 + rh0(icol,k)=0.0_r8 + asydry_aer(icol,k)=0.0_r8 + end do + enddo - do iloop=1,1 ! loop over i>1 for testing CPU use in interpol* - ! BC(ax) mode (dry only): - call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) + lw_on = .false. ! No LW optics needed for RH=0 (interpol returns 0-values) - mplus10=0 - ! SO4/SOA(Ait) mode: - call interpol1 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) + do iloop=1,1 ! loop over i>1 for testing CPU use in interpol* + ! BC(ax) mode (dry only): + call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) + mplus10=0 + ! SO4/SOA(Ait) mode: + call interpol1 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) - ! BC&OC(Ait) mode: ------ fcm not valid here (=0). Use faitbc instead - call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, & - xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) - ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call interpol5to10 (lchnk, ncol, daylight, xrhnull, irh1null, & - Nnatk, xct, ict1, xfac, ifac1, & - xfbc, ifbc1, xfaq, ifaq1, & - ssa, asym, be, ke, lw_on, kalw) - enddo ! iloop + ! BC&OC(Ait) mode: ------ fcm not valid here (=0). Use faitbc instead + call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, & + xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call interpol5to10 (lchnk, ncol, daylight, xrhnull, irh1null, & + Nnatk, xct, ict1, xfac, ifac1, & + xfbc, ifbc1, xfaq, ifaq1, & + ssa, asym, be, ke, lw_on, kalw) + enddo ! iloop - do iloop=1,1 - mplus10=1 - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead - call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, & - ssa, asym, be, ke, lw_on, kalw) + do iloop=1,1 + mplus10=1 + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) - enddo ! iloop + ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead + call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, & + ssa, asym, be, ke, lw_on, kalw) - do i=0,nmodes ! mode 0 to 14 + enddo ! iloop + + do i=0,nmodes ! mode 0 to 14 + do k=1,pver + do icol=1,ncol + dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) + Ctotdry(icol,k)=Ctotdry(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) + end do + enddo + enddo + + ! AeroCom Phase III: adding asymmetry factor for dry aerosol, wavelength band 4 only + ! (and with no CMIP6 volcnic contribution) + ib=4 do k=1,pver do icol=1,ncol - dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) - Ctotdry(icol,k)=Ctotdry(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) -#ifdef COLTST4INTCONS - cmodedry(icol,k,i)=dCtot(icol,k)*Nnatk(icol,k,i) -#endif + betot(icol,k,ib)=0.0_r8 + ssatot(icol,k,ib)=0.0_r8 + asymtot(icol,k,ib)=0.0_r8 end do enddo - enddo + do i=0,nmodes + do k=1,pver + do icol=1,ncol + betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) + ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib) + asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) + ! if(ib.eq.4) then + ! write(*,*) 'i, asym =', i, asym(icol,k,i,ib) + ! write(*,*) 'i, be =', i, be(icol,k,i,ib) + ! write(*,*) 'i, ssa =', i, ssa(icol,k,i,ib) + ! endif - ! AeroCom Phase III: adding asymmetry factor for dry aerosol, wavelength band 4 only - ! (and with no CMIP6 volcnic contribution) - ib=4 - do k=1,pver - do icol=1,ncol - betot(icol,k,ib)=0.0_r8 - ssatot(icol,k,ib)=0.0_r8 - asymtot(icol,k,ib)=0.0_r8 - end do - enddo - do i=0,nmodes + end do + enddo + enddo do k=1,pver do icol=1,ncol - betot(icol,k,ib) = betot(icol,k,ib) + Nnatk(icol,k,i)*be(icol,k,i,ib) - ssatot(icol,k,ib) = ssatot(icol,k,ib) + Nnatk(icol,k,i)*be(icol,k,i,ib)*ssa(icol,k,i,ib) - asymtot(icol,k,ib) = asymtot(icol,k,ib)+ Nnatk(icol,k,i)*be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) - ! if(ib.eq.4) then - ! write(*,*) 'i, asym =', i, asym(icol,k,i,ib) - ! write(*,*) 'i, be =', i, be(icol,k,i,ib) - ! write(*,*) 'i, ssa =', i, ssa(icol,k,i,ib) - ! endif - + ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) + asymtot(icol,k,ib)=asymtot(icol,k,ib) & + /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) + asydry_aer(icol,k)=asymtot(icol,k,ib) end do enddo - enddo - do k=1,pver - do icol=1,ncol - ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) - asymtot(icol,k,ib)=asymtot(icol,k,ib) & - /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) - asydry_aer(icol,k)=asymtot(icol,k,ib) - end do - enddo - ! - call outfld('ASYMMDRY',asydry_aer,pcols,lchnk) - ! + ! + call outfld('ASYMMDRY',asydry_aer,pcols,lchnk) + ! + end if ! AEROCOM - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! (Wet) Optical properties for each of the aerosol modes: + ! (Wet) Optical properties for each of the aerosol modes: lw_on = .true. ! No LW optics needed for RH=0 (interpol returns 0-values) do iloop=1,1 - ! BC(ax) mode (dry only): + ! BC(ax) mode (dry only): call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) mplus10=0 - ! SO4/SOA(Ait) mode: + ! SO4/SOA(Ait) mode: call interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, & Nnatk, xfombg, ifombg1, xct, ict1, & xfac, ifac1, ssa, asym, be, ke, lw_on, kalw) - ! BC(Ait) and OC(Ait) modes: + ! BC(Ait) and OC(Ait) modes: call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & Nnatk, xct, ict1, xfac, ifac1, & ssa, asym, be, ke, lw_on, kalw) - ! BC&OC(Ait) mode: ------ fcm invalid here (=0). Using faitbc instead + ! BC&OC(Ait) mode: ------ fcm invalid here (=0). Using faitbc instead call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & Nnatk, xfbcbg, ifbcbg1, xct, ict1, & xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: call interpol5to10 (lchnk, ncol, daylight, xrh, irh1, & Nnatk, xct, ict1, xfac, ifac1, & xfbc, ifbc1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) enddo ! iloop - ! total aerosol number concentrations + ! total aerosol number concentrations do i=0,nmodes ! mode 0 to 14 do k=1,pver do icol=1,ncol @@ -684,21 +729,20 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & do iloop=1,1 mplus10=1 - ! SO4/SOA(Ait) mode: + ! SO4/SOA(Ait) mode: !does no longer exist as an externally mixed mode - ! BC(Ait) and OC(Ait) modes: + ! BC(Ait) and OC(Ait) modes: call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & Nnatk, xct, ict1, xfac, ifac1, & ssa, asym, be, ke, lw_on, kalw) - ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead + ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) enddo ! iloop - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc do k=1,pver do icol=1,ncol Ctot(icol,k)=0.0_r8 @@ -714,49 +758,17 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & enddo enddo -#ifdef COLTST4INTCONS - ! initializing modal mass column burdens - do icol=1,ncol - cmdry0(icol)=0.0_r8 - cmdry1(icol)=0.0_r8 - cmdry2(icol)=0.0_r8 - cmdry4(icol)=0.0_r8 - cmdry5(icol)=0.0_r8 - cmdry6(icol)=0.0_r8 - cmdry7(icol)=0.0_r8 - cmdry8(icol)=0.0_r8 - cmdry9(icol)=0.0_r8 - cmdry10(icol)=0.0_r8 - cmdry12(icol)=0.0_r8 - cmdry14(icol)=0.0_r8 - enddo -#endif - ! Mass concentration (ug/m3) and mmr (kg/kg) of aerosol condensed water - do k=1,pver - do icol=1,ncol - Cwater(icol,k)=Ctot(icol,k)-Ctotdry(icol,k) - mmr_aerh2o(icol,k)=1.e-9_r8*Cwater(icol,k)/rhoda(icol,k) -#ifdef COLTST4INTCONS - ! and dry mass column burdens for each mode/mixture - deltah=deltah_km(icol,k) - cmdry0(icol)=cmdry0(icol)+cmodedry(icol,k,0)*deltah - cmdry1(icol)=cmdry1(icol)+cmodedry(icol,k,1)*deltah - cmdry2(icol)=cmdry2(icol)+cmodedry(icol,k,2)*deltah - cmdry4(icol)=cmdry4(icol)+cmodedry(icol,k,4)*deltah - cmdry5(icol)=cmdry5(icol)+cmodedry(icol,k,5)*deltah - cmdry6(icol)=cmdry6(icol)+cmodedry(icol,k,6)*deltah - cmdry7(icol)=cmdry7(icol)+cmodedry(icol,k,7)*deltah - cmdry8(icol)=cmdry8(icol)+cmodedry(icol,k,8)*deltah - cmdry9(icol)=cmdry9(icol)+cmodedry(icol,k,9)*deltah - cmdry10(icol)=cmdry10(icol)+cmodedry(icol,k,10)*deltah - cmdry12(icol)=cmdry12(icol)+cmodedry(icol,k,12)*deltah - cmdry14(icol)=cmdry14(icol)+cmodedry(icol,k,14)*deltah -#endif - end do - enddo + if (do_aerocom) then + ! Mass concentration (ug/m3) and mmr (kg/kg) of aerosol condensed water + do k=1,pver + do icol=1,ncol + Cwater(icol,k)=Ctot(icol,k)-Ctotdry(icol,k) + mmr_aerh2o(icol,k)=1.e-9_r8*Cwater(icol,k)/rhoda(icol,k) + end do + enddo + end if - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! SW Optical properties of total aerosol: + ! SW Optical properties of total aerosol: do ib=1,nbands do k=1,pver do icol=1,ncol @@ -779,18 +791,18 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & enddo enddo enddo - ! Adding also the volcanic contribution (CMIP6), which is using a CMIP6 - ! band numbering identical to the AeroTab numbering (unlike CAM) both - ! for SW and LW. I.e., no remapping is required here. - ! Info from CMIP_CAM6_radiation_v3.nc + ! Adding also the volcanic contribution (CMIP6), which is using a CMIP6 + ! band numbering identical to the AeroTab numbering (unlike CAM) both + ! for SW and LW. I.e., no remapping is required here. + ! Info from CMIP_CAM6_radiation_v3.nc ! wl1_sun = 0.2, 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, - ! 1.2987, 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615 ; + ! 1.2987, 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615 ; ! wl2_sun = 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, 1.2987, - ! 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615, 12.1951 ; + ! 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615, 12.1951 ; ! wl1_earth = 3.07692, 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, - ! 7.19424, 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714 ; + ! 7.19424, 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714 ; ! wl2_earth = 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, 7.19424, - ! 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714, 1000 ; + ! 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714, 1000 ; do ib=1,nbands betot(1:ncol,1:pver,ib) = betot(1:ncol,1:pver,ib) & + volc_ext_sun(1:ncol,1:pver,ib) @@ -803,7 +815,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & !akc6+ bevisvolc(1:ncol,1:pver) = volc_ext_sun(1:ncol,1:pver,4) !akc6- - ! and then calculate the total bulk optical parameters + ! and then calculate the total bulk optical parameters do ib=1,nbands do k=1,pver do icol=1,ncol @@ -817,7 +829,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & !------------------------------------------------------------------------------------------------ ! Replace CAM5 standard aerosol optics with CAM5-Oslo optics (except top layer: no aerosol) ! Remapping from AeroTab to CAM5 SW bands, see p. 167 in the CAM5.0 description: - ! CAM5 bands AeroTab bands + ! CAM5 bands AeroTab bands ! 14 3.846 12.195 14 ! 1 3.077 3.846 13 ! 2 2.500 3.077 12 @@ -849,7 +861,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do end do end do - ! Remapping of SW wavelength bands from AeroTab to CAM5 + ! Remapping of SW wavelength bands from AeroTab to CAM5 do i=1,ncol do ib=1,13 do k=1,pver @@ -858,11 +870,11 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,14-ib) per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,14-ib) !tst - ! if(ib.eq.4.and.k.eq.pver.and.i.eq.1) then - ! write(*,*) 'per_tau =', per_tau(i,k,ib) - ! write(*,*) 'per_tau_w =', per_tau_w(i,k,ib) - ! write(*,*) 'per_tau_w_g =', per_tau_w_g(i,k,ib) - ! endif + ! if(ib.eq.4.and.k.eq.pver.and.i.eq.1) then + ! write(*,*) 'per_tau =', per_tau(i,k,ib) + ! write(*,*) 'per_tau_w =', per_tau_w(i,k,ib) + ! write(*,*) 'per_tau_w_g =', per_tau_w_g(i,k,ib) + ! endif !tst end do end do @@ -876,7 +888,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do ! ncol !------------------------------------------------------------------------------------------------ - ! LW Optical properties of total aerosol: + ! LW Optical properties of total aerosol: do ib=1,nlwbands do k=1,pver do icol=1,ncol @@ -895,104 +907,42 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & enddo enddo - ! Adding also the volcanic contribution (CMIP6), which is also using - ! AeroTab band numbering, so that a remapping is required here + ! Adding also the volcanic contribution (CMIP6), which is also using + ! AeroTab band numbering, so that a remapping is required here do ib=1,nlwbands volc_balw(1:ncol,1:pver,ib) = volc_ext_earth(:ncol,1:pver,ib) & *(1.0_r8-volc_omega_earth(:ncol,1:pver,ib)) batotlw(1:ncol,1:pver,ib)=batotlw(1:ncol,1:pver,ib)+volc_balw(1:ncol,1:pver,ib) enddo - ! Remapping of LW wavelength bands from AeroTab to CAM5 + ! Remapping of LW wavelength bands from AeroTab to CAM5 do ib=1,nlwbands do i=1,ncol do k=1,pver per_lw_abs(i,k,ib)=deltah_km(i,k)*batotlw(i,k,17-ib) - ! if(ib.eq.1.and.k.eq.pver.and.i.eq.1) then - ! write(*,*) 'per_lw_abs =', per_lw_abs(i,k,ib) - ! endif + ! if(ib.eq.1.and.k.eq.pver.and.i.eq.1) then + ! write(*,*) 'per_lw_abs =', per_lw_abs(i,k,ib) + ! endif end do end do end do - do i=1,ncol - do k=1,pver - batotsw13(i,k)=betot(i,k,13)*(1.0_r8-ssatot(i,k,13)) - batotlw01(i,k)=batotlw(i,k,1) - end do - end do - ! These two fields should be close to equal, both representing absorption - ! in the 3.077-3.846 um wavelenght band (i.e., a check of LUT for LW vs. SW). - call outfld('BATSW13 ',batotsw13,pcols,lchnk) - call outfld('BATLW01 ',batotlw01,pcols,lchnk) - -#ifdef COLTST4INTCONS - ! initialize modal optical extinctions - do k=1,pver - do icol=1,ncol - bekc0(icol,k)=0.0_r8 - bekc1(icol,k)=0.0_r8 - bekc2(icol,k)=0.0_r8 - bekc4(icol,k)=0.0_r8 - bekc5(icol,k)=0.0_r8 - bekc6(icol,k)=0.0_r8 - bekc7(icol,k)=0.0_r8 - bekc8(icol,k)=0.0_r8 - bekc9(icol,k)=0.0_r8 - bekc10(icol,k)=0.0_r8 - bekc12(icol,k)=0.0_r8 - bekc14(icol,k)=0.0_r8 - ! - kekc0(icol,k)=0.0_r8 - kekc1(icol,k)=0.0_r8 - kekc2(icol,k)=0.0_r8 - kekc4(icol,k)=0.0_r8 - kekc5(icol,k)=0.0_r8 - kekc6(icol,k)=0.0_r8 - kekc7(icol,k)=0.0_r8 - kekc8(icol,k)=0.0_r8 - kekc9(icol,k)=0.0_r8 - kekc10(icol,k)=0.0_r8 - kekc12(icol,k)=0.0_r8 - kekc14(icol,k)=0.0_r8 - end do - enddo - ! optical depth (in band 4 = vis.) for each of the modes - do k=1,pver - do icol=1,ncol - bekc0(icol,k) =Nnatk(icol,k,0) *be(icol,k,0,4) - bekc1(icol,k) =Nnatk(icol,k,1) *be(icol,k,1,4) - bekc2(icol,k) =Nnatk(icol,k,2) *be(icol,k,2,4) - bekc4(icol,k) =Nnatk(icol,k,4) *be(icol,k,4,4) - bekc5(icol,k) =Nnatk(icol,k,5) *be(icol,k,5,4) - bekc6(icol,k) =Nnatk(icol,k,6) *be(icol,k,6,4) - bekc7(icol,k) =Nnatk(icol,k,7) *be(icol,k,7,4) - bekc8(icol,k) =Nnatk(icol,k,8) *be(icol,k,8,4) - bekc9(icol,k) =Nnatk(icol,k,9) *be(icol,k,9,4) - bekc10(icol,k)=Nnatk(icol,k,10)*be(icol,k,10,4) - bekc12(icol,k)=Nnatk(icol,k,12)*be(icol,k,12,4) - bekc14(icol,k)=Nnatk(icol,k,14)*be(icol,k,14,4) - ! - kekc0(icol,k) =ke(icol,k,0,4) - kekc1(icol,k) =ke(icol,k,1,4) - kekc2(icol,k) =ke(icol,k,2,4) - kekc4(icol,k) =ke(icol,k,4,4) - kekc5(icol,k) =ke(icol,k,5,4) - kekc6(icol,k) =ke(icol,k,6,4) - kekc7(icol,k) =ke(icol,k,7,4) - kekc8(icol,k) =ke(icol,k,8,4) - kekc9(icol,k) =ke(icol,k,9,4) - kekc10(icol,k)=ke(icol,k,10,4) - kekc12(icol,k)=ke(icol,k,12,4) - kekc14(icol,k)=ke(icol,k,14,4) + if (do_aerocom) then + do i=1,ncol + do k=1,pver + batotsw13(i,k)=betot(i,k,13)*(1.0_r8-ssatot(i,k,13)) + batotlw01(i,k)=batotlw(i,k,1) + end do end do - enddo -#endif - + ! These two fields should be close to equal, both representing absorption + ! in the 3.077-3.846 um wavelenght band (i.e., a check of LUT for LW vs. SW). + call outfld('BATSW13 ',batotsw13,pcols,lchnk) + call outfld('BATLW01 ',batotlw01,pcols,lchnk) + end if !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! APPROXIMATE aerosol extinction and absorption at 550nm (0.442-0.625 um) - ! (in the visible wavelength band) + ! APPROXIMATE aerosol extinction and absorption at 550nm (0.442-0.625 um) + ! (in the visible wavelength band) do k=1,pver do icol=1,ncol betotvis(icol,k)=betot(icol,k,4) @@ -1012,10 +962,10 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & do k=1,pver do icol=1,ncol - ! dayfoc < 1 when looping only over gridcells with daylight + ! dayfoc < 1 when looping only over gridcells with daylight if(daylight(icol)) then dayfoc(icol,k) = 1.0_r8 - ! with the new bands in CAM5, band 4 is now at ca 0.5 um (0.442-0.625) + ! with the new bands in CAM5, band 4 is now at ca 0.5 um (0.442-0.625) ssavis(icol,k) = ssatot(icol,k,4) asymmvis(icol,k) = asymtot(icol,k,4) extvis(icol,k) = betot(icol,k,4) @@ -1023,86 +973,52 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & enddo end do - ! optical parameters in visible light (0.442-0.625um) + ! optical parameters in visible light (0.442-0.625um) call outfld('SSAVIS ',ssavis,pcols,lchnk) call outfld('ASYMMVIS',asymmvis,pcols,lchnk) call outfld('EXTVIS ',extvis,pcols,lchnk) call outfld('DAYFOC ',dayfoc,pcols,lchnk) - ! Initialize fields + ! Initialize fields do icol=1,ncol - ! akso4c(icol)=0.0_r8 - ! akbcc(icol)=0.0_r8 - ! akocc(icol)=0.0_r8 + ! akso4c(icol)=0.0_r8 + ! akbcc(icol)=0.0_r8 + ! akocc(icol)=0.0_r8 aodvis(icol)=0.0_r8 absvis(icol)=0.0_r8 aodvisvolc(icol)=0.0_r8 absvisvolc(icol)=0.0_r8 airmass(icol)=0.0_r8 !akc6 -#ifdef COLTST4INTCONS - taukc0(icol)=0.0_r8 - taukc1(icol)=0.0_r8 - taukc2(icol)=0.0_r8 - ! taukc3(icol)=0.0_r8 - taukc4(icol)=0.0_r8 - taukc5(icol)=0.0_r8 - taukc6(icol)=0.0_r8 - taukc7(icol)=0.0_r8 - taukc8(icol)=0.0_r8 - taukc9(icol)=0.0_r8 - taukc10(icol)=0.0_r8 - ! taukc11(icol)=0.0_r8 - taukc12(icol)=0.0_r8 - ! taukc13(icol)=0.0_r8 - taukc14(icol)=0.0_r8 -#endif enddo do icol=1,ncol if(daylight(icol)) then do k=1,pver - ! Layer thickness, unit km, and layer airmass, unit kg/m2 + ! Layer thickness, unit km, and layer airmass, unit kg/m2 deltah=deltah_km(icol,k) !akc6 airmass(icol,k)=1.e3_r8*deltah*rhoda(icol,k) airmassl(icol,k)=1.e3_r8*deltah*rhoda(icol,k) airmass(icol)=airmass(icol)+airmassl(icol,k) !akc6 - ! Optical depths at ca. 550 nm (0.442-0.625um) all aerosols + ! Optical depths at ca. 550 nm (0.442-0.625um) all aerosols !tst - ! aodvis3d(icol,k)=betotvis(icol,k)*deltah + ! aodvis3d(icol,k)=betotvis(icol,k)*deltah !tst aodvis(icol)=aodvis(icol)+betotvis(icol,k)*deltah absvis(icol)=absvis(icol)+batotvis(icol,k)*deltah - ! Optical depths at ca. 550 nm (0.442-0.625um) CMIP6 volcanic aerosol + ! Optical depths at ca. 550 nm (0.442-0.625um) CMIP6 volcanic aerosol aodvisvolc(icol)=aodvisvolc(icol)+volc_ext_sun(icol,k,4)*deltah absvisvolc(icol)=absvisvolc(icol)+volc_ext_sun(icol,k,4) & *(1.0_r8-volc_omega_sun(icol,k,4))*deltah -#ifdef COLTST4INTCONS - ! To check internal consistency of these AOD calculations, make - ! sure that sum_i(taukc_i)=aodvis (tested to be ok on 7/1-2016). - ! Note that this will not be the case when CMIP6 volcanic forcing - ! as optical properties are included, since this comes "on top of" - ! the mixtures 0-14 below. - taukc0(icol) =taukc0(icol) +bekc0(icol,k)*deltah - taukc1(icol) =taukc1(icol) +bekc1(icol,k)*deltah - taukc2(icol) =taukc2(icol) +bekc2(icol,k)*deltah - taukc4(icol) =taukc4(icol) +bekc4(icol,k)*deltah - taukc5(icol) =taukc5(icol) +bekc5(icol,k)*deltah - taukc6(icol) =taukc6(icol) +bekc6(icol,k)*deltah - taukc7(icol) =taukc7(icol) +bekc7(icol,k)*deltah - taukc8(icol) =taukc8(icol) +bekc8(icol,k)*deltah - taukc9(icol) =taukc9(icol) +bekc9(icol,k)*deltah - taukc10(icol)=taukc10(icol)+bekc10(icol,k)*deltah - taukc12(icol)=taukc12(icol)+bekc12(icol,k)*deltah - taukc14(icol)=taukc14(icol)+bekc14(icol,k)*deltah -#endif end do ! k endif ! daylight end do ! icol - ! Extinction and absorption for 0.55 um for the total aerosol, and AODs - call outfld('BETOTVIS',betotvis,pcols,lchnk) - call outfld('BATOTVIS',batotvis,pcols,lchnk) - ! call outfld('AODVIS ',aodvis ,pcols,lchnk) + ! Extinction and absorption for 0.55 um for the total aerosol, and AODs + if (do_aerocom) then + call outfld('BETOTVIS',betotvis,pcols,lchnk) + call outfld('BATOTVIS',batotvis,pcols,lchnk) + end if + ! call outfld('AODVIS ',aodvis ,pcols,lchnk) call outfld('AOD_VIS ',aodvis ,pcols,lchnk) call outfld('ABSVIS ',absvis ,pcols,lchnk) call outfld('AODVVOLC',aodvisvolc ,pcols,lchnk) @@ -1111,1165 +1027,1159 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & call outfld('BVISVOLC',bevisvolc ,pcols,lchnk) !akc6- !tst - ! call outfld('AODVIS3D',aodvis3d,pcols,lchnk) + ! call outfld('AODVIS3D',aodvis3d,pcols,lchnk) !tst -#ifdef COLTST4INTCONS - call outfld('TAUKC0 ',taukc0 ,pcols,lchnk) - call outfld('TAUKC1 ',taukc1 ,pcols,lchnk) - call outfld('TAUKC2 ',taukc2 ,pcols,lchnk) - call outfld('TAUKC4 ',taukc4 ,pcols,lchnk) - call outfld('TAUKC5 ',taukc5 ,pcols,lchnk) - call outfld('TAUKC6 ',taukc6 ,pcols,lchnk) - call outfld('TAUKC7 ',taukc7 ,pcols,lchnk) - call outfld('TAUKC8 ',taukc8 ,pcols,lchnk) - call outfld('TAUKC9 ',taukc9 ,pcols,lchnk) - call outfld('TAUKC10 ',taukc10,pcols,lchnk) - call outfld('TAUKC12 ',taukc12,pcols,lchnk) - call outfld('TAUKC14 ',taukc14,pcols,lchnk) - ! - call outfld('MECKC0 ',kekc0 ,pcols,lchnk) - call outfld('MECKC1 ',kekc1 ,pcols,lchnk) - call outfld('MECKC2 ',kekc2 ,pcols,lchnk) - call outfld('MECKC4 ',kekc4 ,pcols,lchnk) - call outfld('MECKC5 ',kekc5 ,pcols,lchnk) - call outfld('MECKC6 ',kekc6 ,pcols,lchnk) - call outfld('MECKC7 ',kekc7 ,pcols,lchnk) - call outfld('MECKC8 ',kekc8 ,pcols,lchnk) - call outfld('MECKC9 ',kekc9 ,pcols,lchnk) - call outfld('MECKC10 ',kekc10 ,pcols,lchnk) - call outfld('MECKC12 ',kekc12 ,pcols,lchnk) - call outfld('MECKC14 ',kekc14 ,pcols,lchnk) -#endif - ra#ifdef AEROCOM ! AEROCOM***********AEROCOM**************AEROCOM***************below + ! AEROCOM***********AEROCOM**************AEROCOM***************below - ! call outfld('BEKC4 ',bekc4 ,pcols,lchnk) + if (do_aerocom) then - ! Initialize fields - do icol=1,ncol - daerh2o(icol)=0.0_r8 - vaercols(icol)=0.0_r8 - vaercoll(icol)=0.0_r8 - aaercols(icol)=0.0_r8 - aaercoll(icol)=0.0_r8 - do i=0,nmodes - dload(icol,i)=0.0_r8 + ! Initialize fields + do icol=1,ncol + daerh2o(icol)=0.0_r8 + vaercols(icol)=0.0_r8 + vaercoll(icol)=0.0_r8 + aaercols(icol)=0.0_r8 + aaercoll(icol)=0.0_r8 + do i=0,nmodes + dload(icol,i)=0.0_r8 + enddo enddo - enddo - bext550n(:,:,:) = 0._r8 - babs550n(:,:,:) = 0._r8 - bext440n(:,:,:) = 0._r8 - babs440n(:,:,:) = 0._r8 - bext870n(:,:,:) = 0._r8 - babs870n(:,:,:) = 0._r8 - babs500n(:,:,:) = 0._r8 - babs670n(:,:,:) = 0._r8 - vnbcarr(:,:) =0.0_r8 - vaitbcarr(:,:) =0.0_r8 - cknorm(:,:,:) =0.0_r8 - - !-------------------------------------- - ! AeroCom diagnostics requiring table look-ups with ambient RH. - !-------------------------------------- - - do irf=0,0 - call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana, & - bebglt1, bebggt1, bebclt1, bebcgt1, & - beoclt1, beocgt1, bes4lt1, bes4gt1, & - bebglt1n, bebggt1n, bebclt1n, bebcgt1n, & - beoclt1n, beocgt1n, bes4lt1n, bes4gt1n) - end do ! irf - - !-------------------------------------- + bext550n(:,:,:) = 0._r8 + babs550n(:,:,:) = 0._r8 + bext440n(:,:,:) = 0._r8 + babs440n(:,:,:) = 0._r8 + bext870n(:,:,:) = 0._r8 + babs870n(:,:,:) = 0._r8 + babs500n(:,:,:) = 0._r8 + babs670n(:,:,:) = 0._r8 + vnbcarr(:,:) =0.0_r8 + vaitbcarr(:,:) =0.0_r8 + cknorm(:,:,:) =0.0_r8 + !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + + ! AeroCom diagnostics requiring table look-ups with ambient RH. + + do irf=0,0 + call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) + end do ! irf + !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - do k=1,pver - do icol=1,ncol + do k=1,pver + do icol=1,ncol - bebglt1t(icol,k)=0.0_r8 - bebggt1t(icol,k)=0.0_r8 - bebclt1t(icol,k)=0.0_r8 - bebcgt1t(icol,k)=0.0_r8 - beoclt1t(icol,k)=0.0_r8 - beocgt1t(icol,k)=0.0_r8 - bes4lt1t(icol,k)=0.0_r8 - bes4gt1t(icol,k)=0.0_r8 - bedustlt1(icol,k)=0.0_r8 - bedustgt1(icol,k)=0.0_r8 - besslt1(icol,k)=0.0_r8 - bessgt1(icol,k)=0.0_r8 - - bext440tot(icol,k)=0.0_r8 - babs440tot(icol,k)=0.0_r8 - bext500tot(icol,k)=0.0_r8 - babs500tot(icol,k)=0.0_r8 - bext550tot(icol,k)=0.0_r8 - babs550tot(icol,k)=0.0_r8 - bext670tot(icol,k)=0.0_r8 - babs670tot(icol,k)=0.0_r8 - bext870tot(icol,k)=0.0_r8 - babs870tot(icol,k)=0.0_r8 - - backsc550tot(icol,k)=0.0_r8 - - bebg440tot(icol,k)=0.0_r8 - bebg500tot(icol,k)=0.0_r8 - bebg550tot(icol,k)=0.0_r8 - babg550tot(icol,k)=0.0_r8 - bebg670tot(icol,k)=0.0_r8 - bebg870tot(icol,k)=0.0_r8 - - bebc440tot(icol,k)=0.0_r8 - bebc500tot(icol,k)=0.0_r8 - bebc550tot(icol,k)=0.0_r8 - babc550tot(icol,k)=0.0_r8 - bebc670tot(icol,k)=0.0_r8 - bebc870tot(icol,k)=0.0_r8 - - beoc440tot(icol,k)=0.0_r8 - beoc500tot(icol,k)=0.0_r8 - beoc550tot(icol,k)=0.0_r8 - baoc550tot(icol,k)=0.0_r8 - beoc670tot(icol,k)=0.0_r8 - beoc870tot(icol,k)=0.0_r8 - - besu440tot(icol,k)=0.0_r8 - besu500tot(icol,k)=0.0_r8 - besu550tot(icol,k)=0.0_r8 - basu550tot(icol,k)=0.0_r8 - besu670tot(icol,k)=0.0_r8 - besu870tot(icol,k)=0.0_r8 + bebglt1t(icol,k)=0.0_r8 + bebggt1t(icol,k)=0.0_r8 + bebclt1t(icol,k)=0.0_r8 + bebcgt1t(icol,k)=0.0_r8 + beoclt1t(icol,k)=0.0_r8 + beocgt1t(icol,k)=0.0_r8 + bes4lt1t(icol,k)=0.0_r8 + bes4gt1t(icol,k)=0.0_r8 + bedustlt1(icol,k)=0.0_r8 + bedustgt1(icol,k)=0.0_r8 + besslt1(icol,k)=0.0_r8 + bessgt1(icol,k)=0.0_r8 + + bext440tot(icol,k)=0.0_r8 + babs440tot(icol,k)=0.0_r8 + bext500tot(icol,k)=0.0_r8 + babs500tot(icol,k)=0.0_r8 + bext550tot(icol,k)=0.0_r8 + babs550tot(icol,k)=0.0_r8 + bext670tot(icol,k)=0.0_r8 + babs670tot(icol,k)=0.0_r8 + bext870tot(icol,k)=0.0_r8 + babs870tot(icol,k)=0.0_r8 + + backsc550tot(icol,k)=0.0_r8 + + bebg440tot(icol,k)=0.0_r8 + bebg500tot(icol,k)=0.0_r8 + bebg550tot(icol,k)=0.0_r8 + babg550tot(icol,k)=0.0_r8 + bebg670tot(icol,k)=0.0_r8 + bebg870tot(icol,k)=0.0_r8 + + bebc440tot(icol,k)=0.0_r8 + bebc500tot(icol,k)=0.0_r8 + bebc550tot(icol,k)=0.0_r8 + babc550tot(icol,k)=0.0_r8 + bebc670tot(icol,k)=0.0_r8 + bebc870tot(icol,k)=0.0_r8 + + beoc440tot(icol,k)=0.0_r8 + beoc500tot(icol,k)=0.0_r8 + beoc550tot(icol,k)=0.0_r8 + baoc550tot(icol,k)=0.0_r8 + beoc670tot(icol,k)=0.0_r8 + beoc870tot(icol,k)=0.0_r8 + + besu440tot(icol,k)=0.0_r8 + besu500tot(icol,k)=0.0_r8 + besu550tot(icol,k)=0.0_r8 + basu550tot(icol,k)=0.0_r8 + besu670tot(icol,k)=0.0_r8 + besu870tot(icol,k)=0.0_r8 + enddo enddo - enddo - do i=0,nbmodes + do i=0,nbmodes + do k=1,pver + do icol=1,ncol + ! total internal extinction and absorption for 0.44, 0.50, 0.55, 0.68 and 0.87 um + bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*bext440(icol,k,i) + babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i) + bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*bext500(icol,k,i) + babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i) + bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*bext550(icol,k,i) + babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i) + bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*bext670(icol,k,i) + babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i) + bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*bext870(icol,k,i) + babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i) + backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*backsc550(icol,k,i) + + ! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um + ! for the whole background aerosol (icluding SO4,BC, and OC for modes 0-5) + bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*bebg440(icol,k,i) + bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*bebg500(icol,k,i) + bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*bebg550(icol,k,i) + babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*babg550(icol,k,i) + bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*bebg670(icol,k,i) + bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*bebg870(icol,k,i) + besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*besu440(icol,k,i) + besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*besu500(icol,k,i) + besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*besu550(icol,k,i) + basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*basu550(icol,k,i) + besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*besu670(icol,k,i) + besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*besu870(icol,k,i) + ! + ! Condensed OC on modes 1-4 and coagulated BC and OC on modes 5-10: + if(i>=1) then + bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i)*bebc440(icol,k,i) + ! babc440tot(icol,k)=babc440tot(icol,k)+Nnatk(icol,k,i)*babc440(icol,k,i) + bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i)*bebc500(icol,k,i) + ! babc500tot(icol,k)=babc500tot(icol,k)+Nnatk(icol,k,i)*babc500(icol,k,i) + bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i)*bebc550(icol,k,i) + babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i)*babc550(icol,k,i) + bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i)*bebc670(icol,k,i) + ! babc670tot(icol,k)=babc670tot(icol,k)+Nnatk(icol,k,i)*babc670(icol,k,i) + bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i)*bebc870(icol,k,i) + ! babc870tot(icol,k)=babc870tot(icol,k)+Nnatk(icol,k,i)*babc870(icol,k,i) + beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i)*beoc440(icol,k,i) + ! baoc440tot(icol,k)=baoc440tot(icol,k)+Nnatk(icol,k,i)*baoc440(icol,k,i) + beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i)*beoc500(icol,k,i) + ! baoc500tot(icol,k)=baoc500tot(icol,k)+Nnatk(icol,k,i)*baoc500(icol,k,i) + beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i)*beoc550(icol,k,i) + baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i)*baoc550(icol,k,i) + beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i)*beoc670(icol,k,i) + ! baoc670tot(icol,k)=baoc670tot(icol,k)+Nnatk(icol,k,i)*baoc670(icol,k,i) + beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i)*beoc870(icol,k,i) + ! baoc870tot(icol,k)=baoc870tot(icol,k)+Nnatk(icol,k,i)*baoc870(icol,k,i) + endif ! i>=1 + if(i==6.or.i==7) then + bedustlt1(icol,k)=bedustlt1(icol,k) & + +Nnatk(icol,k,i)*bebglt1(icol,k,i) + bedustgt1(icol,k)=bedustgt1(icol,k) & + +Nnatk(icol,k,i)*bebggt1(icol,k,i) + elseif(i>=8.and.i<=10) then + besslt1(icol,k)=besslt1(icol,k) & + +Nnatk(icol,k,i)*bebglt1(icol,k,i) + bessgt1(icol,k)=bessgt1(icol,k) & + +Nnatk(icol,k,i)*bebggt1(icol,k,i) + endif + ! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: + bes4lt1t(icol,k)=bes4lt1t(icol,k) & + +Nnatk(icol,k,i)*bes4lt1(icol,k,i) + bes4gt1t(icol,k)=bes4gt1t(icol,k) & + +Nnatk(icol,k,i)*bes4gt1(icol,k,i) + ! Condensed OC on mode 1 and coagulated BC and OC on modes 5-10: + if(i>=1) then + bebclt1t(icol,k)=bebclt1t(icol,k) & + +Nnatk(icol,k,i)*bebclt1(icol,k,i) + bebcgt1t(icol,k)=bebcgt1t(icol,k) & + +Nnatk(icol,k,i)*bebcgt1(icol,k,i) + beoclt1t(icol,k)=beoclt1t(icol,k) & + +Nnatk(icol,k,i)*beoclt1(icol,k,i) + beocgt1t(icol,k)=beocgt1t(icol,k) & + +Nnatk(icol,k,i)*beocgt1(icol,k,i) + endif ! i>=1 + end do ! icol + enddo ! k + enddo ! i + + ! extinction/absorptions (km-1) for each background component + ! in the internal mixture are do k=1,pver do icol=1,ncol - ! total internal extinction and absorption for 0.44, 0.50, 0.55, 0.68 and 0.87 um - bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*bext440(icol,k,i) - babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i) - bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*bext500(icol,k,i) - babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i) - bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*bext550(icol,k,i) - babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i) - bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*bext670(icol,k,i) - babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i) - bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*bext870(icol,k,i) - babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i) - backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*backsc550(icol,k,i) - - ! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um - ! for the whole background aerosol (icluding SO4,BC, and OC for modes 0-5) - bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*bebg440(icol,k,i) - bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*bebg500(icol,k,i) - bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*bebg550(icol,k,i) - babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*babg550(icol,k,i) - bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*bebg670(icol,k,i) - bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*bebg870(icol,k,i) - - ! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um - ! for each added (internally mixed through Aq./cond./coag.) component (SO4,BC,OC). - ! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: - besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*besu440(icol,k,i) - besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*besu500(icol,k,i) - besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*besu550(icol,k,i) - basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*basu550(icol,k,i) - besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*besu670(icol,k,i) - besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*besu870(icol,k,i) - ! - ! Condensed OC on modes 1-4 and coagulated BC and OC on modes 5-10: - if(i>=1) then - bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc440(icol,k,i) - bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc500(icol,k,i) - bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc550(icol,k,i) - babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%babc550(icol,k,i) - bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc670(icol,k,i) - bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%bebc870(icol,k,i) - beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc440(icol,k,i) - beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc500(icol,k,i) - beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc550(icol,k,i) - baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%baoc550(icol,k,i) - beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc670(icol,k,i) - beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i) * extinction_coeff%beoc870(icol,k,i) - endif ! i>=1 - if(i==6.or.i==7) then - bedustlt1(icol,k)=bedustlt1(icol,k) + Nnatk(icol,k,i) * bebglt1(icol,k,i) - bedustgt1(icol,k)=bedustgt1(icol,k) + Nnatk(icol,k,i) * bebggt1(icol,k,i) - elseif(i>=8.and.i<=10) then - besslt1(icol,k)=besslt1(icol,k) + Nnatk(icol,k,i)*bebglt1(icol,k,i) - bessgt1(icol,k)=bessgt1(icol,k) + Nnatk(icol,k,i)*bebggt1(icol,k,i) - endif - ! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: - bes4lt1t(icol,k)=bes4lt1t(icol,k) & - +Nnatk(icol,k,i)*bes4lt1(icol,k,i) - bes4gt1t(icol,k)=bes4gt1t(icol,k) & - +Nnatk(icol,k,i)*bes4gt1(icol,k,i) - ! Condensed OC on mode 1 and coagulated BC and OC on modes 5-10: - if(i>=1) then - bebclt1t(icol,k)=bebclt1t(icol,k) & - +Nnatk(icol,k,i)*bebclt1(icol,k,i) - bebcgt1t(icol,k)=bebcgt1t(icol,k) & - +Nnatk(icol,k,i)*bebcgt1(icol,k,i) - beoclt1t(icol,k)=beoclt1t(icol,k) & - +Nnatk(icol,k,i)*beoclt1(icol,k,i) - beocgt1t(icol,k)=beocgt1t(icol,k) & - +Nnatk(icol,k,i)*beocgt1(icol,k,i) - endif ! i>=1 - end do ! icol - enddo ! k - enddo ! i + bint440du(icol,k)=Nnatk(icol,k,6)*bebg440(icol,k,6) & + +Nnatk(icol,k,7)*bebg440(icol,k,7) + bint500du(icol,k)=Nnatk(icol,k,6)*bebg500(icol,k,6) & + +Nnatk(icol,k,7)*bebg500(icol,k,7) + bint550du(icol,k)=Nnatk(icol,k,6)*bebg550(icol,k,6) & + +Nnatk(icol,k,7)*bebg550(icol,k,7) + bint670du(icol,k)=Nnatk(icol,k,6)*bebg670(icol,k,6) & + +Nnatk(icol,k,7)*bebg670(icol,k,7) + bint870du(icol,k)=Nnatk(icol,k,6)*bebg870(icol,k,6) & + +Nnatk(icol,k,7)*bebg870(icol,k,7) + bint440ss(icol,k)=Nnatk(icol,k,8)*bebg440(icol,k,8) & + +Nnatk(icol,k,9)*bebg440(icol,k,9) & + +Nnatk(icol,k,10)*bebg440(icol,k,10) + bint500ss(icol,k)=Nnatk(icol,k,8)*bebg500(icol,k,8) & + +Nnatk(icol,k,9)*bebg500(icol,k,9) & + +Nnatk(icol,k,10)*bebg500(icol,k,10) + bint550ss(icol,k)=Nnatk(icol,k,8)*bebg550(icol,k,8) & + +Nnatk(icol,k,9)*bebg550(icol,k,9) & + +Nnatk(icol,k,10)*bebg550(icol,k,10) + bint670ss(icol,k)=Nnatk(icol,k,8)*bebg670(icol,k,8) & + +Nnatk(icol,k,9)*bebg670(icol,k,9) & + +Nnatk(icol,k,10)*bebg670(icol,k,10) + bint870ss(icol,k)=Nnatk(icol,k,8)*bebg870(icol,k,8) & + +Nnatk(icol,k,9)*bebg870(icol,k,9) & + +Nnatk(icol,k,10)*bebg870(icol,k,10) + baint550du(icol,k)=Nnatk(icol,k,6)*babg550(icol,k,6) & + +Nnatk(icol,k,7)*babg550(icol,k,7) + baint550ss(icol,k)=Nnatk(icol,k,8)*babg550(icol,k,8) & + +Nnatk(icol,k,9)*babg550(icol,k,9) & + +Nnatk(icol,k,10)*babg550(icol,k,10) + end do + enddo - ! extinction/absorptions (km-1) for each background component - ! in the internal mixture are - do k=1,pver - do icol=1,ncol - bint440du(icol,k)=Nnatk(icol,k,6)*bebg440(icol,k,6) & - +Nnatk(icol,k,7)*bebg440(icol,k,7) - bint500du(icol,k)=Nnatk(icol,k,6)*bebg500(icol,k,6) & - +Nnatk(icol,k,7)*bebg500(icol,k,7) - bint550du(icol,k)=Nnatk(icol,k,6)*bebg550(icol,k,6) & - +Nnatk(icol,k,7)*bebg550(icol,k,7) - bint670du(icol,k)=Nnatk(icol,k,6)*bebg670(icol,k,6) & - +Nnatk(icol,k,7)*bebg670(icol,k,7) - bint870du(icol,k)=Nnatk(icol,k,6)*bebg870(icol,k,6) & - +Nnatk(icol,k,7)*bebg870(icol,k,7) - bint440ss(icol,k)=Nnatk(icol,k,8)*bebg440(icol,k,8) & - +Nnatk(icol,k,9)*bebg440(icol,k,9) & - +Nnatk(icol,k,10)*bebg440(icol,k,10) - bint500ss(icol,k)=Nnatk(icol,k,8)*bebg500(icol,k,8) & - +Nnatk(icol,k,9)*bebg500(icol,k,9) & - +Nnatk(icol,k,10)*bebg500(icol,k,10) - bint550ss(icol,k)=Nnatk(icol,k,8)*bebg550(icol,k,8) & - +Nnatk(icol,k,9)*bebg550(icol,k,9) & - +Nnatk(icol,k,10)*bebg550(icol,k,10) - bint670ss(icol,k)=Nnatk(icol,k,8)*bebg670(icol,k,8) & - +Nnatk(icol,k,9)*bebg670(icol,k,9) & - +Nnatk(icol,k,10)*bebg670(icol,k,10) - bint870ss(icol,k)=Nnatk(icol,k,8)*bebg870(icol,k,8) & - +Nnatk(icol,k,9)*bebg870(icol,k,9) & - +Nnatk(icol,k,10)*bebg870(icol,k,10) - baint550du(icol,k)=Nnatk(icol,k,6)*babg550(icol,k,6) & - +Nnatk(icol,k,7)*babg550(icol,k,7) - baint550ss(icol,k)=Nnatk(icol,k,8)*babg550(icol,k,8) & - +Nnatk(icol,k,9)*babg550(icol,k,9) & - +Nnatk(icol,k,10)*babg550(icol,k,10) - end do - enddo + do i=11,14 + do k=1,pver + do icol=1,ncol + be440x(icol,k,i)=bext440n(icol,k,i-10) + ba440x(icol,k,i)=babs440n(icol,k,i-10) + be500x(icol,k,i)=bext500n(icol,k,i-10) + ba500x(icol,k,i)=babs500n(icol,k,i-10) + be550x(icol,k,i)=bext550n(icol,k,i-10) + ba550x(icol,k,i)=babs550n(icol,k,i-10) + be670x(icol,k,i)=bext670n(icol,k,i-10) + ba670x(icol,k,i)=babs670n(icol,k,i-10) + be870x(icol,k,i)=bext870n(icol,k,i-10) + ba870x(icol,k,i)=babs870n(icol,k,i-10) + belt1x(icol,k,i)=bebglt1n(icol,k,i-10) + begt1x(icol,k,i)=bebggt1n(icol,k,i-10) + backsc550x(icol,k,i)=backsc550n(icol,k,i-10) + end do + enddo + enddo - do i=11,14 + ! The externally modes' contribution to extinction and absorption: do k=1,pver do icol=1,ncol - be440x(icol,k,i)=bext440n(icol,k,i-10) - ba440x(icol,k,i)=babs440n(icol,k,i-10) - be500x(icol,k,i)=bext500n(icol,k,i-10) - ba500x(icol,k,i)=babs500n(icol,k,i-10) - be550x(icol,k,i)=bext550n(icol,k,i-10) - ba550x(icol,k,i)=babs550n(icol,k,i-10) - be670x(icol,k,i)=bext670n(icol,k,i-10) - ba670x(icol,k,i)=babs670n(icol,k,i-10) - be870x(icol,k,i)=bext870n(icol,k,i-10) - ba870x(icol,k,i)=babs870n(icol,k,i-10) - belt1x(icol,k,i)=bebglt1n(icol,k,i-10) - begt1x(icol,k,i)=bebggt1n(icol,k,i-10) - backsc550x(icol,k,i)=backsc550n(icol,k,i-10) + + !BC + vnbcarr(icol,k) = fnbc(icol,k)/(fnbc(icol,k) & + +(1.0_r8-fnbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) + vnbc = vnbcarr(icol,k) + bebc440xt(icol,k) =Nnatk(icol,k,12)*be440x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) + babc440xt(icol,k) =Nnatk(icol,k,12)*ba440x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) + bebc500xt(icol,k) =Nnatk(icol,k,12)*be500x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) + babc500xt(icol,k) =Nnatk(icol,k,12)*ba500x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) + bebc550xt(icol,k) =Nnatk(icol,k,12)*be550x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) + babc550xt(icol,k) =Nnatk(icol,k,12)*ba550x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) + bebc670xt(icol,k) =Nnatk(icol,k,12)*be670x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) + babc670xt(icol,k) =Nnatk(icol,k,12)*ba670x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) + bebc870xt(icol,k) =Nnatk(icol,k,12)*be870x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) + babc870xt(icol,k) =Nnatk(icol,k,12)*ba870x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) + bbclt1xt(icol,k)=Nnatk(icol,k,12)*belt1x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) + bbcgt1xt(icol,k)=Nnatk(icol,k,12)*begt1x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) + !OC + beoc440xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be440x(icol,k,14) + baoc440xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba440x(icol,k,14) + beoc500xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be500x(icol,k,14) + baoc500xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba500x(icol,k,14) + beoc550xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be550x(icol,k,14) + baoc550xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba550x(icol,k,14) + beoc670xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be670x(icol,k,14) + baoc670xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba670x(icol,k,14) + beoc870xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be870x(icol,k,14) + baoc870xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba870x(icol,k,14) + boclt1xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*belt1x(icol,k,14) + bocgt1xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*begt1x(icol,k,14) + ! Total (for all modes) absorption optical depth and backscattering + abs550_aer(icol,k)=babs550tot(icol,k) & + +Nnatk(icol,k,12)*ba550x(icol,k,12) & + +Nnatk(icol,k,14)*ba550x(icol,k,14) + abs550_aer(icol,k)=1.e-3_r8*abs550_aer(icol,k) + bs550_aer(icol,k)= backsc550tot(icol,k) & + +Nnatk(icol,k,12)*backsc550x(icol,k,12) & + +Nnatk(icol,k,14)*backsc550x(icol,k,14) + bs550_aer(icol,k)=1.e-3_r8*bs550_aer(icol,k) + ! end do enddo - enddo - - ! The externally modes' contribution to extinction and absorption: - do k=1,pver + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! collect AeroCom-fields for optical depth/absorption of each comp, + ! 3D and 2D, at 440, 500, 550, 670 and 870 nm, for all d, d<1um and d>1um + ! initialize 2d-fields do icol=1,ncol - - !BC - vnbcarr(icol,k) = fnbc(icol,k)/(fnbc(icol,k) & - +(1.0_r8-fnbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) - vnbc = vnbcarr(icol,k) - bebc440xt(icol,k) =Nnatk(icol,k,12)*be440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) - babc440xt(icol,k) =Nnatk(icol,k,12)*ba440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) - bebc500xt(icol,k) =Nnatk(icol,k,12)*be500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) - babc500xt(icol,k) =Nnatk(icol,k,12)*ba500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) - bebc550xt(icol,k) =Nnatk(icol,k,12)*be550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) - babc550xt(icol,k) =Nnatk(icol,k,12)*ba550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) - bebc670xt(icol,k) =Nnatk(icol,k,12)*be670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) - babc670xt(icol,k) =Nnatk(icol,k,12)*ba670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) - bebc870xt(icol,k) =Nnatk(icol,k,12)*be870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) - babc870xt(icol,k) =Nnatk(icol,k,12)*ba870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) - bbclt1xt(icol,k)=Nnatk(icol,k,12)*belt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) - bbcgt1xt(icol,k)=Nnatk(icol,k,12)*begt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) - !OC - beoc440xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be440x(icol,k,14) - baoc440xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba440x(icol,k,14) - beoc500xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be500x(icol,k,14) - baoc500xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba500x(icol,k,14) - beoc550xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be550x(icol,k,14) - baoc550xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba550x(icol,k,14) - beoc670xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be670x(icol,k,14) - baoc670xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba670x(icol,k,14) - beoc870xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be870x(icol,k,14) - baoc870xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba870x(icol,k,14) - boclt1xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*belt1x(icol,k,14) - bocgt1xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*begt1x(icol,k,14) - ! Total (for all modes) absorption optical depth and backscattering - abs550_aer(icol,k)=babs550tot(icol,k) & - +Nnatk(icol,k,12)*ba550x(icol,k,12) & - +Nnatk(icol,k,14)*ba550x(icol,k,14) - abs550_aer(icol,k)=1.e-3_r8*abs550_aer(icol,k) - bs550_aer(icol,k)= backsc550tot(icol,k) & - +Nnatk(icol,k,12)*backsc550x(icol,k,12) & - +Nnatk(icol,k,14)*backsc550x(icol,k,14) - bs550_aer(icol,k)=1.e-3_r8*bs550_aer(icol,k) + dod440(icol) = 0.0_r8 + abs440(icol) = 0.0_r8 + dod500(icol) = 0.0_r8 + abs500(icol) = 0.0_r8 + dod550(icol) = 0.0_r8 + abs550(icol) = 0.0_r8 + abs550alt(icol) = 0.0_r8 + dod670(icol) = 0.0_r8 + abs670(icol) = 0.0_r8 + dod870(icol) = 0.0_r8 + abs870(icol) = 0.0_r8 ! - end do - enddo - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! collect AeroCom-fields for optical depth/absorption of each comp, - ! 3D and 2D, at 440, 500, 550, 670 and 870 nm, for all d, d<1um and d>1um - ! initialize 2d-fields - do icol=1,ncol - dod440(icol) = 0.0_r8 - abs440(icol) = 0.0_r8 - dod500(icol) = 0.0_r8 - abs500(icol) = 0.0_r8 - dod550(icol) = 0.0_r8 - abs550(icol) = 0.0_r8 - abs550alt(icol) = 0.0_r8 - dod670(icol) = 0.0_r8 - abs670(icol) = 0.0_r8 - dod870(icol) = 0.0_r8 - abs870(icol) = 0.0_r8 - ! - abs550_ss(icol) = 0.0_r8 - abs550_dust(icol) = 0.0_r8 - abs550_so4(icol) = 0.0_r8 - abs550_bc(icol) = 0.0_r8 - abs550_pom(icol) = 0.0_r8 - ! - dod440_ss(icol) = 0.0_r8 - dod440_dust(icol) = 0.0_r8 - dod440_so4(icol) = 0.0_r8 - dod440_bc(icol) = 0.0_r8 - dod440_pom(icol) = 0.0_r8 - dod500_ss(icol) = 0.0_r8 - dod500_dust(icol) = 0.0_r8 - dod500_so4(icol) = 0.0_r8 - dod500_bc(icol) = 0.0_r8 - dod500_pom(icol) = 0.0_r8 - dod550_ss(icol) = 0.0_r8 - dod550_dust(icol) = 0.0_r8 - dod550_so4(icol) = 0.0_r8 - dod550_bc(icol) = 0.0_r8 - dod550_pom(icol) = 0.0_r8 - dod670_ss(icol) = 0.0_r8 - dod670_dust(icol) = 0.0_r8 - dod670_so4(icol) = 0.0_r8 - dod670_bc(icol) = 0.0_r8 - dod670_pom(icol) = 0.0_r8 - dod870_ss(icol) = 0.0_r8 - dod870_dust(icol) = 0.0_r8 - dod870_so4(icol) = 0.0_r8 - dod870_bc(icol) = 0.0_r8 - dod870_pom(icol) = 0.0_r8 - dod550lt1_ss(icol) = 0.0_r8 - dod550gt1_ss(icol) = 0.0_r8 - dod550lt1_dust(icol) = 0.0_r8 - dod550gt1_dust(icol) = 0.0_r8 - dod550lt1_so4(icol) = 0.0_r8 - dod550gt1_so4(icol) = 0.0_r8 - dod550lt1_bc(icol) = 0.0_r8 - dod550gt1_bc(icol) = 0.0_r8 - dod550lt1_pom(icol) = 0.0_r8 - dod550gt1_pom(icol) = 0.0_r8 - do k=1,pver - abs4403d(icol,k) = 0.0_r8 - abs5003d(icol,k) = 0.0_r8 - abs5503d(icol,k) = 0.0_r8 - abs6703d(icol,k) = 0.0_r8 - abs8703d(icol,k) = 0.0_r8 - abs5503dalt(icol,k) = 0.0_r8 + abs550_ss(icol) = 0.0_r8 + abs550_dust(icol) = 0.0_r8 + abs550_so4(icol) = 0.0_r8 + abs550_bc(icol) = 0.0_r8 + abs550_pom(icol) = 0.0_r8 + ! + dod440_ss(icol) = 0.0_r8 + dod440_dust(icol) = 0.0_r8 + dod440_so4(icol) = 0.0_r8 + dod440_bc(icol) = 0.0_r8 + dod440_pom(icol) = 0.0_r8 + dod500_ss(icol) = 0.0_r8 + dod500_dust(icol) = 0.0_r8 + dod500_so4(icol) = 0.0_r8 + dod500_bc(icol) = 0.0_r8 + dod500_pom(icol) = 0.0_r8 + dod550_ss(icol) = 0.0_r8 + dod550_dust(icol) = 0.0_r8 + dod550_so4(icol) = 0.0_r8 + dod550_bc(icol) = 0.0_r8 + dod550_pom(icol) = 0.0_r8 + dod670_ss(icol) = 0.0_r8 + dod670_dust(icol) = 0.0_r8 + dod670_so4(icol) = 0.0_r8 + dod670_bc(icol) = 0.0_r8 + dod670_pom(icol) = 0.0_r8 + dod870_ss(icol) = 0.0_r8 + dod870_dust(icol) = 0.0_r8 + dod870_so4(icol) = 0.0_r8 + dod870_bc(icol) = 0.0_r8 + dod870_pom(icol) = 0.0_r8 + dod550lt1_ss(icol) = 0.0_r8 + dod550gt1_ss(icol) = 0.0_r8 + dod550lt1_dust(icol) = 0.0_r8 + dod550gt1_dust(icol) = 0.0_r8 + dod550lt1_so4(icol) = 0.0_r8 + dod550gt1_so4(icol) = 0.0_r8 + dod550lt1_bc(icol) = 0.0_r8 + dod550gt1_bc(icol) = 0.0_r8 + dod550lt1_pom(icol) = 0.0_r8 + dod550gt1_pom(icol) = 0.0_r8 + do k=1,pver + abs4403d(icol,k) = 0.0_r8 + abs5003d(icol,k) = 0.0_r8 + abs5503d(icol,k) = 0.0_r8 + abs6703d(icol,k) = 0.0_r8 + abs8703d(icol,k) = 0.0_r8 + abs5503dalt(icol,k) = 0.0_r8 + enddo enddo - enddo - do icol=1,ncol - do k=1,pver - ! Layer thickness, unit km - deltah=deltah_km(icol,k) - ! if(k==pver) write(*,*) 'icol, deltah(pmxsub)=', icol, deltah - ! 3D optical depths for monthly averages - !SS - dod4403d_ss(icol,k) = bint440ss(icol,k)*deltah - dod5003d_ss(icol,k) = bint500ss(icol,k)*deltah - dod5503d_ss(icol,k) = bint550ss(icol,k)*deltah - abs5503d_ss(icol,k) = baint550ss(icol,k)*deltah - dod6703d_ss(icol,k) = bint670ss(icol,k)*deltah - dod8703d_ss(icol,k) = bint870ss(icol,k)*deltah - !DUST - dod4403d_dust(icol,k) = bint440du(icol,k)*deltah - dod5003d_dust(icol,k) = bint500du(icol,k)*deltah - dod5503d_dust(icol,k) = bint550du(icol,k)*deltah - abs5503d_dust(icol,k) = baint550du(icol,k)*deltah - dod6703d_dust(icol,k) = bint670du(icol,k)*deltah - dod8703d_dust(icol,k) = bint870du(icol,k)*deltah - !SO4 - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - dod4403d_so4(icol,k) = (besu440tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5003d_so4(icol,k) = (besu500tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5503d_so4(icol,k) = (besu550tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - abs5503d_so4(icol,k) = (basu550tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod6703d_so4(icol,k) = (besu670tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod8703d_so4(icol,k) = (besu870tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - !BC - vaitbcarr(icol,k) = faitbc(icol,k)/(faitbc(icol,k) & - +(1.0_r8-faitbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) - vaitbc = vaitbcarr(icol,k) - dod4403d_bc(icol,k) = (bebc440tot(icol,k)+bebc440xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg440(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5003d_bc(icol,k) = (bebc500tot(icol,k)+bebc500xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg500(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5503d_bc(icol,k) = (bebc550tot(icol,k)+bebc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) - abs5503d_bc(icol,k) = (babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*babg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod6703d_bc(icol,k) = (bebc670tot(icol,k)+bebc670xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg670(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod8703d_bc(icol,k) = (bebc870tot(icol,k)+bebc870xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg870(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) - !OC - !soa + v_soana part of mode 11 for the OC volume fraction of that mode - ! v_soana(icol,k) - dod4403d_pom(icol,k) = (beoc440tot(icol,k)+beoc440xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg440(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) - dod5003d_pom(icol,k) = (beoc500tot(icol,k)+beoc500xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg500(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) - dod5503d_pom(icol,k) = (beoc550tot(icol,k)+beoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg550(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) - abs5503d_pom(icol,k) = (baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*babg550(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) - dod6703d_pom(icol,k) = (beoc670tot(icol,k)+beoc670xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg670(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) - dod8703d_pom(icol,k) = (beoc870tot(icol,k)+beoc870xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg870(icol,k,4))*deltah ! background in OC &BC(Ait) mode (4) - - ec550_so4(icol,k) = 1.e-3*dod5503d_so4(icol,k)/deltah - ec550_bc(icol,k) = 1.e-3*dod5503d_bc(icol,k)/deltah - ec550_pom(icol,k) = 1.e-3*dod5503d_pom(icol,k)/deltah - ec550_ss(icol,k) = 1.e-3*dod5503d_ss(icol,k)/deltah - ec550_du(icol,k) = 1.e-3*dod5503d_dust(icol,k)/deltah - ec550_aer(icol,k) = ec550_so4(icol,k)+ec550_bc(icol,k)+ec550_pom(icol,k) & - + ec550_ss(icol,k) +ec550_du(icol,k) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! Total 3D optical depths/abs. for column integrations - dod4403d(icol,k) = dod4403d_ss(icol,k)+dod4403d_dust(icol,k) & - +dod4403d_so4(icol,k)+dod4403d_bc(icol,k) & - +dod4403d_pom(icol,k) - dod5003d(icol,k) = dod5003d_ss(icol,k)+dod5003d_dust(icol,k) & - +dod5003d_so4(icol,k)+dod5003d_bc(icol,k) & - +dod5003d_pom(icol,k) - dod5503d(icol,k) = dod5503d_ss(icol,k)+dod5503d_dust(icol,k) & - +dod5503d_so4(icol,k)+dod5503d_bc(icol,k) & - +dod5503d_pom(icol,k) - dod6703d(icol,k) = dod6703d_ss(icol,k)+dod6703d_dust(icol,k) & - +dod6703d_so4(icol,k)+dod6703d_bc(icol,k) & - +dod6703d_pom(icol,k) - dod8703d(icol,k) = dod8703d_ss(icol,k)+dod8703d_dust(icol,k) & - +dod8703d_so4(icol,k)+dod8703d_bc(icol,k) & - +dod8703d_pom(icol,k) - abs5503d(icol,k) = abs5503d_ss(icol,k)+abs5503d_dust(icol,k) & - +abs5503d_so4(icol,k)+abs5503d_bc(icol,k) & - +abs5503d_pom(icol,k) - ! (Note: Local abs550alt is up to 6% larger (annually averaged) in typical b.b. - ! regions, compared to abs550. This is most likely most correct, but should be checked!) - do i=0,10 - abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i)*deltah - abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i)*deltah - abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i)*deltah - abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i)*deltah - abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i)*deltah - enddo - do i=11,14 - abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440n(icol,k,i-10)*deltah - abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500n(icol,k,i-10)*deltah - abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670n(icol,k,i-10)*deltah - abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870n(icol,k,i-10)*deltah - abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550n(icol,k,i-10)*deltah - enddo - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! optical depths for d<1um and d>1um (r<0.5um and r>0.5um) - !SS - dod5503dlt1_ss(icol,k) = besslt1(icol,k)*deltah - dod5503dgt1_ss(icol,k) = bessgt1(icol,k)*deltah - !DUST - dod5503dlt1_dust(icol,k) = bedustlt1(icol,k)*deltah - dod5503dgt1_dust(icol,k) = bedustgt1(icol,k)*deltah - - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - dod5503dlt1_so4(icol,k) = (bes4lt1t(icol,k) & ! condensate - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebglt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5503dgt1_so4(icol,k) = (bes4gt1t(icol,k) & ! condensate + n-mode (11) - + Nnatk(icol,k,1)*bebggt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebggt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - !BC - dod5503dlt1_bc(icol,k) = (bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebglt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebglt1(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5503dgt1_bc(icol,k) = (bebcgt1t(icol,k)+bbcgt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebggt1(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebggt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebggt1(icol,k,0))*deltah ! background, BC(ax) mode (0) - !OC - !soa + v_soana part of mode 11 for the OC volume fraction of that mode - dod5503dlt1_pom(icol,k) = (beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + do icol=1,ncol + do k=1,pver + ! Layer thickness, unit km + deltah=deltah_km(icol,k) + ! if(k==pver) write(*,*) 'icol, deltah(pmxsub)=', icol, deltah + ! 3D optical depths for monthly averages + !SS + dod4403d_ss(icol,k) = bint440ss(icol,k)*deltah + dod5003d_ss(icol,k) = bint500ss(icol,k)*deltah + dod5503d_ss(icol,k) = bint550ss(icol,k)*deltah + abs5503d_ss(icol,k) = baint550ss(icol,k)*deltah + dod6703d_ss(icol,k) = bint670ss(icol,k)*deltah + dod8703d_ss(icol,k) = bint870ss(icol,k)*deltah + !DUST + dod4403d_dust(icol,k) = bint440du(icol,k)*deltah + dod5003d_dust(icol,k) = bint500du(icol,k)*deltah + dod5503d_dust(icol,k) = bint550du(icol,k)*deltah + abs5503d_dust(icol,k) = baint550du(icol,k)*deltah + dod6703d_dust(icol,k) = bint670du(icol,k)*deltah + dod8703d_dust(icol,k) = bint870du(icol,k)*deltah + !SO4 + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + dod4403d_so4(icol,k) = (besu440tot(icol,k) & ! condensate ) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5003d_so4(icol,k) = (besu500tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5503d_so4(icol,k) = (besu550tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + abs5503d_so4(icol,k) = (basu550tot(icol,k) & ! condensate ) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod6703d_so4(icol,k) = (besu670tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod8703d_so4(icol,k) = (besu870tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + !BC + vaitbcarr(icol,k) = faitbc(icol,k)/(faitbc(icol,k) & + +(1.0_r8-faitbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) + vaitbc = vaitbcarr(icol,k) + dod4403d_bc(icol,k) = (bebc440tot(icol,k)+bebc440xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg440(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5003d_bc(icol,k) = (bebc500tot(icol,k)+bebc500xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg500(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5503d_bc(icol,k) = (bebc550tot(icol,k)+bebc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + abs5503d_bc(icol,k) = (babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*babg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod6703d_bc(icol,k) = (bebc670tot(icol,k)+bebc670xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg670(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod8703d_bc(icol,k) = (bebc870tot(icol,k)+bebc870xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebg870(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) + !OC + !soa + v_soana part of mode 11 for the OC volume fraction of that mode + ! v_soana(icol,k) + dod4403d_pom(icol,k) = (beoc440tot(icol,k)+beoc440xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*bebg440(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg440(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5003d_pom(icol,k) = (beoc500tot(icol,k)+beoc500xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*bebg500(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg500(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5503d_pom(icol,k) = (beoc550tot(icol,k)+beoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*bebg550(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + abs5503d_pom(icol,k) = (baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*babg550(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*babg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod6703d_pom(icol,k) = (beoc670tot(icol,k)+beoc670xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*bebg670(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg670(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod8703d_pom(icol,k) = (beoc870tot(icol,k)+beoc870xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*bebg870(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg870(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + ec550_so4(icol,k) = 1.e-3*dod5503d_so4(icol,k)/deltah + ec550_bc(icol,k) = 1.e-3*dod5503d_bc(icol,k)/deltah + ec550_pom(icol,k) = 1.e-3*dod5503d_pom(icol,k)/deltah + ec550_ss(icol,k) = 1.e-3*dod5503d_ss(icol,k)/deltah + ec550_du(icol,k) = 1.e-3*dod5503d_dust(icol,k)/deltah + ec550_aer(icol,k) = ec550_so4(icol,k)+ec550_bc(icol,k)+ec550_pom(icol,k) & + + ec550_ss(icol,k)+ec550_du(icol,k) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! Total 3D optical depths/abs. for column integrations + dod4403d(icol,k) = dod4403d_ss(icol,k)+dod4403d_dust(icol,k) & + +dod4403d_so4(icol,k)+dod4403d_bc(icol,k) & + +dod4403d_pom(icol,k) + dod5003d(icol,k) = dod5003d_ss(icol,k)+dod5003d_dust(icol,k) & + +dod5003d_so4(icol,k)+dod5003d_bc(icol,k) & + +dod5003d_pom(icol,k) + dod5503d(icol,k) = dod5503d_ss(icol,k)+dod5503d_dust(icol,k) & + +dod5503d_so4(icol,k)+dod5503d_bc(icol,k) & + +dod5503d_pom(icol,k) + dod6703d(icol,k) = dod6703d_ss(icol,k)+dod6703d_dust(icol,k) & + +dod6703d_so4(icol,k)+dod6703d_bc(icol,k) & + +dod6703d_pom(icol,k) + dod8703d(icol,k) = dod8703d_ss(icol,k)+dod8703d_dust(icol,k) & + +dod8703d_so4(icol,k)+dod8703d_bc(icol,k) & + +dod8703d_pom(icol,k) + abs5503d(icol,k) = abs5503d_ss(icol,k)+abs5503d_dust(icol,k) & + +abs5503d_so4(icol,k)+abs5503d_bc(icol,k) & + +abs5503d_pom(icol,k) + ! (Note: Local abs550alt is up to 6% larger (annually averaged) in typical b.b. + ! regions, compared to abs550. This is most likely most correct, but should be checked!) + do i=0,10 + abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i)*deltah + abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i)*deltah + abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i)*deltah + abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i)*deltah + abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i)*deltah + enddo + do i=11,14 + abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440n(icol,k,i-10)*deltah + abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500n(icol,k,i-10)*deltah + abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670n(icol,k,i-10)*deltah + abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870n(icol,k,i-10)*deltah + abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550n(icol,k,i-10)*deltah + enddo + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! optical depths for d<1um and d>1um (r<0.5um and r>0.5um) + !SS + dod5503dlt1_ss(icol,k) = besslt1(icol,k)*deltah + dod5503dgt1_ss(icol,k) = bessgt1(icol,k)*deltah + !DUST + dod5503dlt1_dust(icol,k) = bedustlt1(icol,k)*deltah + dod5503dgt1_dust(icol,k) = bedustgt1(icol,k)*deltah + + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + dod5503dlt1_so4(icol,k) = (bes4lt1t(icol,k) & ! condensate + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebglt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5503dgt1_so4(icol,k) = (bes4gt1t(icol,k) & ! condensate + n-mode (11) + + Nnatk(icol,k,1)*bebggt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebggt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + !BC + dod5503dlt1_bc(icol,k) = (bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebglt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebglt1(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5503dgt1_bc(icol,k) = (bebcgt1t(icol,k)+bbcgt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebggt1(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebggt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebggt1(icol,k,0))*deltah ! background, BC(ax) mode (0) + !OC + !soa + v_soana part of mode 11 for the OC volume fraction of that mode + dod5503dlt1_pom(icol,k) = (beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 !-3 + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebglt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5503dgt1_pom(icol,k) = (beocgt1t(icol,k)+bocgt1xt(icol,k) & ! coagulated + n-mode OC&OC (14) - + Nnatk(icol,k,1)*bebggt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebglt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5503dgt1_pom(icol,k) = (beocgt1t(icol,k)+bocgt1xt(icol,k) & ! coagulated + n-mode OC&OC (14) + + Nnatk(icol,k,1)*bebggt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 !-3 + Nnatk(icol,k,3)*bebggt1(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebggt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! Column integrated optical depths/abs., total and for each constituent - dod440(icol) = dod440(icol)+dod4403d(icol,k) - abs440(icol) = abs440(icol)+abs4403d(icol,k) - dod500(icol) = dod500(icol)+dod5003d(icol,k) - abs500(icol) = abs500(icol)+abs5003d(icol,k) - dod550(icol) = dod550(icol)+dod5503d(icol,k) - abs550(icol) = abs550(icol)+abs5503d(icol,k) - abs550alt(icol) = abs550alt(icol)+abs5503dalt(icol,k) - dod670(icol) = dod670(icol)+dod6703d(icol,k) - abs670(icol) = abs670(icol)+abs6703d(icol,k) - dod870(icol) = dod870(icol)+dod8703d(icol,k) - abs870(icol) = abs870(icol)+abs8703d(icol,k) - ! Added abs components - abs550_ss(icol) = abs550_ss(icol)+abs5503d_ss(icol,k) - abs550_dust(icol) = abs550_dust(icol)+abs5503d_dust(icol,k) - abs550_so4(icol) = abs550_so4(icol)+abs5503d_so4(icol,k) - abs550_bc(icol) = abs550_bc(icol)+abs5503d_bc(icol,k) - abs550_pom(icol) = abs550_pom(icol)+abs5503d_pom(icol,k) - ! - dod440_ss(icol) = dod440_ss(icol)+dod4403d_ss(icol,k) - dod440_dust(icol) = dod440_dust(icol)+dod4403d_dust(icol,k) - dod440_so4(icol) = dod440_so4(icol)+dod4403d_so4(icol,k) - dod440_bc(icol) = dod440_bc(icol)+dod4403d_bc(icol,k) - dod440_pom(icol) = dod440_pom(icol)+dod4403d_pom(icol,k) - dod500_ss(icol) = dod500_ss(icol)+dod5003d_ss(icol,k) - dod500_dust(icol) = dod500_dust(icol)+dod5003d_dust(icol,k) - dod500_so4(icol) = dod500_so4(icol)+dod5003d_so4(icol,k) - dod500_bc(icol) = dod500_bc(icol)+dod5003d_bc(icol,k) - dod500_pom(icol) = dod500_pom(icol)+dod5003d_pom(icol,k) - dod550_ss(icol) = dod550_ss(icol)+dod5503d_ss(icol,k) - dod550_dust(icol) = dod550_dust(icol)+dod5503d_dust(icol,k) - dod550_so4(icol) = dod550_so4(icol)+dod5503d_so4(icol,k) - dod550_bc(icol) = dod550_bc(icol)+dod5503d_bc(icol,k) - dod550_pom(icol) = dod550_pom(icol)+dod5503d_pom(icol,k) - dod670_ss(icol) = dod670_ss(icol)+dod6703d_ss(icol,k) - dod670_dust(icol) = dod670_dust(icol)+dod6703d_dust(icol,k) - dod670_so4(icol) = dod670_so4(icol)+dod6703d_so4(icol,k) - dod670_bc(icol) = dod670_bc(icol)+dod6703d_bc(icol,k) - dod670_pom(icol) = dod670_pom(icol)+dod6703d_pom(icol,k) - dod870_ss(icol) = dod870_ss(icol)+dod8703d_ss(icol,k) - dod870_dust(icol) = dod870_dust(icol)+dod8703d_dust(icol,k) - dod870_so4(icol) = dod870_so4(icol)+dod8703d_so4(icol,k) - dod870_bc(icol) = dod870_bc(icol)+dod8703d_bc(icol,k) - dod870_pom(icol) = dod870_pom(icol)+dod8703d_pom(icol,k) - dod550lt1_ss(icol) = dod550lt1_ss(icol)+dod5503dlt1_ss(icol,k) - dod550gt1_ss(icol) = dod550gt1_ss(icol)+dod5503dgt1_ss(icol,k) - dod550lt1_dust(icol) = dod550lt1_dust(icol)+dod5503dlt1_dust(icol,k) - dod550gt1_dust(icol) = dod550gt1_dust(icol)+dod5503dgt1_dust(icol,k) - dod550lt1_so4(icol) = dod550lt1_so4(icol)+dod5503dlt1_so4(icol,k) - dod550gt1_so4(icol) = dod550gt1_so4(icol)+dod5503dgt1_so4(icol,k) - dod550lt1_bc(icol) = dod550lt1_bc(icol)+dod5503dlt1_bc(icol,k) - dod550gt1_bc(icol) = dod550gt1_bc(icol)+dod5503dgt1_bc(icol,k) - dod550lt1_pom(icol) = dod550lt1_pom(icol)+dod5503dlt1_pom(icol,k) - dod550gt1_pom(icol) = dod550gt1_pom(icol)+dod5503dgt1_pom(icol,k) - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - enddo ! k - - enddo ! icol - - ! extinction, absorption (m-1) and backscatter coefficients (m-1 sr-1) - call outfld('EC550AER',ec550_aer,pcols,lchnk) - call outfld('ABS550_A',abs550_aer,pcols,lchnk) - call outfld('BS550AER',bs550_aer,pcols,lchnk) - ! - ! speciated extinction coefficients (m-1) - call outfld('EC550SO4',ec550_so4,pcols,lchnk) - call outfld('EC550BC ',ec550_bc ,pcols,lchnk) - call outfld('EC550POM',ec550_pom,pcols,lchnk) - call outfld('EC550SS ',ec550_ss ,pcols,lchnk) - call outfld('EC550DU ',ec550_du ,pcols,lchnk) - ! - ! optical depths and absorption as requested by AeroCom - ! notation: 3=3D, D=DOD, A=ABS, LT=d<1um, GT=d>1um - call outfld('DOD440 ',dod440 ,pcols,lchnk) - call outfld('ABS440 ',abs440 ,pcols,lchnk) - call outfld('DOD500 ',dod500 ,pcols,lchnk) - call outfld('ABS500 ',abs500 ,pcols,lchnk) - call outfld('DOD550 ',dod550 ,pcols,lchnk) - call outfld('ABS550 ',abs550 ,pcols,lchnk) - call outfld('ABS550AL',abs550alt,pcols,lchnk) - call outfld('DOD670 ',dod670 ,pcols,lchnk) - call outfld('ABS670 ',abs670 ,pcols,lchnk) - call outfld('DOD870 ',dod870 ,pcols,lchnk) - call outfld('ABS870 ',abs870 ,pcols,lchnk) - call outfld('A550_SS ',abs550_ss ,pcols,lchnk) - call outfld('A550_DU ',abs550_dust,pcols,lchnk) - call outfld('A550_SO4',abs550_so4 ,pcols,lchnk) - call outfld('A550_BC ',abs550_bc ,pcols,lchnk) - call outfld('A550_POM',abs550_pom ,pcols,lchnk) - ! - call outfld('D440_SS ',dod440_ss ,pcols,lchnk) - call outfld('D440_DU ',dod440_dust,pcols,lchnk) - call outfld('D440_SO4',dod440_so4 ,pcols,lchnk) - call outfld('D440_BC ',dod440_bc ,pcols,lchnk) - call outfld('D440_POM',dod440_pom ,pcols,lchnk) - call outfld('D500_SS ',dod500_ss ,pcols,lchnk) - call outfld('D500_DU ',dod500_dust,pcols,lchnk) - call outfld('D500_SO4',dod500_so4 ,pcols,lchnk) - call outfld('D500_BC ',dod500_bc ,pcols,lchnk) - call outfld('D500_POM',dod500_pom ,pcols,lchnk) - call outfld('D550_SS ',dod550_ss ,pcols,lchnk) - call outfld('D550_DU ',dod550_dust,pcols,lchnk) - call outfld('D550_SO4',dod550_so4 ,pcols,lchnk) - call outfld('D550_BC ',dod550_bc ,pcols,lchnk) - call outfld('D550_POM',dod550_pom ,pcols,lchnk) - call outfld('D670_SS ',dod670_ss ,pcols,lchnk) - call outfld('D670_DU ',dod670_dust,pcols,lchnk) - call outfld('D670_SO4',dod670_so4 ,pcols,lchnk) - call outfld('D670_BC ',dod670_bc ,pcols,lchnk) - call outfld('D670_POM',dod670_pom ,pcols,lchnk) - call outfld('D870_SS ',dod870_ss ,pcols,lchnk) - call outfld('D870_DU ',dod870_dust,pcols,lchnk) - call outfld('D870_SO4',dod870_so4 ,pcols,lchnk) - call outfld('D870_BC ',dod870_bc ,pcols,lchnk) - call outfld('D870_POM',dod870_pom ,pcols,lchnk) - call outfld('DLT_SS ',dod550lt1_ss,pcols,lchnk) - call outfld('DGT_SS ',dod550gt1_ss,pcols,lchnk) - call outfld('DLT_DUST',dod550lt1_dust,pcols,lchnk) - call outfld('DGT_DUST',dod550gt1_dust,pcols,lchnk) - call outfld('DLT_SO4 ',dod550lt1_so4,pcols,lchnk) - call outfld('DGT_SO4 ',dod550gt1_so4,pcols,lchnk) - call outfld('DLT_BC ',dod550lt1_bc,pcols,lchnk) - call outfld('DGT_BC ',dod550gt1_bc,pcols,lchnk) - call outfld('DLT_POM ',dod550lt1_pom,pcols,lchnk) - call outfld('DGT_POM ',dod550gt1_pom,pcols,lchnk) - !tst - ! call outfld('DOD5503D',dod5503d,pcols,lchnk) - !tst - !- call outfld('ABS5503D',abs5503d,pcols,lchnk) - !- call outfld('D443_SS ',dod4403d_ss ,pcols,lchnk) - !- call outfld('D443_DU ',dod4403d_dust,pcols,lchnk) - !- call outfld('D443_SO4',dod4403d_so4 ,pcols,lchnk) - !- call outfld('D443_BC ',dod4403d_bc ,pcols,lchnk) - !- call outfld('D443_POM',dod4403d_pom ,pcols,lchnk) - !- call outfld('D503_SS ',dod5003d_ss ,pcols,lchnk) - !- call outfld('D503_DU ',dod5003d_dust,pcols,lchnk) - !- call outfld('D503_SO4',dod5003d_so4 ,pcols,lchnk) - !- call outfld('D503_BC ',dod5003d_bc ,pcols,lchnk) - !- call outfld('D503_POM',dod5003d_pom ,pcols,lchnk) - !- call outfld('D553_SS ',dod5503d_ss ,pcols,lchnk) - !- call outfld('D553_DU ',dod5503d_dust,pcols,lchnk) - !- call outfld('D553_SO4',dod5503d_so4 ,pcols,lchnk) - !- call outfld('D553_BC ',dod5503d_bc ,pcols,lchnk) - !- call outfld('D553_POM',dod5503d_pom ,pcols,lchnk) - !- call outfld('D673_SS ',dod6703d_ss ,pcols,lchnk) - !- call outfld('D673_DU ',dod6703d_dust,pcols,lchnk) - !- call outfld('D673_SO4',dod6703d_so4 ,pcols,lchnk) - !- call outfld('D673_BC ',dod6703d_bc ,pcols,lchnk) - !- call outfld('D673_POM',dod6703d_pom ,pcols,lchnk) - !- call outfld('D873_SS ',dod8703d_ss ,pcols,lchnk) - !- call outfld('D873_DU ',dod8703d_dust,pcols,lchnk) - !- call outfld('D873_SO4',dod8703d_so4 ,pcols,lchnk) - !- call outfld('D873_BC ',dod8703d_bc ,pcols,lchnk) - !- call outfld('D873_POM',dod8703d_pom ,pcols,lchnk) - - - !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - - ! Dry parameters of each aerosol component - ! BC(ax) mode - aerodry_prop%intdrypar0(lchnk, ncol, Nnatk) - - ! SO4&SOA(Ait,n) mode - aerodry_prop%intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) - - ! BC(Ait,n) and OC(Ait,n) modes - aerodry_prop%intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1) - - ! BC&OC(Ait,n) mode ------ fcm not valid here (=0). Use faitbc or fnbc instead - aerodry_prop%intdrypar4(lchnk, ncol, Nnatk, & - xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & - xct, ict1, xfac, ifac1, xfaq, ifaq1) - - ! SO4(Ait75) (5), mineral (6-7) and Sea-salt (8-10) modes: - aerodry_prop%intdrypar5to10(lchnk, ncol, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) - - do k=1,pver - do icol=1,ncol - c_ss(icol,k)=0.0_r8 - c_mi(icol,k)=0.0_r8 - enddo - enddo + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebggt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! Column integrated optical depths/abs., total and for each constituent + dod440(icol) = dod440(icol)+dod4403d(icol,k) + abs440(icol) = abs440(icol)+abs4403d(icol,k) + dod500(icol) = dod500(icol)+dod5003d(icol,k) + abs500(icol) = abs500(icol)+abs5003d(icol,k) + dod550(icol) = dod550(icol)+dod5503d(icol,k) + abs550(icol) = abs550(icol)+abs5503d(icol,k) + abs550alt(icol) = abs550alt(icol)+abs5503dalt(icol,k) + dod670(icol) = dod670(icol)+dod6703d(icol,k) + abs670(icol) = abs670(icol)+abs6703d(icol,k) + dod870(icol) = dod870(icol)+dod8703d(icol,k) + abs870(icol) = abs870(icol)+abs8703d(icol,k) + ! Added abs components + abs550_ss(icol) = abs550_ss(icol)+abs5503d_ss(icol,k) + abs550_dust(icol) = abs550_dust(icol)+abs5503d_dust(icol,k) + abs550_so4(icol) = abs550_so4(icol)+abs5503d_so4(icol,k) + abs550_bc(icol) = abs550_bc(icol)+abs5503d_bc(icol,k) + abs550_pom(icol) = abs550_pom(icol)+abs5503d_pom(icol,k) + ! + dod440_ss(icol) = dod440_ss(icol)+dod4403d_ss(icol,k) + dod440_dust(icol) = dod440_dust(icol)+dod4403d_dust(icol,k) + dod440_so4(icol) = dod440_so4(icol)+dod4403d_so4(icol,k) + dod440_bc(icol) = dod440_bc(icol)+dod4403d_bc(icol,k) + dod440_pom(icol) = dod440_pom(icol)+dod4403d_pom(icol,k) + dod500_ss(icol) = dod500_ss(icol)+dod5003d_ss(icol,k) + dod500_dust(icol) = dod500_dust(icol)+dod5003d_dust(icol,k) + dod500_so4(icol) = dod500_so4(icol)+dod5003d_so4(icol,k) + dod500_bc(icol) = dod500_bc(icol)+dod5003d_bc(icol,k) + dod500_pom(icol) = dod500_pom(icol)+dod5003d_pom(icol,k) + dod550_ss(icol) = dod550_ss(icol)+dod5503d_ss(icol,k) + dod550_dust(icol) = dod550_dust(icol)+dod5503d_dust(icol,k) + dod550_so4(icol) = dod550_so4(icol)+dod5503d_so4(icol,k) + dod550_bc(icol) = dod550_bc(icol)+dod5503d_bc(icol,k) + dod550_pom(icol) = dod550_pom(icol)+dod5503d_pom(icol,k) + dod670_ss(icol) = dod670_ss(icol)+dod6703d_ss(icol,k) + dod670_dust(icol) = dod670_dust(icol)+dod6703d_dust(icol,k) + dod670_so4(icol) = dod670_so4(icol)+dod6703d_so4(icol,k) + dod670_bc(icol) = dod670_bc(icol)+dod6703d_bc(icol,k) + dod670_pom(icol) = dod670_pom(icol)+dod6703d_pom(icol,k) + dod870_ss(icol) = dod870_ss(icol)+dod8703d_ss(icol,k) + dod870_dust(icol) = dod870_dust(icol)+dod8703d_dust(icol,k) + dod870_so4(icol) = dod870_so4(icol)+dod8703d_so4(icol,k) + dod870_bc(icol) = dod870_bc(icol)+dod8703d_bc(icol,k) + dod870_pom(icol) = dod870_pom(icol)+dod8703d_pom(icol,k) + dod550lt1_ss(icol) = dod550lt1_ss(icol)+dod5503dlt1_ss(icol,k) + dod550gt1_ss(icol) = dod550gt1_ss(icol)+dod5503dgt1_ss(icol,k) + dod550lt1_dust(icol) = dod550lt1_dust(icol)+dod5503dlt1_dust(icol,k) + dod550gt1_dust(icol) = dod550gt1_dust(icol)+dod5503dgt1_dust(icol,k) + dod550lt1_so4(icol) = dod550lt1_so4(icol)+dod5503dlt1_so4(icol,k) + dod550gt1_so4(icol) = dod550gt1_so4(icol)+dod5503dgt1_so4(icol,k) + dod550lt1_bc(icol) = dod550lt1_bc(icol)+dod5503dlt1_bc(icol,k) + dod550gt1_bc(icol) = dod550gt1_bc(icol)+dod5503dgt1_bc(icol,k) + dod550lt1_pom(icol) = dod550lt1_pom(icol)+dod5503dlt1_pom(icol,k) + dod550gt1_pom(icol) = dod550gt1_pom(icol)+dod5503dgt1_pom(icol,k) + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + enddo ! k + + enddo ! icol + + ! extinction, absorption (m-1) and backscatter coefficients (m-1 sr-1) + call outfld('EC550AER',ec550_aer,pcols,lchnk) + call outfld('ABS550_A',abs550_aer,pcols,lchnk) + call outfld('BS550AER',bs550_aer,pcols,lchnk) + ! + ! speciated extinction coefficients (m-1) + call outfld('EC550SO4',ec550_so4,pcols,lchnk) + call outfld('EC550BC ',ec550_bc ,pcols,lchnk) + call outfld('EC550POM',ec550_pom,pcols,lchnk) + call outfld('EC550SS ',ec550_ss ,pcols,lchnk) + call outfld('EC550DU ',ec550_du ,pcols,lchnk) + ! + ! optical depths and absorption as requested by AeroCom + ! notation: 3=3D, D=DOD, A=ABS, LT=d<1um, GT=d>1um + call outfld('DOD440 ',dod440 ,pcols,lchnk) + call outfld('ABS440 ',abs440 ,pcols,lchnk) + call outfld('DOD500 ',dod500 ,pcols,lchnk) + call outfld('ABS500 ',abs500 ,pcols,lchnk) + call outfld('DOD550 ',dod550 ,pcols,lchnk) + call outfld('ABS550 ',abs550 ,pcols,lchnk) + call outfld('ABS550AL',abs550alt,pcols,lchnk) + call outfld('DOD670 ',dod670 ,pcols,lchnk) + call outfld('ABS670 ',abs670 ,pcols,lchnk) + call outfld('DOD870 ',dod870 ,pcols,lchnk) + call outfld('ABS870 ',abs870 ,pcols,lchnk) + call outfld('A550_SS ',abs550_ss ,pcols,lchnk) + call outfld('A550_DU ',abs550_dust,pcols,lchnk) + call outfld('A550_SO4',abs550_so4 ,pcols,lchnk) + call outfld('A550_BC ',abs550_bc ,pcols,lchnk) + call outfld('A550_POM',abs550_pom ,pcols,lchnk) + ! + call outfld('D440_SS ',dod440_ss ,pcols,lchnk) + call outfld('D440_DU ',dod440_dust,pcols,lchnk) + call outfld('D440_SO4',dod440_so4 ,pcols,lchnk) + call outfld('D440_BC ',dod440_bc ,pcols,lchnk) + call outfld('D440_POM',dod440_pom ,pcols,lchnk) + call outfld('D500_SS ',dod500_ss ,pcols,lchnk) + call outfld('D500_DU ',dod500_dust,pcols,lchnk) + call outfld('D500_SO4',dod500_so4 ,pcols,lchnk) + call outfld('D500_BC ',dod500_bc ,pcols,lchnk) + call outfld('D500_POM',dod500_pom ,pcols,lchnk) + call outfld('D550_SS ',dod550_ss ,pcols,lchnk) + call outfld('D550_DU ',dod550_dust,pcols,lchnk) + call outfld('D550_SO4',dod550_so4 ,pcols,lchnk) + call outfld('D550_BC ',dod550_bc ,pcols,lchnk) + call outfld('D550_POM',dod550_pom ,pcols,lchnk) + call outfld('D670_SS ',dod670_ss ,pcols,lchnk) + call outfld('D670_DU ',dod670_dust,pcols,lchnk) + call outfld('D670_SO4',dod670_so4 ,pcols,lchnk) + call outfld('D670_BC ',dod670_bc ,pcols,lchnk) + call outfld('D670_POM',dod670_pom ,pcols,lchnk) + call outfld('D870_SS ',dod870_ss ,pcols,lchnk) + call outfld('D870_DU ',dod870_dust,pcols,lchnk) + call outfld('D870_SO4',dod870_so4 ,pcols,lchnk) + call outfld('D870_BC ',dod870_bc ,pcols,lchnk) + call outfld('D870_POM',dod870_pom ,pcols,lchnk) + call outfld('DLT_SS ',dod550lt1_ss,pcols,lchnk) + call outfld('DGT_SS ',dod550gt1_ss,pcols,lchnk) + call outfld('DLT_DUST',dod550lt1_dust,pcols,lchnk) + call outfld('DGT_DUST',dod550gt1_dust,pcols,lchnk) + call outfld('DLT_SO4 ',dod550lt1_so4,pcols,lchnk) + call outfld('DGT_SO4 ',dod550gt1_so4,pcols,lchnk) + call outfld('DLT_BC ',dod550lt1_bc,pcols,lchnk) + call outfld('DGT_BC ',dod550gt1_bc,pcols,lchnk) + call outfld('DLT_POM ',dod550lt1_pom,pcols,lchnk) + call outfld('DGT_POM ',dod550gt1_pom,pcols,lchnk) + !tst + ! call outfld('DOD5503D',dod5503d,pcols,lchnk) + !tst + !- call outfld('ABS5503D',abs5503d,pcols,lchnk) + !- call outfld('D443_SS ',dod4403d_ss ,pcols,lchnk) + !- call outfld('D443_DU ',dod4403d_dust,pcols,lchnk) + !- call outfld('D443_SO4',dod4403d_so4 ,pcols,lchnk) + !- call outfld('D443_BC ',dod4403d_bc ,pcols,lchnk) + !- call outfld('D443_POM',dod4403d_pom ,pcols,lchnk) + !- call outfld('D503_SS ',dod5003d_ss ,pcols,lchnk) + !- call outfld('D503_DU ',dod5003d_dust,pcols,lchnk) + !- call outfld('D503_SO4',dod5003d_so4 ,pcols,lchnk) + !- call outfld('D503_BC ',dod5003d_bc ,pcols,lchnk) + !- call outfld('D503_POM',dod5003d_pom ,pcols,lchnk) + !- call outfld('D553_SS ',dod5503d_ss ,pcols,lchnk) + !- call outfld('D553_DU ',dod5503d_dust,pcols,lchnk) + !- call outfld('D553_SO4',dod5503d_so4 ,pcols,lchnk) + !- call outfld('D553_BC ',dod5503d_bc ,pcols,lchnk) + !- call outfld('D553_POM',dod5503d_pom ,pcols,lchnk) + !- call outfld('D673_SS ',dod6703d_ss ,pcols,lchnk) + !- call outfld('D673_DU ',dod6703d_dust,pcols,lchnk) + !- call outfld('D673_SO4',dod6703d_so4 ,pcols,lchnk) + !- call outfld('D673_BC ',dod6703d_bc ,pcols,lchnk) + !- call outfld('D673_POM',dod6703d_pom ,pcols,lchnk) + !- call outfld('D873_SS ',dod8703d_ss ,pcols,lchnk) + !- call outfld('D873_DU ',dod8703d_dust,pcols,lchnk) + !- call outfld('D873_SO4',dod8703d_so4 ,pcols,lchnk) + !- call outfld('D873_BC ',dod8703d_bc ,pcols,lchnk) + !- call outfld('D873_POM',dod8703d_pom ,pcols,lchnk) + + + !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + + ! Dry parameters of each aerosol component + ! BC(ax) mode + call intdrypar0(lchnk, ncol, Nnatk, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + cknorm,cknlt05,ckngt125) + ! SO4&SOA(Ait,n) mode + call intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, & + xct, ict1, xfac, ifac1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) + ! BC(Ait,n) and OC(Ait,n) modes + call intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) + ! BC&OC(Ait,n) mode ------ fcm not valid here (=0). Use faitbc or fnbc instead + call intdrypar4(lchnk, ncol, Nnatk, & + xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & + xct, ict1, xfac, ifac1, xfaq, ifaq1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & + aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) + ! SO4(Ait75) (5), mineral (6-7) and Sea-salt (8-10) modes: + call intdrypar5to10(lchnk, ncol, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & + cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & + cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& + cknorm,cknlt05,ckngt125) - do k=1,pver - do icol=1,ncol - ! mineral and sea-salt background concentrations, internally mixed - c_mi(icol,k) = Nnatk(icol,k,6) * aerdry_prop%cintbg(icol,k,6) + & - Nnatk(icol,k,7) * aerdry_prop%cintbg(icol,k,7) - c_mi05(icol,k) = Nnatk(icol,k,6) * aerdry_prop%cintbg05(icol,k,6) + & - Nnatk(icol,k,7) * aerdry_prop%cintbg05(icol,k,7) - c_mi125(icol,k) = Nnatk(icol,k,6) * aerdry_prop%cintbg125(icol,k,6) + & - Nnatk(icol,k,7) * aerdry_prop%cintbg125(icol,k,7) - c_ss(icol,k) = Nnatk(icol,k,8) * aerdry_prop%cintbg(icol,k,8) + & - Nnatk(icol,k,9) * aerdry_prop%cintbg(icol,k,9) + & - Nnatk(icol,k,10)* aerdry_prop%cintbg(icol,k,10) - c_ss05(icol,k) = Nnatk(icol,k,8) * aerdry_prop%cintbg05(icol,k,8) + & - Nnatk(icol,k,9) * aerdry_prop%cintbg05(icol,k,9) + & - Nnatk(icol,k,10)* aerdry_prop%cintbg05(icol,k,10) - c_ss125(icol,k) = Nnatk(icol,k,8) * aerdry_prop%cintbg125(icol,k,8) + & - Nnatk(icol,k,9) * aerdry_prop%cintbg125(icol,k,9) + & - Nnatk(icol,k,10)* aerdry_prop%cintbg125(icol,k,10) - - ! internally mixed bc and oc (from coagulation) and so4 concentrations - ! (sa=so4(aq) and sc=so4(cond+coag), separated because of different density: - ! necessary for calculation of volume fractions!), and total aerosol surface - ! areas and volumes. - c_bc(icol,k) = 0.0_r8 - c_bc05(icol,k) = 0.0_r8 - c_bc125(icol,k) = 0.0_r8 - c_oc(icol,k) = 0.0_r8 - c_oc05(icol,k) = 0.0_r8 - c_oc125(icol,k) = 0.0_r8 - c_s4(icol,k) = 0.0_r8 - c_s4_a(icol,k) = 0.0_r8 - c_s4_1(icol,k) = 0.0_r8 - c_s4_5(icol,k) = 0.0_r8 - c_sa(icol,k) = 0.0_r8 - c_sa05(icol,k) = 0.0_r8 - c_sa125(icol,k) = 0.0_r8 - c_sc(icol,k) = 0.0_r8 - c_sc05(icol,k) = 0.0_r8 - c_sc125(icol,k) = 0.0_r8 - aaeros_tot(icol,k) = 0.0_r8 - aaerol_tot(icol,k) = 0.0_r8 - vaeros_tot(icol,k) = 0.0_r8 - vaerol_tot(icol,k) = 0.0_r8 - c_bc_0(icol,k) = 0.0_r8 - c_bc_2(icol,k) = 0.0_r8 - c_bc_4(icol,k) = 0.0_r8 - c_bc_12(icol,k) = 0.0_r8 - c_bc_14(icol,k) = 0.0_r8 - c_oc_4(icol,k) = 0.0_r8 - c_oc_14(icol,k) = 0.0_r8 - c_tot(icol,k) = 0.0_r8 - c_tot125(icol,k) = 0.0_r8 - c_tot05(icol,k) = 0.0_r8 - c_pm25(icol,k) = 0.0_r8 - c_pm1(icol,k) = 0.0_r8 - mmr_pm25(icol,k) = 0.0_r8 - mmr_pm1(icol,k) = 0.0_r8 - - do i=0,nbmodes - if(i.ne.3) then - c_bc(icol,k) = c_bc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc(icol,k,i) - c_bc05(icol,k) = c_bc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc05(icol,k,i) - c_bc125(icol,k) = c_bc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc125(icol,k,i) - c_oc(icol,k) = c_oc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc(icol,k,i) - c_oc05(icol,k) = c_oc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc05(icol,k,i) - c_oc125(icol,k) = c_oc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc125(icol,k,i) - c_sa(icol,k) = c_sa(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa(icol,k,i) - c_sa05(icol,k) = c_sa05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa05(icol,k,i) - c_sa125(icol,k) = c_sa125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa125(icol,k,i) - c_sc(icol,k) = c_sc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc(icol,k,i) - c_sc05(icol,k) = c_sc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc05(icol,k,i) - c_sc125(icol,k) = c_sc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc125(icol,k,i) - aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeros(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerol(icol,k,i) - vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeros(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerol(icol,k,i) - endif + do k=1,pver + do icol=1,ncol + c_ss(icol,k)=0.0_r8 + c_mi(icol,k)=0.0_r8 enddo + enddo - ! add dry aerosol area and volume of externally mixed modes - do i=nbmp1,nmodes - aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerosn(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeroln(icol,k,i) - vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerosn(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeroln(icol,k,i) - end do - - !c_er3d - ! Effective radii for particles smaller and greater than 0.5um, - ! and for all radii, in each layer (er=3*V/A): - erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) /(aaeros_tot(icol,k)+eps) - ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) /(aaerol_tot(icol,k)+eps) - er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) - !c_er3d - - ! column integrated dry aerosol surface areas and volumes - ! for r<0.5um and r>0.5um (s and l, respectively). - aaercols(icol)=aaercols(icol)+aaeros_tot(icol,k) - aaercoll(icol)=aaercoll(icol)+aaerol_tot(icol,k) - vaercols(icol)=vaercols(icol)+vaeros_tot(icol,k) - vaercoll(icol)=vaercoll(icol)+vaerol_tot(icol,k) - - ! then add background and externally mixed BC, OC and SO4 to mass concentrations - c_bc_ac(icol,k)= c_bc(icol,k) - c_bc_0(icol,k) = Nnatk(icol,k,0)*aerodry_prop%cintbg(icol,k,0) - c_bc_2(icol,k) = Nnatk(icol,k,2)*aerodry_prop%cintbg(icol,k,2) - c_bc_4(icol,k) = Nnatk(icol,k,4)*aerodry_prop%cintbg(icol,k,4)*faitbc(icol,k) - c_bc_12(icol,k)= Nnatk(icol,k,12)*aerodry_prop%cknorm(icol,k,12) - c_bc_14(icol,k)= Nnatk(icol,k,14)*aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) - c_bc(icol,k) = c_bc(icol,k) & - +Nnatk(icol,k,2)*aerodry_prop%cintbg(icol,k,2) & - +Nnatk(icol,k,4)*aerodry_prop%cintbg(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0)*aerodry_prop%cintbg(icol,k,0) & - +Nnatk(icol,k,12)*aerodry_prop%cknorm(icol,k,12) & - +Nnatk(icol,k,14)*aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) - c_bc05(icol,k) = c_bc05(icol,k) & - +Nnatk(icol,k,2)*aerodry_prop%cintbg05(icol,k,2) & - +Nnatk(icol,k,4)*aerodry_prop%cintbg05(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0)*aerodry_prop%cintbg05(icol,k,0) & - +Nnatk(icol,k,12)*aerodry_prop%cknlt05(icol,k,12) & - +Nnatk(icol,k,14)*aerodry_prop%cknlt05(icol,k,14)*fnbc(icol,k) - c_bc125(icol,k) = c_bc125(icol,k) & - +Nnatk(icol,k,2)*aerodry_prop%cintbg125(icol,k,2) & - +Nnatk(icol,k,4)*aerodry_prop%cintbg125(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0)*aerodry_prop%cintbg125(icol,k,0) & - +Nnatk(icol,k,12)*ckngt125(icol,k,12) & - +Nnatk(icol,k,14)*ckngt125(icol,k,14)*fnbc(icol,k) - c_oc_ac(icol,k)= c_oc(icol,k) - c_oc_4(icol,k) = Nnatk(icol,k,4)*aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) - c_oc_14(icol,k) = Nnatk(icol,k,14)*aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc(icol,k) = c_oc(icol,k) & - +Nnatk(icol,k,1)*aerodry_prop%cintbg(icol,k,1)*f_soana(icol,k) & - +Nnatk(icol,k,4)*aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14)*aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc05(icol,k) = c_oc05(icol,k) & - +Nnatk(icol,k,1)*aerodry_prop%cintbg05(icol,k,1)*f_soana(icol,k) & - +Nnatk(icol,k,4)*aerodry_prop%cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14)*aerodry_prop%cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc125(icol,k) = c_oc125(icol,k) & - +Nnatk(icol,k,1)*aerodry_prop%cintbg125(icol,k,1)*f_soana(icol,k) & - +Nnatk(icol,k,4)*aerodry_prop%cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14)*ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_s4(icol,k) = c_sa(icol,k)+c_sc(icol,k) & - +Nnatk(icol,k,1)*aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5)*aerodry_prop%cintbg(icol,k,5) - c_s405(icol,k) = c_sa05(icol,k)+c_sc05(icol,k) & - +Nnatk(icol,k,1)*aerodry_prop%cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5)*aerodry_prop%cintbg05(icol,k,5) - c_s4125(icol,k) = c_sa125(icol,k)+c_sc125(icol,k) & - +Nnatk(icol,k,1)*aerodry_prop%cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5)*aerodry_prop%cintbg125(icol,k,5) + do k=1,pver + do icol=1,ncol + ! mineral and sea-salt background concentrations, internally mixed + c_mi(icol,k) = Nnatk(icol,k,6)*cintbg(icol,k,6) & + +Nnatk(icol,k,7)*cintbg(icol,k,7) + c_mi05(icol,k) = Nnatk(icol,k,6)*cintbg05(icol,k,6) & + +Nnatk(icol,k,7)*cintbg05(icol,k,7) + c_mi125(icol,k) = Nnatk(icol,k,6)*cintbg125(icol,k,6)& + +Nnatk(icol,k,7)*cintbg125(icol,k,7) + c_ss(icol,k) = Nnatk(icol,k,8)*cintbg(icol,k,8) & + +Nnatk(icol,k,9)*cintbg(icol,k,9) & + +Nnatk(icol,k,10)*cintbg(icol,k,10) + c_ss05(icol,k) = Nnatk(icol,k,8)*cintbg05(icol,k,8) & + +Nnatk(icol,k,9)*cintbg05(icol,k,9) & + +Nnatk(icol,k,10)*cintbg05(icol,k,10) + c_ss125(icol,k) = Nnatk(icol,k,8)*cintbg125(icol,k,8)& + +Nnatk(icol,k,9)*cintbg125(icol,k,9) & + +Nnatk(icol,k,10)*cintbg125(icol,k,10) + ! internally mixed bc and oc (from coagulation) and so4 concentrations + ! (sa=so4(aq) and sc=so4(cond+coag), separated because of different density: + ! necessary for calculation of volume fractions!), and total aerosol surface + ! areas and volumes. + c_bc(icol,k)=0.0_r8 + c_bc05(icol,k)=0.0_r8 + c_bc125(icol,k)=0.0_r8 + c_oc(icol,k)=0.0_r8 + c_oc05(icol,k)=0.0_r8 + c_oc125(icol,k)=0.0_r8 + c_s4(icol,k)=0.0_r8 + c_s4_a(icol,k)=0.0_r8 + c_s4_1(icol,k)=0.0_r8 + c_s4_5(icol,k)=0.0_r8 + c_sa(icol,k)=0.0_r8 + c_sa05(icol,k)=0.0_r8 + c_sa125(icol,k)=0.0_r8 + c_sc(icol,k)=0.0_r8 + c_sc05(icol,k)=0.0_r8 + c_sc125(icol,k)=0.0_r8 + aaeros_tot(icol,k)=0.0_r8 + aaerol_tot(icol,k)=0.0_r8 + vaeros_tot(icol,k)=0.0_r8 + vaerol_tot(icol,k)=0.0_r8 + c_bc_0(icol,k)=0.0_r8 + c_bc_2(icol,k)=0.0_r8 + c_bc_4(icol,k)=0.0_r8 + c_bc_12(icol,k)=0.0_r8 + c_bc_14(icol,k)=0.0_r8 + c_oc_4(icol,k)=0.0_r8 + c_oc_14(icol,k)=0.0_r8 + !akc6+ + c_tot(icol,k)=0.0_r8 + c_tot125(icol,k)=0.0_r8 + c_tot05(icol,k)=0.0_r8 + c_pm25(icol,k)=0.0_r8 + c_pm1(icol,k)=0.0_r8 + mmr_pm25(icol,k)=0.0_r8 + mmr_pm1(icol,k)=0.0_r8 + !akc6- + + do i=0,nbmodes + if(i.ne.3) then + c_bc(icol,k) = c_bc(icol,k) & + +Nnatk(icol,k,i)*cintbc(icol,k,i) + c_bc05(icol,k) = c_bc05(icol,k) & + +Nnatk(icol,k,i)*cintbc05(icol,k,i) + c_bc125(icol,k) = c_bc125(icol,k) & + +Nnatk(icol,k,i)*cintbc125(icol,k,i) + c_oc(icol,k) = c_oc(icol,k) & + +Nnatk(icol,k,i)*cintoc(icol,k,i) + c_oc05(icol,k) = c_oc05(icol,k) & + +Nnatk(icol,k,i)*cintoc05(icol,k,i) + c_oc125(icol,k) = c_oc125(icol,k) & + +Nnatk(icol,k,i)*cintoc125(icol,k,i) + c_sa(icol,k) = c_sa(icol,k) & + +Nnatk(icol,k,i)*cintsa(icol,k,i) + c_sa05(icol,k) = c_sa05(icol,k) & + +Nnatk(icol,k,i)*cintsa05(icol,k,i) + c_sa125(icol,k) = c_sa125(icol,k) & + +Nnatk(icol,k,i)*cintsa125(icol,k,i) + c_sc(icol,k) = c_sc(icol,k) & + +Nnatk(icol,k,i)*cintsc(icol,k,i) + c_sc05(icol,k) = c_sc05(icol,k) & + +Nnatk(icol,k,i)*cintsc05(icol,k,i) + c_sc125(icol,k) = c_sc125(icol,k) & + +Nnatk(icol,k,i)*cintsc125(icol,k,i) + aaeros_tot(icol,k) = aaeros_tot(icol,k) & + +Nnatk(icol,k,i)*aaeros(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) & + +Nnatk(icol,k,i)*aaerol(icol,k,i) + vaeros_tot(icol,k) =vaeros_tot(icol,k) & + +Nnatk(icol,k,i)*vaeros(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) & + +Nnatk(icol,k,i)*vaerol(icol,k,i) + endif + enddo + ! add dry aerosol area and volume of externally mixed modes + do i=nbmp1,nmodes + aaeros_tot(icol,k) = aaeros_tot(icol,k) & + +Nnatk(icol,k,i)*aaerosn(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) & + +Nnatk(icol,k,i)*aaeroln(icol,k,i) + vaeros_tot(icol,k) =vaeros_tot(icol,k) & + +Nnatk(icol,k,i)*vaerosn(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) & + +Nnatk(icol,k,i)*vaeroln(icol,k,i) + end do + !c_er3d + ! Effective radii for particles smaller and greater than 0.5um, + ! and for all radii, in each layer (er=3*V/A): + erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) & + /(aaeros_tot(icol,k)+eps) + ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) & + /(aaerol_tot(icol,k)+eps) + er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) & + /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) + !c_er3d + ! column integrated dry aerosol surface areas and volumes + ! for r<0.5um and r>0.5um (s and l, respectively). + aaercols(icol)=aaercols(icol)+aaeros_tot(icol,k) + aaercoll(icol)=aaercoll(icol)+aaerol_tot(icol,k) + vaercols(icol)=vaercols(icol)+vaeros_tot(icol,k) + vaercoll(icol)=vaercoll(icol)+vaerol_tot(icol,k) + ! then add background and externally mixed BC, OC and SO4 to mass concentrations + c_bc_ac(icol,k)= c_bc(icol,k) + c_bc_0(icol,k) = Nnatk(icol,k,0)*cintbg(icol,k,0) + c_bc_2(icol,k) = Nnatk(icol,k,2)*cintbg(icol,k,2) + c_bc_4(icol,k) = Nnatk(icol,k,4)*cintbg(icol,k,4)*faitbc(icol,k) + c_bc_12(icol,k)= Nnatk(icol,k,12)*cknorm(icol,k,12) + c_bc_14(icol,k)= Nnatk(icol,k,14)*cknorm(icol,k,14)*fnbc(icol,k) + c_bc(icol,k) = c_bc(icol,k) & + +Nnatk(icol,k,2)*cintbg(icol,k,2) & + +Nnatk(icol,k,4)*cintbg(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0)*cintbg(icol,k,0) & + +Nnatk(icol,k,12)*cknorm(icol,k,12) & + +Nnatk(icol,k,14)*cknorm(icol,k,14)*fnbc(icol,k) + c_bc05(icol,k) = c_bc05(icol,k) & + +Nnatk(icol,k,2)*cintbg05(icol,k,2) & + +Nnatk(icol,k,4)*cintbg05(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0)*cintbg05(icol,k,0) & + +Nnatk(icol,k,12)*cknlt05(icol,k,12) & + +Nnatk(icol,k,14)*cknlt05(icol,k,14)*fnbc(icol,k) + c_bc125(icol,k) = c_bc125(icol,k) & + +Nnatk(icol,k,2)*cintbg125(icol,k,2) & + +Nnatk(icol,k,4)*cintbg125(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0)*cintbg125(icol,k,0) & + +Nnatk(icol,k,12)*ckngt125(icol,k,12) & + +Nnatk(icol,k,14)*ckngt125(icol,k,14)*fnbc(icol,k) + c_oc_ac(icol,k)= c_oc(icol,k) + c_oc_4(icol,k) = Nnatk(icol,k,4)*cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) + c_oc_14(icol,k) = Nnatk(icol,k,14)*cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc(icol,k) = c_oc(icol,k) & + +Nnatk(icol,k,1)*cintbg(icol,k,1)*f_soana(icol,k) & + !-3 +Nnatk(icol,k,3)*cintbg(icol,k,3) & + +Nnatk(icol,k,4)*cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14)*cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc05(icol,k) = c_oc05(icol,k) & + +Nnatk(icol,k,1)*cintbg05(icol,k,1)*f_soana(icol,k) & + !-3 +Nnatk(icol,k,3)*cintbg05(icol,k,3) & + +Nnatk(icol,k,4)*cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14)*cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc125(icol,k) = c_oc125(icol,k) & + +Nnatk(icol,k,1)*cintbg125(icol,k,1)*f_soana(icol,k) & + !-3 +Nnatk(icol,k,3)*cintbg125(icol,k,3) & + +Nnatk(icol,k,4)*cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14)*ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_s4(icol,k) = c_sa(icol,k)+c_sc(icol,k) & + +Nnatk(icol,k,1)*cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5)*cintbg(icol,k,5) + c_s405(icol,k) = c_sa05(icol,k)+c_sc05(icol,k) & + +Nnatk(icol,k,1)*cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5)*cintbg05(icol,k,5) + c_s4125(icol,k) = c_sa125(icol,k)+c_sc125(icol,k) & + +Nnatk(icol,k,1)*cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5)*cintbg125(icol,k,5) + + !akc6+ + c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) & + + c_mi(icol,k) + c_ss(icol,k) + c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) & + + c_mi125(icol,k) + c_ss125(icol,k) + c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) & + + c_mi05(icol,k) + c_ss05(icol,k) + c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) + c_pm1(icol,k) = c_tot05(icol,k) + ! mass mixing ratio: + mmr_pm25(icol,k) = 1.e-9*c_pm25(icol,k)/rhoda(icol,k) + mmr_pm1(icol,k) = 1.e-9*c_pm1(icol,k)/rhoda(icol,k) + !akc6- + + ! converting from S to SO4 concentrations is no longer necessary, since + ! sc=H2SO4 and sa=(NH4)2SO4 now, not SO4 as in CAM4-Oslo + ! c_s4(icol,k)=c_s4(icol,k)/3._r8 + ! c_s405(icol,k)=c_s405(icol,k)/3._r8 + ! c_s4125(icol,k)=c_s4125(icol,k)/3._r8 + + c_s4_a(icol,k) = c_sa(icol,k)+c_sc(icol,k) + c_s4_1(icol,k) = Nnatk(icol,k,1)*cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) + c_s4_5(icol,k) = Nnatk(icol,k,5)*cintbg05(icol,k,5) + + end do ! icol + enddo ! k + ! Total PM and PM2.5 (dry r>1.25um), surface values (ug/m3) + do icol=1,ncol + ! c_tots(icol) = c_s4(icol,pver) + c_oc(icol,pver) + c_bc(icol,pver) & + ! + c_mi(icol,pver) + c_ss(icol,pver) + ! c_tot125s(icol) = c_s4125(icol,pver) + c_oc125(icol,pver) + c_bc125(icol,pver) & + ! + c_mi125(icol,pver) + c_ss125(icol,pver) + ! c_pm25s(icol) = c_tots(icol) - c_tot125s(icol) !akc6+ - c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) + c_mi(icol,k) + c_ss(icol,k) - c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) + c_mi125(icol,k) + c_ss125(icol,k) - c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) + c_mi05(icol,k) + c_ss05(icol,k) - c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) - c_pm1(icol,k) = c_tot05(icol,k) - ! mass mixing ratio: - mmr_pm25(icol,k) = 1.e-9*c_pm25(icol,k)/rhoda(icol,k) - mmr_pm1(icol,k) = 1.e-9*c_pm1(icol,k)/rhoda(icol,k) + c_tots(icol) = c_tot(icol,pver) + c_tot125s(icol) = c_tot125(icol,pver) + c_pm25s(icol) = c_pm25(icol,pver) !akc6- + enddo - ! converting from S to SO4 concentrations is no longer necessary, since - ! sc=H2SO4 and sa=(NH4)2SO4 now, not SO4 as in CAM4-Oslo - ! c_s4(icol,k)=c_s4(icol,k)/3._r8 - ! c_s405(icol,k)=c_s405(icol,k)/3._r8 - ! c_s4125(icol,k)=c_s4125(icol,k)/3._r8 - - c_s4_a(icol,k) = c_sa(icol,k)+c_sc(icol,k) - c_s4_1(icol,k) = Nnatk(icol,k,1)*aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) - c_s4_5(icol,k) = Nnatk(icol,k,5)*aerodry_prop%cintbg05(icol,k,5) - - end do ! icol - enddo ! k + ! Effective, column integrated, radii for particles + ! smaller and greater than 0.5um, and for all radii + do icol=1,ncol + derlt05(icol)=3.0_r8*vaercols(icol)/(aaercols(icol)+eps) + dergt05(icol)=3.0_r8*vaercoll(icol)/(aaercoll(icol)+eps) + der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) & + /(aaercols(icol)+aaercoll(icol)+eps) + enddo - ! Total PM and PM2.5 (dry r>1.25um), surface values (ug/m3) - do icol=1,ncol - ! c_tots(icol) = c_s4(icol,pver) + c_oc(icol,pver) + c_bc(icol,pver) & - ! + c_mi(icol,pver) + c_ss(icol,pver) - ! c_tot125s(icol) = c_s4125(icol,pver) + c_oc125(icol,pver) + c_bc125(icol,pver) & - ! + c_mi125(icol,pver) + c_ss125(icol,pver) - ! c_pm25s(icol) = c_tots(icol) - c_tot125s(icol) + do icol=1,ncol + dload_s4(icol)=0.0_r8 + dload_s4_a(icol)=0.0_r8 + dload_s4_1(icol)=0.0_r8 + dload_s4_5(icol)=0.0_r8 + dload_oc(icol)=0.0_r8 + dload_bc(icol)=0.0_r8 + dload_bc_ac(icol)=0.0_r8 + dload_bc_0(icol)=0.0_r8 + dload_bc_2(icol)=0.0_r8 + dload_bc_4(icol)=0.0_r8 + dload_bc_12(icol)=0.0_r8 + dload_bc_14(icol)=0.0_r8 + dload_oc_ac(icol)=0.0_r8 + dload_oc_4(icol)=0.0_r8 + dload_oc_14(icol)=0.0_r8 + do k=1,pver + ! Layer thickness, unit km + !- deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) + deltah=deltah_km(icol,k) + ! Modal and total mass concentrations for clean and dry aerosol, + ! i.e. not including coag./cond./Aq. BC,OC,SO4 or condensed water. + ! Units: ug/m3 for concentrations and mg/m2 (--> kg/m2 later) for mass loading. + do i=0,nmodes + ck(icol,k,i)=cknorm(icol,k,i)*Nnatk(icol,k,i) + dload3d(icol,k,i)=ck(icol,k,i)*deltah + dload(icol,i)=dload(icol,i)+dload3d(icol,k,i) + enddo + nnat_0(icol,k) =Nnatk(icol,k,0) + nnat_1(icol,k) =Nnatk(icol,k,1) + nnat_2(icol,k) =Nnatk(icol,k,2) + nnat_4(icol,k) =Nnatk(icol,k,4) + nnat_5(icol,k) =Nnatk(icol,k,5) + nnat_6(icol,k) =Nnatk(icol,k,6) + nnat_7(icol,k) =Nnatk(icol,k,7) + nnat_8(icol,k) =Nnatk(icol,k,8) + nnat_9(icol,k) =Nnatk(icol,k,9) + nnat_10(icol,k)=Nnatk(icol,k,10) + nnat_12(icol,k)=Nnatk(icol,k,12) + nnat_14(icol,k)=Nnatk(icol,k,14) + ! mineral and sea-salt mass concentrations + cmin(icol,k)=ck(icol,k,6)+ck(icol,k,7) + cseas(icol,k)=ck(icol,k,8)+ck(icol,k,9)+ck(icol,k,10) + ! Aerocom: Condensed water loading (mg_m2) + daerh2o(icol)=daerh2o(icol)+Cwater(icol,k)*deltah + ! just for checking purposes: + dload_s4(icol)=dload_s4(icol)+c_s4(icol,k)*deltah + dload_s4_a(icol)=dload_s4_a(icol)+c_s4_a(icol,k)*deltah + dload_s4_1(icol)=dload_s4_1(icol)+c_s4_1(icol,k)*deltah + dload_s4_5(icol)=dload_s4_5(icol)+c_s4_5(icol,k)*deltah + dload_oc(icol)=dload_oc(icol)+c_oc(icol,k)*deltah + dload_bc(icol)=dload_bc(icol)+c_bc(icol,k)*deltah + ! + dload_bc_ac(icol)=dload_bc_ac(icol)+c_bc_ac(icol,k)*deltah + dload_bc_0(icol)=dload_bc_0(icol)+c_bc_0(icol,k)*deltah + dload_bc_2(icol)=dload_bc_2(icol)+c_bc_2(icol,k)*deltah + dload_bc_4(icol)=dload_bc_4(icol)+c_bc_4(icol,k)*deltah + dload_bc_12(icol)=dload_bc_12(icol)+c_bc_12(icol,k)*deltah + dload_bc_14(icol)=dload_bc_14(icol)+c_bc_14(icol,k)*deltah + dload_oc_ac(icol)=dload_oc_ac(icol)+c_oc_ac(icol,k)*deltah + dload_oc_4(icol)=dload_oc_4(icol)+c_oc_4(icol,k)*deltah + dload_oc_14(icol)=dload_oc_14(icol)+c_oc_14(icol,k)*deltah + ! + end do ! k + dload_mi(icol)=dload(icol,6)+dload(icol,7) + dload_ss(icol)=dload(icol,8)+dload(icol,9)+dload(icol,10) + end do ! icol + + ! Internally and externally mixed dry concentrations (ug/m3) of + ! SO4, BC and OC, for all r, r<0.5um and r>1.25um... + ! call outfld('C_BCPM ',c_bc ,pcols,lchnk) + ! call outfld('C_BC05 ',c_bc05 ,pcols,lchnk) + ! call outfld('C_BC125 ',c_bc125,pcols,lchnk) + ! call outfld('C_OCPM ',c_oc ,pcols,lchnk) + ! call outfld('C_OC05 ',c_oc05 ,pcols,lchnk) + ! call outfld('C_OC125 ',c_oc125,pcols,lchnk) + ! call outfld('C_S4PM ',c_s4 ,pcols,lchnk) + ! call outfld('C_S405 ',c_s405 ,pcols,lchnk) + ! call outfld('C_S4125 ',c_s4125,pcols,lchnk) + ! ... and of background components for all r, r<0.5um and r>1.25um + ! call outfld('C_MIPM ',c_mi ,pcols,lchnk) + ! call outfld('C_MI05 ',c_mi05 ,pcols,lchnk) + ! call outfld('C_MI125 ',c_mi125,pcols,lchnk) + ! call outfld('C_SSPM ',c_ss ,pcols,lchnk) + ! call outfld('C_SS05 ',c_ss05 ,pcols,lchnk) + ! call outfld('C_SS125 ',c_ss125,pcols,lchnk) + call outfld('PMTOT ',c_tots ,pcols,lchnk) + call outfld('PM25 ',c_pm25s ,pcols,lchnk) !akc6+ - c_tots(icol) = c_tot(icol,pver) - c_tot125s(icol) = c_tot125(icol,pver) - c_pm25s(icol) = c_pm25(icol,pver) + call outfld('PM2P5 ',c_pm25 ,pcols,lchnk) + call outfld('MMRPM2P5',mmr_pm25,pcols,lchnk) + call outfld('MMRPM1 ',mmr_pm1 ,pcols,lchnk) + call outfld('MMRPM2P5_SRF',mmr_pm25(:pcols,pver),pcols,lchnk) !akc6- - enddo - - ! Effective, column integrated, radii for particles - ! smaller and greater than 0.5um, and for all radii - do icol=1,ncol - derlt05(icol)=3.0_r8*vaercols(icol)/(aaercols(icol)+eps) - dergt05(icol)=3.0_r8*vaercoll(icol)/(aaercoll(icol)+eps) - der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) / (aaercols(icol)+aaercoll(icol)+eps) - enddo - - do icol=1,ncol - dload_s4(icol)=0.0_r8 - dload_s4_a(icol)=0.0_r8 - dload_s4_1(icol)=0.0_r8 - dload_s4_5(icol)=0.0_r8 - dload_oc(icol)=0.0_r8 - dload_bc(icol)=0.0_r8 - dload_bc_ac(icol)=0.0_r8 - dload_bc_0(icol)=0.0_r8 - dload_bc_2(icol)=0.0_r8 - dload_bc_4(icol)=0.0_r8 - dload_bc_12(icol)=0.0_r8 - dload_bc_14(icol)=0.0_r8 - dload_oc_ac(icol)=0.0_r8 - dload_oc_4(icol)=0.0_r8 - dload_oc_14(icol)=0.0_r8 - do k=1,pver - ! Layer thickness, unit km - !- deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) - deltah=deltah_km(icol,k) - ! Modal and total mass concentrations for clean and dry aerosol, - ! i.e. not including coag./cond./Aq. BC,OC,SO4 or condensed water. - ! Units: ug/m3 for concentrations and mg/m2 (--> kg/m2 later) for mass loading. - do i=0,nmodes - ck(icol,k,i)=aerodry_prop%cknorm(icol,k,i)*Nnatk(icol,k,i) - dload3d(icol,k,i)=ck(icol,k,i)*deltah - dload(icol,i)=dload(icol,i)+dload3d(icol,k,i) - enddo - nnat_0(icol,k) =Nnatk(icol,k,0) - nnat_1(icol,k) =Nnatk(icol,k,1) - nnat_2(icol,k) =Nnatk(icol,k,2) - nnat_4(icol,k) =Nnatk(icol,k,4) - nnat_5(icol,k) =Nnatk(icol,k,5) - nnat_6(icol,k) =Nnatk(icol,k,6) - nnat_7(icol,k) =Nnatk(icol,k,7) - nnat_8(icol,k) =Nnatk(icol,k,8) - nnat_9(icol,k) =Nnatk(icol,k,9) - nnat_10(icol,k)=Nnatk(icol,k,10) - nnat_12(icol,k)=Nnatk(icol,k,12) - nnat_14(icol,k)=Nnatk(icol,k,14) - ! mineral and sea-salt mass concentrations - cmin(icol,k)=ck(icol,k,6)+ck(icol,k,7) - cseas(icol,k)=ck(icol,k,8)+ck(icol,k,9)+ck(icol,k,10) - ! Aerocom: Condensed water loading (mg_m2) - daerh2o(icol)=daerh2o(icol)+Cwater(icol,k)*deltah - ! just for checking purposes: - dload_s4(icol)=dload_s4(icol)+c_s4(icol,k)*deltah - dload_s4_a(icol)=dload_s4_a(icol)+c_s4_a(icol,k)*deltah - dload_s4_1(icol)=dload_s4_1(icol)+c_s4_1(icol,k)*deltah - dload_s4_5(icol)=dload_s4_5(icol)+c_s4_5(icol,k)*deltah - dload_oc(icol)=dload_oc(icol)+c_oc(icol,k)*deltah - dload_bc(icol)=dload_bc(icol)+c_bc(icol,k)*deltah - ! - dload_bc_ac(icol)=dload_bc_ac(icol)+c_bc_ac(icol,k)*deltah - dload_bc_0(icol)=dload_bc_0(icol)+c_bc_0(icol,k)*deltah - dload_bc_2(icol)=dload_bc_2(icol)+c_bc_2(icol,k)*deltah - dload_bc_4(icol)=dload_bc_4(icol)+c_bc_4(icol,k)*deltah - dload_bc_12(icol)=dload_bc_12(icol)+c_bc_12(icol,k)*deltah - dload_bc_14(icol)=dload_bc_14(icol)+c_bc_14(icol,k)*deltah - dload_oc_ac(icol)=dload_oc_ac(icol)+c_oc_ac(icol,k)*deltah - dload_oc_4(icol)=dload_oc_4(icol)+c_oc_4(icol,k)*deltah - dload_oc_14(icol)=dload_oc_14(icol)+c_oc_14(icol,k)*deltah - ! - end do ! k - dload_mi(icol)=dload(icol,6)+dload(icol,7) - dload_ss(icol)=dload(icol,8)+dload(icol,9)+dload(icol,10) - end do ! icol - -#ifdef COLTST4INTCONS - ! Testing column burdens for internal consistency between intdrypar* - ! (use of aerodryk*.out look-up tables) and calculations directly - ! from the qm1 array. Will only work with #define AEROCOM. - ! - call coltst4intcons (lchnk, ncol, qm1, deltah_km, rhoda, fnbc, & - dload_mi, dload_ss, dload_s4, dload_oc, dload_bc, & - dload_bc_0, dload_bc_2, dload_bc_4, dload_bc_12, dload_bc_14, dload_bc_ac, & - dload_oc_4, dload_oc_14, dload_oc_ac, dload_s4_a, dload_s4_1, dload_s4_5) - ! -#ifdef AEROCOM - call outfld('CMDRY0 ',cmdry0 ,pcols,lchnk) - call outfld('CMDRY1 ',cmdry1 ,pcols,lchnk) - call outfld('CMDRY2 ',cmdry2 ,pcols,lchnk) - call outfld('CMDRY4 ',cmdry4 ,pcols,lchnk) - call outfld('CMDRY5 ',cmdry5 ,pcols,lchnk) - call outfld('CMDRY6 ',cmdry6 ,pcols,lchnk) - call outfld('CMDRY7 ',cmdry7 ,pcols,lchnk) - call outfld('CMDRY8 ',cmdry8 ,pcols,lchnk) - call outfld('CMDRY9 ',cmdry9 ,pcols,lchnk) - call outfld('CMDRY10 ',cmdry10 ,pcols,lchnk) - call outfld('CMDRY12 ',cmdry12 ,pcols,lchnk) - call outfld('CMDRY14 ',cmdry14 ,pcols,lchnk) -#endif -#endif ! COLTST4INTCONS - - ! Internally and externally mixed dry concentrations (ug/m3) of - ! SO4, BC and OC, for all r, r<0.5um and r>1.25um... - ! call outfld('C_BCPM ',c_bc ,pcols,lchnk) - ! call outfld('C_BC05 ',c_bc05 ,pcols,lchnk) - ! call outfld('C_BC125 ',c_bc125,pcols,lchnk) - ! call outfld('C_OCPM ',c_oc ,pcols,lchnk) - ! call outfld('C_OC05 ',c_oc05 ,pcols,lchnk) - ! call outfld('C_OC125 ',c_oc125,pcols,lchnk) - ! call outfld('C_S4PM ',c_s4 ,pcols,lchnk) - ! call outfld('C_S405 ',c_s405 ,pcols,lchnk) - ! call outfld('C_S4125 ',c_s4125,pcols,lchnk) - ! ... and of background components for all r, r<0.5um and r>1.25um - ! call outfld('C_MIPM ',c_mi ,pcols,lchnk) - ! call outfld('C_MI05 ',c_mi05 ,pcols,lchnk) - ! call outfld('C_MI125 ',c_mi125,pcols,lchnk) - ! call outfld('C_SSPM ',c_ss ,pcols,lchnk) - ! call outfld('C_SS05 ',c_ss05 ,pcols,lchnk) - ! call outfld('C_SS125 ',c_ss125,pcols,lchnk) - call outfld('PMTOT ',c_tots ,pcols,lchnk) - call outfld('PM25 ',c_pm25s ,pcols,lchnk) - !akc6+ - call outfld('PM2P5 ',c_pm25 ,pcols,lchnk) - call outfld('MMRPM2P5',mmr_pm25,pcols,lchnk) - call outfld('MMRPM1 ',mmr_pm1 ,pcols,lchnk) - call outfld('MMRPM2P5_SRF',mmr_pm25(:pcols,pver),pcols,lchnk) - !akc6- - ! total (all r) dry concentrations (ug/m3) and loadings (mg/m2) - call outfld('DLOAD_MI',dload_mi,pcols,lchnk) - call outfld('DLOAD_SS',dload_ss,pcols,lchnk) - call outfld('DLOAD_S4',dload_s4,pcols,lchnk) - call outfld('DLOAD_OC',dload_oc,pcols,lchnk) - call outfld('DLOAD_BC',dload_bc,pcols,lchnk) - - call outfld('LOADBCAC',dload_bc_ac,pcols,lchnk) - call outfld('LOADBC0 ',dload_bc_0,pcols,lchnk) - call outfld('LOADBC2 ',dload_bc_2,pcols,lchnk) - call outfld('LOADBC4 ',dload_bc_4,pcols,lchnk) - call outfld('LOADBC12',dload_bc_12,pcols,lchnk) - call outfld('LOADBC14',dload_bc_14,pcols,lchnk) - call outfld('LOADOCAC',dload_oc_ac,pcols,lchnk) - call outfld('LOADOC4 ',dload_oc_4,pcols,lchnk) - call outfld('LOADOC14',dload_oc_14,pcols,lchnk) - ! condensed water mmr (kg/kg) - call outfld('MMR_AH2O',mmr_aerh2o,pcols,lchnk) - ! condensed water loading (mg/m2) - call outfld('DAERH2O ',daerh2o ,pcols,lchnk) - ! number concentrations (1/cm3) - call outfld('NNAT_0 ',nnat_0 ,pcols,lchnk) - call outfld('NNAT_1 ',nnat_1 ,pcols,lchnk) - call outfld('NNAT_2 ',nnat_2 ,pcols,lchnk) - !=0 call outfld('NNAT_3 ',nnat_3 ,pcols,lchnk) - call outfld('NNAT_4 ',nnat_4 ,pcols,lchnk) - call outfld('NNAT_5 ',nnat_5 ,pcols,lchnk) - call outfld('NNAT_6 ',nnat_6 ,pcols,lchnk) - call outfld('NNAT_7 ',nnat_7 ,pcols,lchnk) - call outfld('NNAT_8 ',nnat_8 ,pcols,lchnk) - call outfld('NNAT_9 ',nnat_9 ,pcols,lchnk) - call outfld('NNAT_10 ',nnat_10,pcols,lchnk) - !=0 call outfld('NNAT_11 ',nnat_11,pcols,lchnk) - call outfld('NNAT_12 ',nnat_12,pcols,lchnk) - !=0 call outfld('NNAT_13 ',nnat_13,pcols,lchnk) - call outfld('NNAT_14 ',nnat_14,pcols,lchnk) - !akc6 call outfld('AIRMASSL',airmassl,pcols,lchnk) - call outfld('AIRMASSL',airmassl,pcols,lchnk) - call outfld('AIRMASS ',airmass,pcols,lchnk) !akc6 - - !c_er3d - ! effective dry radii (um) in each layer - ! call outfld('ERLT053D',erlt053d,pcols,lchnk) - ! call outfld('ERGT053D',ergt053d,pcols,lchnk) - ! call outfld('ER3D ',er3d ,pcols,lchnk) - !c_er3d - ! column integrated effective dry radii (um) - call outfld('DERLT05 ',derlt05,pcols,lchnk) - call outfld('DERGT05 ',dergt05,pcols,lchnk) - call outfld('DER ',der ,pcols,lchnk) - ! - - !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 + ! total (all r) dry concentrations (ug/m3) and loadings (mg/m2) + call outfld('DLOAD_MI',dload_mi,pcols,lchnk) + call outfld('DLOAD_SS',dload_ss,pcols,lchnk) + call outfld('DLOAD_S4',dload_s4,pcols,lchnk) + call outfld('DLOAD_OC',dload_oc,pcols,lchnk) + call outfld('DLOAD_BC',dload_bc,pcols,lchnk) + + call outfld('LOADBCAC',dload_bc_ac,pcols,lchnk) + call outfld('LOADBC0 ',dload_bc_0,pcols,lchnk) + call outfld('LOADBC2 ',dload_bc_2,pcols,lchnk) + call outfld('LOADBC4 ',dload_bc_4,pcols,lchnk) + call outfld('LOADBC12',dload_bc_12,pcols,lchnk) + call outfld('LOADBC14',dload_bc_14,pcols,lchnk) + call outfld('LOADOCAC',dload_oc_ac,pcols,lchnk) + call outfld('LOADOC4 ',dload_oc_4,pcols,lchnk) + call outfld('LOADOC14',dload_oc_14,pcols,lchnk) + ! condensed water mmr (kg/kg) + call outfld('MMR_AH2O',mmr_aerh2o,pcols,lchnk) + ! condensed water loading (mg/m2) + call outfld('DAERH2O ',daerh2o ,pcols,lchnk) + ! number concentrations (1/cm3) + call outfld('NNAT_0 ',nnat_0 ,pcols,lchnk) + call outfld('NNAT_1 ',nnat_1 ,pcols,lchnk) + call outfld('NNAT_2 ',nnat_2 ,pcols,lchnk) + !=0 call outfld('NNAT_3 ',nnat_3 ,pcols,lchnk) + call outfld('NNAT_4 ',nnat_4 ,pcols,lchnk) + call outfld('NNAT_5 ',nnat_5 ,pcols,lchnk) + call outfld('NNAT_6 ',nnat_6 ,pcols,lchnk) + call outfld('NNAT_7 ',nnat_7 ,pcols,lchnk) + call outfld('NNAT_8 ',nnat_8 ,pcols,lchnk) + call outfld('NNAT_9 ',nnat_9 ,pcols,lchnk) + call outfld('NNAT_10 ',nnat_10,pcols,lchnk) + !=0 call outfld('NNAT_11 ',nnat_11,pcols,lchnk) + call outfld('NNAT_12 ',nnat_12,pcols,lchnk) + !=0 call outfld('NNAT_13 ',nnat_13,pcols,lchnk) + call outfld('NNAT_14 ',nnat_14,pcols,lchnk) + !akc6 call outfld('AIRMASSL',airmassl,pcols,lchnk) + call outfld('AIRMASSL',airmassl,pcols,lchnk) + call outfld('AIRMASS ',airmass,pcols,lchnk) !akc6 + + !c_er3d + ! effective dry radii (um) in each layer + ! call outfld('ERLT053D',erlt053d,pcols,lchnk) + ! call outfld('ERGT053D',ergt053d,pcols,lchnk) + ! call outfld('ER3D ',er3d ,pcols,lchnk) + !c_er3d + ! column integrated effective dry radii (um) + call outfld('DERLT05 ',derlt05,pcols,lchnk) + call outfld('DERGT05 ',dergt05,pcols,lchnk) + call outfld('DER ',der ,pcols,lchnk) + ! - ! Extra AeroCom diagnostics requiring table look-ups with RH = constant + ! Extra AeroCom diagnostics requiring table look-ups with RH = constant #ifdef AEROCOM_INSITU - irfmax=6 + irfmax=6 #else - irfmax=1 + irfmax=1 #endif ! AEROCOM_INSITU - ! Note: using xrhnull etc as proxy for constant RH input values (see opttab.F90) - do irf=1,irfmax - do k=1,pver - do icol=1,ncol - xrhnull(icol,k)=xrhrf(irf) - irh1null(icol,k)=irhrf1(irf) - end do - enddo - call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrhnull, irh1null, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) - end do ! irf - - !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - + ! Note: using xrhnull etc as proxy for constant RH input values (see opttab.F90) + do irf=1,irfmax + do k=1,pver + do icol=1,ncol + xrhnull(icol,k)=xrhrf(irf) + irh1null(icol,k)=irhrf1(irf) + end do + enddo + call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrhnull, irh1null, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) + end do ! irf + end if ! ***********AEROCOM***********AEROCOM**************AEROCOM***************above - return end subroutine pmxsub end module pmxsub_mod From 1b7d057da515dd78b7fb06d947756497a755af39 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 15 Aug 2023 14:34:29 +0200 Subject: [PATCH 05/71] changes that compiled and ran - bfb still tbd --- src/NorESM/cam_diagnostics.F90 | 361 +------ src/NorESM/phys_control.F90 | 4 +- src/NorESM/physpkg.F90 | 279 +++--- src/chemistry/oslo_aero/aero_model.F90 | 32 +- src/chemistry/oslo_aero/intlog.F90 | 491 ++++++++++ src/chemistry/oslo_aero/intlog1to3.F90 | 137 --- src/chemistry/oslo_aero/intlog4.F90 | 171 ---- src/chemistry/oslo_aero/intlog5to10.F90 | 203 ---- src/chemistry/oslo_aero/parmix_progncdnc.F90 | 4 +- src/physics/cam_oslo/aerodry_mod.F90 | 195 ++-- src/physics/cam_oslo/aeroopt_mod.F90 | 294 +++--- src/physics/cam_oslo/lininterpol_mod.F90 | 141 +++ src/physics/cam_oslo/opticsAtConstRh.F90 | 76 +- src/physics/cam_oslo/optinterpol.F90 | 21 +- src/physics/cam_oslo/opttab.F90 | 82 +- src/physics/cam_oslo/pmxsub.F90 | 906 ++++++++---------- .../cam_oslo/preprocessorDefinitions.h | 4 - src/physics/cam_oslo/radiation.F90 | 494 ++-------- src/physics/cam_oslo/radlw.F90 | 22 - src/physics/cam_oslo/radsw.F90 | 56 +- 20 files changed, 1559 insertions(+), 2414 deletions(-) create mode 100644 src/chemistry/oslo_aero/intlog.F90 delete mode 100644 src/chemistry/oslo_aero/intlog1to3.F90 delete mode 100644 src/chemistry/oslo_aero/intlog4.F90 delete mode 100644 src/chemistry/oslo_aero/intlog5to10.F90 create mode 100644 src/physics/cam_oslo/lininterpol_mod.F90 delete mode 100644 src/physics/cam_oslo/preprocessorDefinitions.h diff --git a/src/NorESM/cam_diagnostics.F90 b/src/NorESM/cam_diagnostics.F90 index e8dff42def..7259c19979 100644 --- a/src/NorESM/cam_diagnostics.F90 +++ b/src/NorESM/cam_diagnostics.F90 @@ -4,10 +4,6 @@ module cam_diagnostics ! Module to compute a variety of diagnostics quantities for history files !--------------------------------------------------------------------------------- -#ifdef OSLO_AERO -#include -#endif - use shr_kind_mod, only: r8 => shr_kind_r8 use camsrfexch, only: cam_in_t, cam_out_t use cam_control_mod, only: moist_physics @@ -27,13 +23,10 @@ module cam_diagnostics use scamMod, only: single_column, wfld use cam_abortutils, only: endrun -#ifdef OSLO_AERO use opttab, only: RF -#endif implicit none private -save ! Public interfaces @@ -113,6 +106,12 @@ module cam_diagnostics integer :: trefmxav_idx = -1, trefmnav_idx = -1 +#ifdef AEROCOM +logical :: do_aerocom = .true. +#else +logical :: do_aerocom = .false. +#endif + contains !============================================================================== @@ -184,12 +183,7 @@ subroutine diag_init_dry(pbuf2d) use physics_buffer, only: pbuf_set_field use tidal_diag, only: tidal_diag_init !+ -#ifdef AEROCOM use commondefinitions, only: nbmodes -!#ifdef RFMIPIRF -! use radconstants, only: nswbands, nlwbands -!#endif -#endif !- type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) @@ -201,17 +195,11 @@ subroutine diag_init_dry(pbuf2d) !AL integer :: ierr -!+ -#ifdef AEROCOM +!+ AEROCOM beg character(len=10) :: modeString character(len=20) :: varname integer :: i, irh -!#ifdef RFMIPIRF -! character(len=2) :: c2 -! integer :: ib -!#endif -#endif -!- +!+ AEROCOM end ! outfld calls in diag_phys_writeout call addfld (cnst_name(1), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(1)) @@ -327,82 +315,21 @@ subroutine diag_init_dry(pbuf2d) call addfld ('ATMEINT', horiz_only, 'A', 'J/m2','Vertically integrated total atmospheric energy ') -!akc6+ CNVCLD is zero... -! call addfld ('CNVCLD', horiz_only, 'A', 'fraction', 'Vertically integrated convective cloud cover') -!akc6- - - -#ifdef OSLO_AERO - -#ifdef DIRIND call addfld ('AOD_VIS ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um call addfld ('ABSVIS ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um - call addfld ('AODVVOLC ',horiz_only, 'A','unitless','CMIP6 volcanic aerosol optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um - call addfld ('ABSVVOLC ',horiz_only, 'A','unitless','CMIP6 volcanic aerosol absorptive optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um + call addfld ('AODVVOLC ',horiz_only, 'A','unitless','CMIP6 volcanic aerosol optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um + call addfld ('ABSVVOLC ',horiz_only, 'A','unitless','CMIP6 volcanic aerosol absorptive optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um call addfld ('CAODVIS ',horiz_only, 'A','unitless','Clear air aerosol optical depth') call addfld ('CABSVIS ',horiz_only, 'A','unitless','Clear air aerosol absorptive optical depth') call addfld ('CLDFREE ',horiz_only, 'A','unitless','Cloud free fraction wrt CAODVIS and CABSVIS') call addfld ('DAYFOC ',horiz_only, 'A','unitless','Daylight fraction') call addfld ('N_AER ',(/'lev'/), 'A', 'unitless','Aerosol number concentration') -!- call addfld ('N_AERORG','unitless',pver, 'A','Aerosol number concentration',phys_decomp) call addfld ('SSAVIS ',(/'lev'/), 'A','unitless','Aerosol single scattering albedo in visible wavelength band') call addfld ('ASYMMVIS',(/'lev'/), 'A','unitless','Aerosol assymetry factor in visible wavelength band') call addfld ('EXTVIS ',(/'lev'/), 'A','1/km ','Aerosol extinction') -!=0 call addfld ('RELH ',(/'lev'/), 'A', 'unitless','Fictive relative humidity') -!akc6+ - call addfld ('BVISVOLC ',(/'lev'/), 'A','1/km ','CMIP6 volcanic aerosol extinction at 0.442-0.625um') -!akc6- -!#ifdef SPAERO -! call addfld ('AODVISSP',horiz_only, 'A','unitless' ,'Simple plumes aerosol optical depth at 0.35-0.64um') -! call addfld ('ABSVISSP',horiz_only, 'A','unitless' ,'Simple plumes aerosol absorptive optical depth at 0.35-0.64um') -! call addfld ('XCDNC_SP',horiz_only, 'A','unitless' ,'CDNC modification factor for simple plume aerosols') -! call addfld ('AODV3DSP',(/'lev'/), 'A','unitless','Simple plumes 3D aerosol optical depth at 0.35-0.64um') -! call addfld ('ABSV3DSP',(/'lev'/), 'A','unitless','Simple plumes 3D absorption AOD at 0.35-0.64um') -!#endif -#ifdef COLTST4INTCONS -! optical depth for each mode/mixture: - call addfld ('TAUKC0 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 0') - call addfld ('TAUKC1 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 1') - call addfld ('TAUKC2 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 2') - call addfld ('TAUKC4 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 4') - call addfld ('TAUKC5 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 5') - call addfld ('TAUKC6 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 6') - call addfld ('TAUKC7 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 7') - call addfld ('TAUKC8 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 8') - call addfld ('TAUKC9 ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 9') - call addfld ('TAUKC10',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 10') - call addfld ('TAUKC12',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 12') - call addfld ('TAUKC14',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um for kcomp 14') -! mass specific extinction (including condensed water) for each mode/mixture: - call addfld ('MECKC0 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 0') - call addfld ('MECKC1 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 1') - call addfld ('MECKC2 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 2') - call addfld ('MECKC4 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 4') - call addfld ('MECKC5 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 5') - call addfld ('MECKC6 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 6') - call addfld ('MECKC7 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 7') - call addfld ('MECKC8 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 8') - call addfld ('MECKC9 ',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 9') - call addfld ('MECKC10',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 10') - call addfld ('MECKC12',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 12') - call addfld ('MECKC14',(/'lev'/), 'A','m2/g','Aerosol MEC at 0.442-0.625um for kcomp 14') -#ifdef AEROCOM -! dry mass for each mode/mixture (for calculation of specific extinction without condensed water): - call addfld ('CMDRY0 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 0') - call addfld ('CMDRY1 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 1') - call addfld ('CMDRY2 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 2') - call addfld ('CMDRY4 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 4') - call addfld ('CMDRY5 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 5') - call addfld ('CMDRY6 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 6') - call addfld ('CMDRY7 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 7') - call addfld ('CMDRY8 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 8') - call addfld ('CMDRY9 ',horiz_only, 'A','unitless','Total dry mass load for kcomp 9') - call addfld ('CMDRY10',horiz_only, 'A','unitless','Total dry mass load for kcomp 10') - call addfld ('CMDRY12',horiz_only, 'A','unitless','Total dry mass load for kcomp 12') - call addfld ('CMDRY14',horiz_only, 'A','unitless','Total dry mass load for kcomp 14') -#endif !aerocom -#endif !extra tests -#ifdef AEROFFL + call addfld ('BVISVOLC ',(/'lev'/), 'A','1/km ','CMIP6 volcanic aerosol extinction at 0.442-0.625um') + + ! AEROFFL start call addfld ('FSNT_DRF',horiz_only, 'A','W/m^2','Total column absorbed solar flux (DIRind)') call addfld ('FSNTCDRF',horiz_only, 'A','W/m^2','Clear sky total column absorbed solar flux (DIRind)' ) call addfld ('FSNS_DRF',horiz_only, 'A','W/m^2 ','Surface absorbed solar flux (DIRind)' ) @@ -416,18 +343,16 @@ subroutine diag_init_dry(pbuf2d) call addfld ('FSUS_DRF',horiz_only, 'A','W/m^2 ','SW upwelling flux at surface') call addfld ('FSDSCDRF',horiz_only, 'A','W/m^2 ','SW downwelling clear sky flux at surface') call addfld ('FLUS ',horiz_only, 'A','W/m^2 ','LW surface upwelling flux') -!->ut call addfld ('FLNT_ORG',horiz_only, 'A','W/m^2 ','Total column longwave flux (CAM5)' ) -#endif ! aeroffl -#ifdef AEROCOM + ! AEROFFL end + + if (do_aerocom) then call addfld ('AKCXS ',horiz_only, 'A','mg/m2 ','Scheme excess aerosol mass burden') call addfld ('PMTOT ',horiz_only, 'A','ug/m3 ','Aerosol PM, all sizes') call addfld ('PM25 ',horiz_only, 'A','ug/m3 ','Aerosol PM2.5') -!akc6+ call addfld ('PM2P5 ',(/'lev'/), 'A','ug/m3 ','3D aerosol PM2.5') call addfld ('MMRPM2P5',(/'lev'/), 'A','kg/kg ','3D aerosol PM2.5 mass mixing ratio') call addfld ('MMRPM1 ',(/'lev'/), 'A','kg/kg ','3D aerosol PM1.0 mass mixing ratio') call addfld ('MMRPM2P5_SRF',horiz_only, 'A','kg/kg ','Aerosol PM2.5 mass mixing ratio in bottom layer') -!akc6- call addfld ('GRIDAREA',horiz_only, 'A','m2 ','Grid area for 1.9x2.5 horizontal resolution') call addfld ('DAERH2O ',horiz_only, 'A', 'mg/m2 ','Aerosol water load') call addfld ('MMR_AH2O',(/'lev'/), 'A', 'kg/kg ','Aerosol water mmr') @@ -454,10 +379,6 @@ subroutine diag_init_dry(pbuf2d) call addfld ('DOD500 ',horiz_only, 'A', 'unitless','Aerosol optical depth at 500nm') call addfld ('ABS500 ',horiz_only, 'A', 'unitless','Aerosol absorptive optical depth at 500nm') call addfld ('DOD550 ',horiz_only, 'A','unitless','Aerosol optical depth at 550nm') -!tst -! call addfld ('DOD5503D',(/'lev'/),'A','unitless','3D aerosol optical depth at 550 nm') -! call addfld ('AODVIS3D',(/'lev'/),'A','unitless','3D aerosol optical depth in visible wavelength band') -!tst call addfld ('ABS550 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 550nm') call addfld ('ABS550AL',horiz_only, 'A','unitless','Alt. aerosol absorptive optical depth at 550nm') call addfld ('DOD670 ',horiz_only, 'A','unitless','Aerosol optical depth at 670nm') @@ -481,21 +402,6 @@ subroutine diag_init_dry(pbuf2d) call addfld ('LOADOC4 ',horiz_only, 'A','mg/m2 ','OC aerosol mode 4 load') call addfld ('LOADOC13',horiz_only, 'A','mg/m2 ','OC aerosol mode 13 load') call addfld ('LOADOC14',horiz_only, 'A','mg/m2 ','OC aerosol mode 14 load') -#ifdef COLTST4INTCONS - call addfld ('COLRBC0 ',horiz_only, 'A','unitless','COLRAT BC mode 0 load ratio') - call addfld ('COLRBC2 ',horiz_only, 'A','unitless','COLRAT BC mode 2 load ratio') - call addfld ('COLRBC4 ',horiz_only, 'A','unitless','COLRAT BC mode 4 load ratio') - call addfld ('COLRBC12',horiz_only, 'A','unitless','COLRAT BC mode 12 load ratio') - call addfld ('COLRBC14',horiz_only, 'A','unitless','COLRAT BC mode 14 load ratio') - call addfld ('COLRBCAC',horiz_only, 'A','unitless','COLRAT BC mode AC load ratio') - call addfld ('COLROC4 ',horiz_only, 'A','unitless','COLRAT OC mode 4 load ratio') - call addfld ('COLROC14',horiz_only, 'A','unitless','COLRAT OC mode 14 load ratio') - call addfld ('COLROCAC',horiz_only, 'A','unitless','COLRAT OC mode AC load ratio') - call addfld ('COLRSULA',horiz_only, 'A','unitless','COLRAT Sulfate mode A load ratio') - call addfld ('COLRSUL1',horiz_only, 'A','unitless','COLRAT Sulfate mode 1 load ratio') - call addfld ('COLRSUL5',horiz_only, 'A','unitless','COLRAT Sulfate mode 5 load ratio') -#endif ! COLTST4INTCONS - ! call addfld ('EC550AER',(/'lev'/),'A','m-1 ','aerosol extinction coefficient') call addfld ('ABS550_A',(/'lev'/),'A','m-1 ','aerosol absorption coefficient') @@ -565,13 +471,11 @@ subroutine diag_init_dry(pbuf2d) call addfld ('NNAT_10 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 10 number concentration') call addfld ('NNAT_12 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 12 number concentration') call addfld ('NNAT_14 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 14 number concentration') -!ak call addfld ('AIRMASS ',(/'lev'/),'A','kg/m3 ','Layer airmass') call addfld ('AIRMASSL',(/'lev'/),'A','kg/m2 ','Layer airmass') call addfld ('BETOTVIS',(/'lev'/),'A','1/km','Aerosol 3d extinction at 0.442-0.625') ! CAM4-Oslo: 0.35-0.64um call addfld ('BATOTVIS',(/'lev'/),'A','1/km','Aerosol 3d absorption at 0.442-0.625') ! CAM4-Oslo: 0.35-0.64um call addfld ('BATSW13 ',(/'lev'/),'A','1/km','Aerosol 3d SW absorption at 3.077-3.846um') call addfld ('BATLW01 ',(/'lev'/),'A','1/km','Aerosol 3d LW absorption depth at 3.077-3.846um') -!akc6 call addfld ('AERLWA01',(/'lev'/),'A','unitless','CAM5 3d LW absorptive optical depth at 3.077-3.846um') !+ do i=1,nbmodes modeString=" " @@ -588,55 +492,7 @@ subroutine diag_init_dry(pbuf2d) if(i.ne.3) call addfld(varName, horiz_only, 'A', 'unitless', 'relative exessive added mass column for mode'//modeString) enddo -!#ifdef RFMIPIRF -! do ib=1,nswbands -! write(c2,'(I2)') ib -! call addfld('AERTAUBND'//trim(adjustl(c2)), (/'lev'/),'A', 'unitless', 'aerosol extinction optical depth for wavelength band '//trim(adjustl(c2))) -! call addfld('AERSSABND'//trim(adjustl(c2)), (/'lev'/),'A', 'unitless', 'aerosol single scattering albedo for wavelength band '//c2) -! call addfld('AERASYBND'//trim(adjustl(c2)), (/'lev'/),'A', 'unitless', 'aerosol asymmetry parameter for wavelength band '//c2) -! -! call addfld('SDBND'//trim(adjustl(c2)), (/'ilev'/),'A', 'W/m^2', 'shortwave spectral flux down for wavelength band '//c2) -! call addfld('SUBND'//trim(adjustl(c2)), (/'ilev'/),'A', 'W/m^2', 'shortwave spectral flux up for wavelength band '//c2) -! enddo -! do ib=1,nlwbands -! write(c2,'(I2)') ib -! call addfld('LDBND'//trim(adjustl(c2)), (/'ilev'/),'A', 'W/m^2', 'longwave spectral flux down for wavelength band '//c2) -! call addfld('LUBND'//trim(adjustl(c2)), (/'ilev'/),'A', 'W/m^2', 'longwave spectral flux up for wavelength band '//c2) -! enddo -!#endif - -#ifdef AEROCOM_INSITU ! Note that this code has not yet been updated to CESM2 standard - - do i=2,6 - - irh=RF(i) - modeString=" " - write(modeString,"(I2)"),irh - if(RF(i).eq.0) modeString="00" - -!- varName = "EC44RH"//trim(modeString) -!- call addfld(varName, 'unitless', pver, 'A', '3D EC440 at RH ='//modeString//'%', phys_decomp) - varName = "EC55RH"//trim(modeString) - call addfld(varName, 'unitless', pver, 'A', '3D EC550 at RH ='//modeString//'%', phys_decomp) -!- varName = "EC87RH"//trim(modeString) -!- call addfld(varName, 'unitless', pver, 'A', '3D EC870 at RH ='//modeString//'%', phys_decomp) - -!- varName = "AB44RH"//trim(modeString) -!- call addfld(varName, 'unitless', pver, 'A', '3D ABS440 at RH ='//modeString//'%', phys_decomp) - varName = "AB55RH"//trim(modeString) - call addfld(varName, 'unitless', pver, 'A', '3D ABS550 at RH ='//modeString//'%', phys_decomp) -!- varName = "AB87RH"//trim(modeString) -!- call addfld(varName, 'unitless', pver, 'A', '3D ABS870 at RH ='//modeString//'%', phys_decomp) - - enddo - -#endif ! AEROCOM_INSITU - -#endif ! aerocom -#endif ! dirind - -#endif ! OSLO_AERO - + end if if (history_amwg) then call add_default ('PHIS ' , 1, ' ') @@ -773,7 +629,6 @@ subroutine diag_init_dry(pbuf2d) call addfld ('MO_pAM', horiz_only, 'A', 'kg*m2/s*rad2',& 'Total column mass axial angular momentum after dry mass correction') -#ifdef DIRIND call add_default ('AOD_VIS ', 1, ' ') call add_default ('ABSVIS ', 1, ' ') call add_default ('AODVVOLC', 1, ' ') @@ -783,63 +638,11 @@ subroutine diag_init_dry(pbuf2d) call add_default ('CABSVIS ', 1, ' ') call add_default ('CLDFREE ', 1, ' ') call add_default ('N_AER ', 1, ' ') -#ifdef COLTST4INTCONS - call add_default ('TAUKC0 ', 1, ' ') - call add_default ('TAUKC1 ', 1, ' ') - call add_default ('TAUKC2 ', 1, ' ') - call add_default ('TAUKC4 ', 1, ' ') - call add_default ('TAUKC5 ', 1, ' ') - call add_default ('TAUKC6 ', 1, ' ') - call add_default ('TAUKC7 ', 1, ' ') - call add_default ('TAUKC8 ', 1, ' ') - call add_default ('TAUKC9 ', 1, ' ') - call add_default ('TAUKC10', 1, ' ') - call add_default ('TAUKC12', 1, ' ') - call add_default ('TAUKC14', 1, ' ') -! - call add_default ('MECKC0 ', 1, ' ') - call add_default ('MECKC1 ', 1, ' ') - call add_default ('MECKC2 ', 1, ' ') - call add_default ('MECKC4 ', 1, ' ') - call add_default ('MECKC5 ', 1, ' ') - call add_default ('MECKC6 ', 1, ' ') - call add_default ('MECKC7 ', 1, ' ') - call add_default ('MECKC8 ', 1, ' ') - call add_default ('MECKC9 ', 1, ' ') - call add_default ('MECKC10', 1, ' ') - call add_default ('MECKC12', 1, ' ') - call add_default ('MECKC14', 1, ' ') -#ifdef AEROCOM - call add_default ('CMDRY0 ', 1, ' ') - call add_default ('CMDRY1 ', 1, ' ') - call add_default ('CMDRY2 ', 1, ' ') - call add_default ('CMDRY4 ', 1, ' ') - call add_default ('CMDRY5 ', 1, ' ') - call add_default ('CMDRY6 ', 1, ' ') - call add_default ('CMDRY7 ', 1, ' ') - call add_default ('CMDRY8 ', 1, ' ') - call add_default ('CMDRY9 ', 1, ' ') - call add_default ('CMDRY10', 1, ' ') - call add_default ('CMDRY12', 1, ' ') - call add_default ('CMDRY14', 1, ' ') -#endif -#endif !- call add_default ('N_AERORG', 1, ' ') call add_default ('SSAVIS ', 1, ' ') call add_default ('ASYMMVIS', 1, ' ') call add_default ('EXTVIS ', 1, ' ') -!=0 call add_default ('RELH ', 1, ' ') -!akc6+ call add_default ('BVISVOLC', 1, ' ') -!akc6- -!#ifdef SPAERO -! call add_default ('AODVISSP', 1, ' ') -! call add_default ('ABSVISSP', 1, ' ') -! call add_default ('XCDNC_SP', 1, ' ') -! call add_default ('AODV3DSP', 1, ' ') -! call add_default ('ABSV3DSP', 1, ' ') -!#endif -#ifdef AEROFFL call add_default ('FSNT_DRF', 1, ' ') call add_default ('FSNTCDRF', 1, ' ') call add_default ('FSNS_DRF', 1, ' ') @@ -853,17 +656,13 @@ subroutine diag_init_dry(pbuf2d) call add_default ('FSUS_DRF', 1, ' ') call add_default ('FSDSCDRF', 1, ' ') call add_default ('FLUS ', 1, ' ') -!->ut call add_default ('FLNT_ORG', 1, ' ') -#endif ! aeroffl -#ifdef AEROCOM + if (do_aerocom) then call add_default ('AKCXS ', 1, ' ') call add_default ('PMTOT ', 1, ' ') call add_default ('PM25 ', 1, ' ') -!akc6+ call add_default ('PM2P5 ', 1, ' ') call add_default ('MMRPM2P5', 1, ' ') call add_default ('MMRPM1 ', 1, ' ') -!akc6- call add_default ('GRIDAREA', 1, ' ') call add_default ('DAERH2O ', 1, ' ') call add_default ('MMR_AH2O', 1, ' ') @@ -890,10 +689,6 @@ subroutine diag_init_dry(pbuf2d) call add_default ('DOD500 ', 1, ' ') call add_default ('ABS500 ', 1, ' ') call add_default ('DOD550 ', 1, ' ') -!tst -! call add_default ('DOD5503D', 1, ' ') -! call add_default ('AODVIS3D', 1, ' ') -!tst call add_default ('ABS550 ', 1, ' ') call add_default ('ABS550AL', 1, ' ') call add_default ('DOD670 ', 1, ' ') @@ -914,20 +709,6 @@ subroutine diag_init_dry(pbuf2d) call add_default ('LOADOCAC', 1, ' ') call add_default ('LOADOC4 ', 1, ' ') call add_default ('LOADOC14', 1, ' ') -#ifdef COLTST4INTCONS - call add_default ('COLRBC0 ', 1, ' ') - call add_default ('COLRBC2 ', 1, ' ') - call add_default ('COLRBC4 ', 1, ' ') - call add_default ('COLRBC12', 1, ' ') - call add_default ('COLRBC14', 1, ' ') - call add_default ('COLRBCAC', 1, ' ') - call add_default ('COLROC4 ', 1, ' ') - call add_default ('COLROC14', 1, ' ') - call add_default ('COLROCAC', 1, ' ') - call add_default ('COLRSULA', 1, ' ') - call add_default ('COLRSUL1', 1, ' ') - call add_default ('COLRSUL5', 1, ' ') -#endif ! COLTST4INTCONS ! call add_default ('EC550AER', 1, ' ') call add_default ('ABS550_A', 1, ' ') @@ -1002,8 +783,6 @@ subroutine diag_init_dry(pbuf2d) call add_default ('BATOTVIS', 1, ' ') call add_default ('BATSW13 ', 1, ' ') call add_default ('BATLW01 ', 1, ' ') -!akc6 call add_default ('AERLWA01', 1, ' ') -!+ do i=1,nbmodes modeString=" " write(modeString,"(I2)"),i @@ -1018,85 +797,9 @@ subroutine diag_init_dry(pbuf2d) varName = "Cxsrel"//trim(modeString) if(i.ne.3) call add_default(varName, 1, ' ') enddo -!++ - -!#ifdef RFMIPIRF -! do i=1,nbands -! do ib=1,nswbands -! write(c2,'(I2)') ib -! call add_default('AERTAUBND'//trim(adjustl(c2)), 1, ' ') -! call add_default('AERSSABND'//trim(adjustl(c2)), 1, ' ') -! call add_default('AERASYBND'//trim(adjustl(c2)), 1, ' ') -! -! call add_default('SDBND'//trim(adjustl(c2)), 1, ' ') -! call add_default('SUBND'//trim(adjustl(c2)), 1, ' ') -! enddo -! do ib=1,nlwbands -! write(c2,'(I2)') ib -! call add_default('LDBND'//trim(adjustl(c2)), 1, ' ') -! call add_default('LUBND'//trim(adjustl(c2)), 1, ' ') -! enddo -!#endif - - -#ifdef AEROCOM_INSITU - - do i=2,6 - - irh=RF(i) - modeString=" " - write(modeString,"(I2)"),irh - if(RF(i).eq.0) modeString="00" - -!- varName = "EC44RH"//trim(modeString) -!- call add_default(varName, 1, ' ') - varName = "EC55RH"//trim(modeString) - call add_default(varName, 1, ' ') -!- varName = "EC87RH"//trim(modeString) -!- call add_default(varName, 1, ' ') - -!- varName = "AB44RH"//trim(modeString) -!- call add_default(varName, 1, ' ') - varName = "AB55RH"//trim(modeString) - call add_default(varName, 1, ' ') -!- varName = "AB87RH"//trim(modeString) -!- call add_default(varName, 1, ' ') - - enddo - -#endif ! AEROCOM_INSITU - !-- !- -#endif ! aerocom -#endif ! dirind - -!#ifdef SPAERO -! call addfld ('FSNT_SP ', horiz_only, 'A','W/m^2','Total column absorbed solar flux (without SP aerosols)') -! call addfld ('FSNTC_SP', horiz_only, 'A','W/m^2','Clear sky total column absorbed solar flux (without SP aerosols)') -! call addfld ('FSNS_SP ', horiz_only, 'A','W/m^2','Surface absorbed solar flux (without SP aerosols)') -! call addfld ('FSNSC_SP', horiz_only, 'A','W/m^2','Clear sky surface absorbed solar flux (without SP aerosols)') -! call addfld ('FSNT_SP2', horiz_only, 'A','W/m^2','Total column absorbed solar flux (SP aerosols for DRF only)') -! call addfld ('FSNTCSP2', horiz_only, 'A','W/m^2','Clear sky total column absorbed solar flux (SP aerosols for DRF only)') -! call addfld ('FSNS_SP2', horiz_only, 'A','W/m^2','Surface absorbed solar flux (SP aerosols for DRF only)') -! call addfld ('FSNSCSP2', horiz_only, 'A','W/m^2','Clear sky surface absorbed solar flux (SP aerosols for DRF only)') -! call addfld ('FSNT_SP3', horiz_only, 'A','W/m^2','Total column absorbed solar flux (SP aerosols)') -! call addfld ('FSNTCSP3', horiz_only, 'A','W/m^2','Clear sky total column absorbed solar flux (SP aerosols)') -! call addfld ('FSNS_SP3', horiz_only, 'A','W/m^2','Surface absorbed solar flux (SP aerosols)') -! call addfld ('FSNSCSP3', horiz_only, 'A','W/m^2','Clear sky surface absorbed solar flux (SP aerosols)') -! call add_default ('FSNT_SP' , 1, ' ') -! call add_default ('FSNTC_SP', 1, ' ') -! call add_default ('FSNS_SP' , 1, ' ') -! call add_default ('FSNSC_SP', 1, ' ') -! call add_default ('FSNT_SP2', 1, ' ') -! call add_default ('FSNTCSP2', 1, ' ') -! call add_default ('FSNS_SP2', 1, ' ') -! call add_default ('FSNSCSP2', 1, ' ') -! call add_default ('FSNT_SP3', 1, ' ') -! call add_default ('FSNTCSP3', 1, ' ') -! call add_default ('FSNS_SP3', 1, ' ') -! call add_default ('FSNSCSP3', 1, ' ') -!#endif + end if end subroutine diag_init_dry @@ -1281,9 +984,9 @@ subroutine diag_init_moist(pbuf2d) call addfld('a2x_DSTWET4', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin4)') call addfld('a2x_DSTDRY4', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin4)') -#ifdef AEROCOM - call add_default ('RHW ', 1, ' ') -#endif ! aerocom + if (do_aerocom) then + call add_default ('RHW ', 1, ' ') + end if ! defaults if (history_amwg) then @@ -2053,25 +1756,25 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) call outfld ('RELHUM ',ftem ,pcols ,lchnk ) end if -#ifdef AEROCOM + if (do_aerocom) then ! We want RHW output always when AEROCOM is on (not only if added to a namelist) ! RH w.r.t liquid (water) call qsat_water (state%t(:ncol,:), state%pmid(:ncol,:), & esl(:ncol,:), ftem(:ncol,:)) ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 call outfld ('RHW ',ftem ,pcols ,lchnk ) -#endif + end if if (hist_fld_active('RHW') .or. hist_fld_active('RHI') .or. hist_fld_active('RHCFMIP') ) then -#ifndef AEROCOM - ! RH w.r.t liquid (water) - call qsat_water (state%t(:ncol,:), state%pmid(:ncol,:), & - esl(:ncol,:), ftem(:ncol,:)) - ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 - call outfld ('RHW ',ftem ,pcols ,lchnk ) -#endif AEROCOM - + if (.not. do_aerocom) then + ! RH w.r.t liquid (water) + call qsat_water (state%t(:ncol,:), state%pmid(:ncol,:), & + esl(:ncol,:), ftem(:ncol,:)) + ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 + call outfld ('RHW ',ftem ,pcols ,lchnk ) + end if + ! Convert to RHI (ice) do i=1,ncol do k=1,pver diff --git a/src/NorESM/phys_control.F90 b/src/NorESM/phys_control.F90 index 06efcdde10..b4ed1199f9 100644 --- a/src/NorESM/phys_control.F90 +++ b/src/NorESM/phys_control.F90 @@ -237,9 +237,9 @@ subroutine phys_ctl_readnl(nlfile) ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. prog_modal_aero = index(cam_chempkg,'_mam')>0 -#ifdef OSLO_AERO + ! OSLO_AERO beg prog_modal_aero = .FALSE. -#endif + ! OSLO_AERO end end subroutine phys_ctl_readnl !=============================================================================== diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index b54289dd68..b535292ee9 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -11,8 +11,6 @@ module physpkg ! Nov 2010 A. Gettelman Put micro/macro physics into separate routines !----------------------------------------------------------------------- -#include - use shr_kind_mod, only: r8 => shr_kind_r8 use spmd_utils, only: masterproc use physconst, only: latvap, latice, rh2o @@ -88,6 +86,12 @@ module physpkg integer :: snow_sh_idx = 0 integer :: dlfzm_idx = 0 ! detrained convective cloud water mixing ratio. +#ifdef AEROCOM +logical :: do_aerocom = .true. +#else +logical :: do_aerocom = .false. +#endif + !======================================================================= contains !======================================================================= @@ -1728,10 +1732,10 @@ subroutine tphysbc (ztodt, state, & use subcol_utils, only: subcol_ptend_copy, is_subcol_on use qneg_module, only: qneg3 -#ifdef OSLO_AERO + ! OSLO_AERO beg use commondefinitions use aerosoldef !, only: nmodes -#endif + ! OSLO_AERO end implicit none @@ -1780,9 +1784,8 @@ subroutine tphysbc (ztodt, state, & ! for macro/micro co-substepping integer :: macmic_it ! iteration variables real(r8) :: cld_macmic_ztodt ! modified timestep -#ifdef OSLO_AERO - integer kcomp ! mode number (1-14) -#endif + + integer kcomp ! mode number (1-14) oslo_aero ! physics buffer fields to compute tendencies for stratiform package integer itim_old, ifld @@ -1844,52 +1847,52 @@ subroutine tphysbc (ztodt, state, & logical :: lq(pcnst) -#ifdef AEROCOM - real(r8) :: logsig3d(pcols,pver,nmodes) ! Log (log10) of standard deviation for lognormal modes, method 2. - real(r8) :: rnew3d(pcols,pver,nmodes) ! New modal radius from look-up tables, method 2. - real(r8) :: logsig1(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 1, method 2. - real(r8) :: rnew1(pcols,pver) ! New modal radius, mode 1, from look-up tables, method 2. - real(r8) :: logsig2(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 2, method 2. - real(r8) :: rnew2(pcols,pver) ! New modal radius, mode 2, from look-up tables, method 2. - real(r8) :: logsig4(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 4, method 2. - real(r8) :: rnew4(pcols,pver) ! New modal radius, mode 4, from look-up tables, method 2. - real(r8) :: logsig5(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 5, method 2. - real(r8) :: rnew5(pcols,pver) ! New modal radius, mode 5, from look-up tables, method 2. - real(r8) :: logsig6(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 6, method 2. - real(r8) :: rnew6(pcols,pver) ! New modal radius, mode 6, from look-up tables, method 2. - real(r8) :: logsig7(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 7, method 2. - real(r8) :: rnew7(pcols,pver) ! New modal radius, mode 7, from look-up tables, method 2. - real(r8) :: logsig8(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 8, method 2. - real(r8) :: rnew8(pcols,pver) ! New modal radius, mode 8, from look-up tables, method 2. - real(r8) :: logsig9(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 9, method 2. - real(r8) :: rnew9(pcols,pver) ! New modal radius, mode 9, from look-up tables, method 2. - real(r8) :: logsig10(pcols,pver)! Log (log10) of standard deviation for lognormal modes 10, method 2. - real(r8) :: rnew10(pcols,pver) ! New modal radius, mode 10, from look-up tables, method 2. - real(r8) :: logsig11(pcols,pver)! Log (log10) of standard deviation for lognormal modes 11, method 2. - real(r8) :: rnew11(pcols,pver) ! New modal radius, mode 11, from look-up tables, method 2. - real(r8) :: logsig13(pcols,pver)! Log (log10) of standard deviation for lognormal modes 13, method 2. - real(r8) :: rnew13(pcols,pver) ! New modal radius, mode 13, from look-up tables, method 2. - real(r8) :: logsig14(pcols,pver)! Log (log10) of standard deviation for lognormal modes 14, method 2. - real(r8) :: rnew14(pcols,pver) ! New modal radius, mode 14, from look-up tables, method 2. - real(r8) :: rnewdry1(pcols,pver) ! New dry modal radius, mode 1, from look-up tables, method 2. - real(r8) :: rnewdry2(pcols,pver) ! New dry modal radius, mode 2, from look-up tables, method 2. - real(r8) :: rnewdry4(pcols,pver) ! New dry modal radius, mode 4, from look-up tables, method 2. - real(r8) :: rnewdry5(pcols,pver) ! New dry modal radius, mode 5, from look-up tables, method 2. - real(r8) :: rnewdry6(pcols,pver) ! New dry modal radius, mode 6, from look-up tables, method 2. - real(r8) :: rnewdry7(pcols,pver) ! New dry modal radius, mode 7, from look-up tables, method 2. - real(r8) :: rnewdry8(pcols,pver) ! New dry modal radius, mode 8, from look-up tables, method 2. - real(r8) :: rnewdry9(pcols,pver) ! New dry modal radius, mode 9, from look-up tables, method 2. - real(r8) :: rnewdry10(pcols,pver) ! New dry modal radius, mode 10, from look-up tables, method 2. - real(r8) :: rnewdry11(pcols,pver) ! New dry modal radius, mode 11, from look-up tables, method 2. - real(r8) :: rnewdry13(pcols,pver) ! New dry modal radius, mode 13, from look-up tables, method 2. - real(r8) :: rnewdry14(pcols,pver) ! New dry modal radius, mode 14, from look-up tables, method 2. - real(r8) :: relhum(pcols,pver) ! Ambient relative humidity (fraction) - real(r8) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate - real(r8) :: v3insol(pcols,pver,nmodes)! Modal mass fraction of BC and dust - real(r8) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) - real(r8) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt - real(r8) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor -#endif ! aerocom + ! OSLO_AERO beg + real(r8) :: logsig3d(pcols,pver,nmodes) ! Log (log10) of standard deviation for lognormal modes, method 2. + real(r8) :: rnew3d(pcols,pver,nmodes) ! New modal radius from look-up tables, method 2. + real(r8) :: logsig1(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 1, method 2. + real(r8) :: rnew1(pcols,pver) ! New modal radius, mode 1, from look-up tables, method 2. + real(r8) :: logsig2(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 2, method 2. + real(r8) :: rnew2(pcols,pver) ! New modal radius, mode 2, from look-up tables, method 2. + real(r8) :: logsig4(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 4, method 2. + real(r8) :: rnew4(pcols,pver) ! New modal radius, mode 4, from look-up tables, method 2. + real(r8) :: logsig5(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 5, method 2. + real(r8) :: rnew5(pcols,pver) ! New modal radius, mode 5, from look-up tables, method 2. + real(r8) :: logsig6(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 6, method 2. + real(r8) :: rnew6(pcols,pver) ! New modal radius, mode 6, from look-up tables, method 2. + real(r8) :: logsig7(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 7, method 2. + real(r8) :: rnew7(pcols,pver) ! New modal radius, mode 7, from look-up tables, method 2. + real(r8) :: logsig8(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 8, method 2. + real(r8) :: rnew8(pcols,pver) ! New modal radius, mode 8, from look-up tables, method 2. + real(r8) :: logsig9(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 9, method 2. + real(r8) :: rnew9(pcols,pver) ! New modal radius, mode 9, from look-up tables, method 2. + real(r8) :: logsig10(pcols,pver)! Log (log10) of standard deviation for lognormal modes 10, method 2. + real(r8) :: rnew10(pcols,pver) ! New modal radius, mode 10, from look-up tables, method 2. + real(r8) :: logsig11(pcols,pver)! Log (log10) of standard deviation for lognormal modes 11, method 2. + real(r8) :: rnew11(pcols,pver) ! New modal radius, mode 11, from look-up tables, method 2. + real(r8) :: logsig13(pcols,pver)! Log (log10) of standard deviation for lognormal modes 13, method 2. + real(r8) :: rnew13(pcols,pver) ! New modal radius, mode 13, from look-up tables, method 2. + real(r8) :: logsig14(pcols,pver)! Log (log10) of standard deviation for lognormal modes 14, method 2. + real(r8) :: rnew14(pcols,pver) ! New modal radius, mode 14, from look-up tables, method 2. + real(r8) :: rnewdry1(pcols,pver) ! New dry modal radius, mode 1, from look-up tables, method 2. + real(r8) :: rnewdry2(pcols,pver) ! New dry modal radius, mode 2, from look-up tables, method 2. + real(r8) :: rnewdry4(pcols,pver) ! New dry modal radius, mode 4, from look-up tables, method 2. + real(r8) :: rnewdry5(pcols,pver) ! New dry modal radius, mode 5, from look-up tables, method 2. + real(r8) :: rnewdry6(pcols,pver) ! New dry modal radius, mode 6, from look-up tables, method 2. + real(r8) :: rnewdry7(pcols,pver) ! New dry modal radius, mode 7, from look-up tables, method 2. + real(r8) :: rnewdry8(pcols,pver) ! New dry modal radius, mode 8, from look-up tables, method 2. + real(r8) :: rnewdry9(pcols,pver) ! New dry modal radius, mode 9, from look-up tables, method 2. + real(r8) :: rnewdry10(pcols,pver) ! New dry modal radius, mode 10, from look-up tables, method 2. + real(r8) :: rnewdry11(pcols,pver) ! New dry modal radius, mode 11, from look-up tables, method 2. + real(r8) :: rnewdry13(pcols,pver) ! New dry modal radius, mode 13, from look-up tables, method 2. + real(r8) :: rnewdry14(pcols,pver) ! New dry modal radius, mode 14, from look-up tables, method 2. + real(r8) :: relhum(pcols,pver) ! Ambient relative humidity (fraction) + real(r8) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate + real(r8) :: v3insol(pcols,pver,nmodes)! Modal mass fraction of BC and dust + real(r8) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) + real(r8) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt + real(r8) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor + ! OSLO_AERO_END !----------------------------------------------------------------------- call t_startf('bc_init') @@ -2080,24 +2083,6 @@ subroutine tphysbc (ztodt, state, & ! code. call sslt_rebin_adv(pbuf, state) -#ifdef DIRIND -! do i=1,ncol -! precc (i) = prec_zmc(i) + prec_cmf(i) -! if(precc(i).lt.0.) precc(i)=0. -! end do -#ifdef AEROCOM -! do kcomp=1,14 -! do k=1,pver -! do i=1,ncol - rnew3d(:,:,:) =0.0_r8 - logsig3d(:,:,:)=0.0_r8 -! enddo -! enddo -! enddo -#endif ! aerocom -#endif ! dirind - - !=================================================== ! Calculate tendencies from CARMA bin microphysics. !=================================================== @@ -2334,103 +2319,53 @@ subroutine tphysbc (ztodt, state, & call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) call physics_update(state, ptend, ztodt, tend) -#ifdef DIRIND -#ifdef AEROCOM -! Estimating hygroscopic growth by use of linear interpolation w.r.t. mass -! fractions of each internally mixed component for each mode (kcomp). -! - call intfrh(lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relhum, frh) -! - do k=1,pver - do i=1,ncol - rnewdry1(i,k) = rnew3d(i,k,1) - rnewdry2(i,k) = rnew3d(i,k,2) - rnewdry4(i,k) = rnew3d(i,k,4) - rnewdry5(i,k) = rnew3d(i,k,5) - rnewdry6(i,k) = rnew3d(i,k,6) - rnewdry7(i,k) = rnew3d(i,k,7) - rnewdry8(i,k) = rnew3d(i,k,8) - rnewdry9(i,k) = rnew3d(i,k,9) - rnewdry10(i,k) = rnew3d(i,k,10) - rnewdry11(i,k) = rnew3d(i,k,11) - rnewdry13(i,k) = rnew3d(i,k,13) - rnewdry14(i,k) = rnew3d(i,k,14) - rnew1(i,k) = rnew3d(i,k,1)*frh(i,k,1) - rnew2(i,k) = rnew3d(i,k,2)*frh(i,k,2) - rnew4(i,k) = rnew3d(i,k,4)*frh(i,k,4) - rnew5(i,k) = rnew3d(i,k,5)*frh(i,k,5) - rnew6(i,k) = rnew3d(i,k,6)*frh(i,k,6) - rnew7(i,k) = rnew3d(i,k,7)*frh(i,k,7) - rnew8(i,k) = rnew3d(i,k,8)*frh(i,k,8) - rnew9(i,k) = rnew3d(i,k,9)*frh(i,k,9) - rnew10(i,k) = rnew3d(i,k,10)*frh(i,k,10) - rnew11(i,k) = rnew3d(i,k,11)*frh(i,k,11) - rnew13(i,k) = rnew3d(i,k,13)*frh(i,k,13) - rnew14(i,k) = rnew3d(i,k,14)*frh(i,k,14) - logsig1(i,k) = logsig3d(i,k,1) - logsig2(i,k) = logsig3d(i,k,2) - logsig4(i,k) = logsig3d(i,k,4) - logsig5(i,k) = logsig3d(i,k,5) - logsig6(i,k) = logsig3d(i,k,6) - logsig7(i,k) = logsig3d(i,k,7) - logsig8(i,k) = logsig3d(i,k,8) - logsig9(i,k) = logsig3d(i,k,9) - logsig10(i,k)= logsig3d(i,k,10) - logsig11(i,k)= logsig3d(i,k,11) - logsig13(i,k)= logsig3d(i,k,13) - logsig14(i,k)= logsig3d(i,k,14) -!test-output++ -! logsig1(i,k) = frh(i,k,1) -! logsig2(i,k) = frh(i,k,2) -! logsig4(i,k) = frh(i,k,4) -! logsig5(i,k) = frh(i,k,5) -! logsig6(i,k) = frh(i,k,6) -! logsig7(i,k) = frh(i,k,7) -! logsig8(i,k) = frh(i,k,8) -! logsig9(i,k) = frh(i,k,9) -! logsig10(i,k) = frh(i,k,10) -!test-output-- - end do - end do -! kommenterer ut disse foreløpig: -! call outfld('RNEWD1 ',rnewdry1,pcols,lchnk) -! call outfld('RNEWD2 ',rnewdry2,pcols,lchnk) -! call outfld('RNEWD4 ',rnewdry4,pcols,lchnk) -! call outfld('RNEWD5 ',rnewdry5,pcols,lchnk) -! call outfld('RNEWD6 ',rnewdry6,pcols,lchnk) -! call outfld('RNEWD7 ',rnewdry7,pcols,lchnk) -! call outfld('RNEWD8 ',rnewdry8,pcols,lchnk) -! call outfld('RNEWD9 ',rnewdry9,pcols,lchnk) -! call outfld('RNEWD10 ',rnewdry10,pcols,lchnk) -!! call outfld('RNEWD11 ',rnewdry11,pcols,lchnk) ! always = 0.0118 -!! call outfld('RNEWD13 ',rnewdry13,pcols,lchnk) ! always = 0.04 -!! call outfld('RNEWD14 ',rnewdry14,pcols,lchnk) ! always = 0.04 -! call outfld('RNEW1 ',rnew1,pcols,lchnk) -! call outfld('RNEW2 ',rnew2,pcols,lchnk) -! call outfld('RNEW4 ',rnew4,pcols,lchnk) -! call outfld('RNEW5 ',rnew5,pcols,lchnk) -! call outfld('RNEW6 ',rnew6,pcols,lchnk) -! call outfld('RNEW7 ',rnew7,pcols,lchnk) -! call outfld('RNEW8 ',rnew8,pcols,lchnk) -! call outfld('RNEW9 ',rnew9,pcols,lchnk) -! call outfld('RNEW10 ',rnew10,pcols,lchnk) -! call outfld('RNEW11 ',rnew11,pcols,lchnk) -! call outfld('RNEW13 ',rnew13,pcols,lchnk) -! call outfld('RNEW14 ',rnew14,pcols,lchnk) -! call outfld('LOGSIG1 ',logsig1,pcols,lchnk) -! call outfld('LOGSIG2 ',logsig2,pcols,lchnk) -! call outfld('LOGSIG4 ',logsig4,pcols,lchnk) -! call outfld('LOGSIG5 ',logsig5,pcols,lchnk) -! call outfld('LOGSIG6 ',logsig6,pcols,lchnk) -! call outfld('LOGSIG7 ',logsig7,pcols,lchnk) -! call outfld('LOGSIG8 ',logsig8,pcols,lchnk) -! call outfld('LOGSIG9 ',logsig9,pcols,lchnk) -! call outfld('LOGSIG10',logsig10,pcols,lchnk) -!! call outfld('LOGSIG11',logsig11,pcols,lchnk) ! always = 0.2553 -!! call outfld('LOGSIG13',logsig13,pcols,lchnk) ! always = 0.2553 -!! call outfld('LOGSIG14',logsig14,pcols,lchnk) ! always = 0.2553 -#endif ! aerocom -#endif ! dirind + if (do_aerocom) then + ! Estimating hygroscopic growth by use of linear interpolation w.r.t. mass + ! fractions of each internally mixed component for each mode (kcomp). + ! + call intfrh(lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relhum, frh) + ! + do k=1,pver + do i=1,ncol + rnewdry1(i,k) = rnew3d(i,k,1) + rnewdry2(i,k) = rnew3d(i,k,2) + rnewdry4(i,k) = rnew3d(i,k,4) + rnewdry5(i,k) = rnew3d(i,k,5) + rnewdry6(i,k) = rnew3d(i,k,6) + rnewdry7(i,k) = rnew3d(i,k,7) + rnewdry8(i,k) = rnew3d(i,k,8) + rnewdry9(i,k) = rnew3d(i,k,9) + rnewdry10(i,k) = rnew3d(i,k,10) + rnewdry11(i,k) = rnew3d(i,k,11) + rnewdry13(i,k) = rnew3d(i,k,13) + rnewdry14(i,k) = rnew3d(i,k,14) + rnew1(i,k) = rnew3d(i,k,1)*frh(i,k,1) + rnew2(i,k) = rnew3d(i,k,2)*frh(i,k,2) + rnew4(i,k) = rnew3d(i,k,4)*frh(i,k,4) + rnew5(i,k) = rnew3d(i,k,5)*frh(i,k,5) + rnew6(i,k) = rnew3d(i,k,6)*frh(i,k,6) + rnew7(i,k) = rnew3d(i,k,7)*frh(i,k,7) + rnew8(i,k) = rnew3d(i,k,8)*frh(i,k,8) + rnew9(i,k) = rnew3d(i,k,9)*frh(i,k,9) + rnew10(i,k) = rnew3d(i,k,10)*frh(i,k,10) + rnew11(i,k) = rnew3d(i,k,11)*frh(i,k,11) + rnew13(i,k) = rnew3d(i,k,13)*frh(i,k,13) + rnew14(i,k) = rnew3d(i,k,14)*frh(i,k,14) + logsig1(i,k) = logsig3d(i,k,1) + logsig2(i,k) = logsig3d(i,k,2) + logsig4(i,k) = logsig3d(i,k,4) + logsig5(i,k) = logsig3d(i,k,5) + logsig6(i,k) = logsig3d(i,k,6) + logsig7(i,k) = logsig3d(i,k,7) + logsig8(i,k) = logsig3d(i,k,8) + logsig9(i,k) = logsig3d(i,k,9) + logsig10(i,k)= logsig3d(i,k,10) + logsig11(i,k)= logsig3d(i,k,11) + logsig13(i,k)= logsig3d(i,k,13) + logsig14(i,k)= logsig3d(i,k,14) + end do + end do + end if if (carma_do_wetdep) then ! CARMA wet deposition @@ -2548,9 +2483,9 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) use epp_ionization, only: epp_ionization_active use iop_forcing, only: scam_use_iop_srf use nudging, only: Nudge_Model, nudging_timestep_init -#ifdef OSLO_AERO + ! OSLO_AERO beg use oslo_ocean_intr, only: oslo_ocean_time -#endif + ! OSLO_AERO end implicit none @@ -2585,9 +2520,9 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) call aircraft_emit_adv(phys_state, pbuf2d) call prescribed_volcaero_adv(phys_state, pbuf2d) call prescribed_strataero_adv(phys_state, pbuf2d) -#ifdef OSLO_AERO + ! OSLO_AERO beg call oslo_ocean_time(phys_state, pbuf2d) -#endif + ! OSLO_AERO end ! prescribed aerosol deposition fluxes call aerodep_flx_adv(phys_state, pbuf2d, cam_out) diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 38a06f8722..6c91b077e5 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -3,8 +3,6 @@ !=============================================================================== module aero_model -#include - use shr_kind_mod, only: r8 => shr_kind_r8 use constituents, only: pcnst, cnst_name, cnst_get_ind use ppgrid, only: pcols, pver, pverp @@ -14,26 +12,22 @@ module aero_model use perf_mod, only: t_startf, t_stopf use camsrfexch, only: cam_in_t, cam_out_t use aerodep_flx, only: aerodep_flx_prescribed - use init_aeropt_mod,only: initaeropt + use aeroopt_mod, only: initaeropt + use aerodry_mod, only: initdryp use physics_types, only: physics_state, physics_ptend, physics_ptend_init use physics_buffer, only: physics_buffer_desc use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field use physconst, only: gravit, rair, rhoh2o use spmd_utils, only: masterproc use infnan, only: nan, assignment(=) - use cam_history, only: outfld, fieldname_len use chem_mods, only: gas_pcnst, adv_mass use mo_tracname, only: solsym - use aerosoldef, only: chemistryIndex, physicsIndex & - , getCloudTracerIndexDirect & - , getCloudTracerName - use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4 & - , condtend_sub - use koagsub, only: coagtend, clcoag + use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName + use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub + use koagsub, only: coagtend, clcoag use sox_cldaero_mod, only: sox_cldaero_init - !use modal_aero_data,only: cnst_name_cw, lptr_so4_cw_amode !use modal_aero_data,only: ntot_amode, modename_amode, nspec_max @@ -56,7 +50,7 @@ module aero_model public :: aero_model_surfarea ! tropopspheric aerosol wet surface area for chemistry public :: aero_model_strat_surfarea ! stratospheric aerosol wet surface area for chemistry - ! Misc private data + ! Misc private data ! number of modes integer :: nmodes @@ -108,6 +102,12 @@ module aero_model logical :: convproc_do_aer +#ifdef AEROCOM + logical :: do_aerocom = .true. +#else + logical :: do_aerocom = .false. +#endif + contains !============================================================================= @@ -237,10 +237,10 @@ subroutine aero_model_init( pbuf2d ) call initopt call initlogn call initopt_lw -#ifdef AEROCOM - call initaeropt() - call initdryp -#endif ! aerocom + if (do_aerocom) then + call initaeropt() + call initdryp() + end if call initializeCondensation() call oslo_ocean_init() diff --git a/src/chemistry/oslo_aero/intlog.F90 b/src/chemistry/oslo_aero/intlog.F90 new file mode 100644 index 0000000000..f2fe698108 --- /dev/null +++ b/src/chemistry/oslo_aero/intlog.F90 @@ -0,0 +1,491 @@ +module intlog + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols + use commondefinitions, only : nmodes, nbmodes + use const, only: sss1to3, rrr1to3 + use const, only: sss4, rrr4 + use const, only: sss, rrr + use opttab, only: nbmp1, cate, fac, faq, fbc, cat + use lininterpol_mod, only: lininterpol3dim, lininterpol4dim + + implicit none + private + + public :: intlog1to3_sub + public :: intlog4_sub + public :: intlog5to10_sub + +contains + + subroutine intlog1to3_sub (ncol, ind, kcomp, xctin, & + Nnat, xfacin, cxs, xstdv, xrk) + + ! Created by Trude Storelvmo, fall 2007. This subroutine gives as output + ! the "new" modal radius and standard deviation for a given aerosol mode, kcomp + ! 1-3. These parameters are calculated for a best lognormal fit approximation of + ! the aerosol size distribution. This because the aerosol activation routine + ! (developed by Abdul-Razzak & Ghan, 2000) requiers the size distribution to be + ! described by lognormal modes. + ! Changed by Alf KirkevÃ¥g to take into account condensation of SOA, September 2015, + + integer, intent(in) :: ncol + integer, intent(in) :: ind(pcols) + integer, intent(in) :: kcomp + real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration + real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) + real(r8), intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass + real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit + real(r8), intent(out) :: xrk(pcols) ! Modal radius for lognormal fit + real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. + + real(r8) camdiff + real(r8) xct(pcols) + real(r8) xfac(ncol) + integer lon, long + integer i, ictot, ict1, ict2 + real(r8) r1, r2, s1, s2 + integer ifac, ifac1, ifac2 + real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2 + real(r8) r11, r12, r21, r22, s11, s12, s21, s22 + real(r8) d2mx(2), dxm1(2), invd(2) + real(r8) esssf10, ess + real(r8), parameter :: eps= 1.0e-10_r8 + + ! Initialize excess mass cxs, wrt. maximum allowed internal mixing + do lon=1,ncol + cxs(lon) = 0.0_r8 + xct(lon) = 0.0_r8 + xfac(lon) = 0.0_r8 + enddo + + do long=1,ncol + lon=ind(long) + xstdv(lon) = 0._r8 + xrk(lon) = 0._r8 + + xct(lon) = min(max(xctin(lon)/(Nnat(lon)+eps),cate(kcomp,1)),cate(kcomp,16)) + xfac(lon) = min(max(xfacin(lon),fac(1)),fac(6)) + camdiff = xctin(lon)-xct(lon)*(Nnat(lon)+eps) + + cxs(lon) = max(0.0_r8,camdiff) + + ictot=1 + ess = xct(lon) + do while (ictot.lt.15.and.(ess.lt.cate(kcomp,ictot).or. & + ess.gt.cate(kcomp,ictot+1))) + ictot=ictot+1 + enddo + ict1=ictot + ict2=ictot+1 + + ifac=1 + ess = xfac(lon) + do while (ifac.lt.5.and.(ess.lt.fac(ifac).or. & + ess.gt.fac(ifac+1))) + ifac=ifac+1 + enddo + ifac1=ifac + ifac2=ifac+1 + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_cat1 = cate(kcomp,ict1) + t_cat2 = cate(kcomp,ict2) + t_fac1 = fac(ifac1) + t_fac2 = fac(ifac2) + + t_xct = xct(lon) + t_xfac = xfac(lon) + + ! partial lengths along each dimension (1-2) for interpolation + + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + + ! interpolated (in 2 dimensions) modal median radius: + + r11=rrr1to3(kcomp,ict1,ifac1) + r12=rrr1to3(kcomp,ict1,ifac2) + r21=rrr1to3(kcomp,ict2,ifac1) + r22=rrr1to3(kcomp,ict2,ifac2) + + r1 =d2mx(2)*r11+dxm1(2)*r12 + r2 =d2mx(2)*r21+dxm1(2)*r22 + + xrk(lon) = (d2mx(1)*r1+dxm1(1)*r2)*invd(2)*invd(1)*1.e-6_r8 !Look-up table radii in um + + ! interpolated (in 2 dimensions) modal standard deviation: + + s11=sss1to3(kcomp,ict1,ifac1) + s12=sss1to3(kcomp,ict1,ifac2) + s21=sss1to3(kcomp,ict2,ifac1) + s22=sss1to3(kcomp,ict2,ifac2) + + s1 =d2mx(2)*s11+dxm1(2)*s12 + s2 =d2mx(2)*s21+dxm1(2)*s22 + + xstdv(lon) = (d2mx(1)*s1+dxm1(1)*s2)*invd(2)*invd(1) + + + end do ! lon + + return + end subroutine intlog1to3_sub + + subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & + xfacin, xfaqin, cxs, xstdv, xrk) + + ! Created by Trude Storelvmo, fall 2007. This subroutine gives as output + ! the "new" modal radius and standard deviation for aerosol mode kcomp=4. + ! These parameters are calculated for a best lognormal fit approximation of + ! the aerosol size distribution. This because the aerosol activation routine + ! (developed by Abdul-Razzak & Ghan, 2000) requires the size distribution + ! to be described by lognormal modes. + ! Changed by Alf KirkevÃ¥g to take into account condensation of SOA, September + ! 2015, and also rewritten to a more generalized for for interpolations using + ! common subroutines interpol*dim. + + integer, intent(in) :: ncol + integer, intent(in) :: ind(pcols) + integer, intent(in) :: kcomp + real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration + real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) + real(r8), intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass + real(r8), intent(in) :: xfaqin(pcols) ! = Cso4a2/(Cso4a1+Cso4a2) + real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit + real(r8), intent(out) :: xrk(pcols) ! Modal radius for lognormal fit + real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. + + real(r8) camdiff + real(r8), dimension(pcols) :: xct, xfac, xfaq + + integer lon, long + + integer i, ictot, ifac, ifaq, & + ict1, ict2, ifac1, ifac2, ifaq1, ifaq2 + + real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2, & + t_faq1, t_faq2, t_xfaq + real(r8) r1, r2, s1, s2, tmp, e + real(r8) d2mx(3), dxm1(3), invd(3) + real(r8) sizepar3d(2,2,2) + + !ces: New local variables introduced by (or inspired by) Egil Stoeren: + + real(r8), parameter :: eps=1.0e-60_r8 + + ! Initialize excess mass cxs, wrt. maximum allowed internal mixing + do lon=1,ncol + cxs(lon) = 0.0_r8 + xct(lon) = 0.0_r8 + xfac(lon) = 0.0_r8 + xfaq(lon) = 0.0_r8 + enddo + + !ces: All loops "do long=1,nlons" combined to one loop: + + ! do lon=1,ncol + do long=1,ncol + lon=ind(long) + xstdv(lon) = 0._r8 + xrk(lon) = 0._r8 + + xct(lon) = min(max(xctin(lon)/(Nnat(lon)+eps),cate(kcomp,1)),cate(kcomp,16)) + xfac(lon) = min(max(xfacin(lon),fac(1)),fac(6)) + xfaq(lon) = min(max(xfaqin(lon),faq(1)),faq(6)) + + camdiff = xctin(lon)-xct(lon)*(Nnat(lon)+eps) + + cxs(lon) = max(0.0_r8,camdiff) + + ictot=1 + tmp = xct(lon) + do while (ictot.lt.15.and.(tmp.lt.cate(kcomp,ictot).or. & + tmp.gt.cate(kcomp,ictot+1))) + ictot=ictot+1 + enddo + ict1=ictot + ict2=ictot+1 + + ifac=1 + tmp = xfac(lon) + do while (ifac.lt.5.and.(tmp.lt.fac(ifac).or. & + tmp.gt.fac(ifac+1))) + ifac=ifac+1 + enddo + ifac1=ifac + ifac2=ifac+1 + + ifaq=1 + tmp = xfaq(lon) + do while (ifaq.lt.5.and.(tmp.lt.faq(ifaq) & + .or.tmp.gt.faq(ifaq+1))) + ifaq=ifaq+1 + enddo + ifaq1=ifaq + ifaq2=ifaq+1 + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + t_cat1 = cate(kcomp,ict1) + t_cat2 = cate(kcomp,ict2) + t_fac1 = fac(ifac1) + t_fac2 = fac(ifac2) + t_faq1 = faq(ifaq1) + t_faq2 = faq(ifaq2) + + t_xct = xct(lon) + t_xfac = xfac(lon) + t_xfaq = xfaq(lon) + + ! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + d2mx(3) = (t_faq2-t_xfaq) + dxm1(3) = (t_xfaq-t_faq1) + invd(3) = 1.0_r8/(t_faq2-t_faq1) + + ! Table points as basis for multidimentional linear interpolation, + ! modal median radius: + + sizepar3d(1,1,1)=rrr4(ict1,ifac1,ifaq1) + sizepar3d(1,1,2)=rrr4(ict1,ifac1,ifaq2) + sizepar3d(1,2,1)=rrr4(ict1,ifac2,ifaq1) + sizepar3d(1,2,2)=rrr4(ict1,ifac2,ifaq2) + sizepar3d(2,1,1)=rrr4(ict2,ifac1,ifaq1) + sizepar3d(2,1,2)=rrr4(ict2,ifac1,ifaq2) + sizepar3d(2,2,1)=rrr4(ict2,ifac2,ifaq1) + sizepar3d(2,2,2)=rrr4(ict2,ifac2,ifaq2) + + ! interpolation in the faq and fac dimension + call lininterpol3dim (d2mx, dxm1, invd, sizepar3d, r1, r2) + + ! finally, interpolation in the cate dimension + xrk(lon)=(d2mx(1)*r1+dxm1(1)*r2)*invd(1)*1.e-6_r8 ! look up table radii in um + + + ! Table points as basis for multidimentional linear interpolation, + ! modal standard deviation: + sizepar3d(1,1,1)=sss4(ict1,ifac1,ifaq1) + sizepar3d(1,1,2)=sss4(ict1,ifac1,ifaq2) + sizepar3d(1,2,1)=sss4(ict1,ifac2,ifaq1) + sizepar3d(1,2,2)=sss4(ict1,ifac2,ifaq2) + sizepar3d(2,1,1)=sss4(ict2,ifac1,ifaq1) + sizepar3d(2,1,2)=sss4(ict2,ifac1,ifaq2) + sizepar3d(2,2,1)=sss4(ict2,ifac2,ifaq1) + sizepar3d(2,2,2)=sss4(ict2,ifac2,ifaq2) + + ! interpolation in the faq and fac dimension + call lininterpol3dim (d2mx, dxm1, invd, sizepar3d, s1, s2) + + ! finally, interpolation in the cate dimension + xstdv(lon)=(d2mx(1)*s1+dxm1(1)*s2)*invd(1) + + end do ! lon + + return + end subroutine intlog4_sub + + subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & + xfacin, xfbcin, xfaqin, cxs, xstdv, xrk) + + !Created by Trude Storelvmo, fall 2007, based on method of A. Kirkevag. + !This subroutine gives as output the "new" modal radius and standard deviation + !for a given aerosol mode, kcomp 1-5. These parameters are calculated for a + !best lognormal fit approximation of the aerosol size distribution. + !This because the aerosol activation routine (developed by Abdul-Razzak & Ghan, + !2000) requires the size distribution to be described by lognormal modes. + !Rewritten by Alf Kirkevaag September 2015 to a more generalized for for + !interpolations using common subroutines interpol*dim. + + + implicit none + + integer, intent(in) :: ncol + integer, intent(in) :: ind(pcols) + integer, intent(in) :: kcomp + real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration + real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) + real(r8), intent(in) :: xfacin(pcols) ! = (Cbc+Coc)/(Cbc+Coc+Cso4) + real(r8), intent(in) :: xfbcin(pcols) ! = Cbc/(Cbc+Coc) + real(r8), intent(in) :: xfaqin(pcols) ! = Cso4a2/(Cso4a1+Cso4a2) + real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation of lognormal fit + real(r8), intent(out) :: xrk(pcols) ! Modal radius of lognormal fit + real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. + + real(r8) xctsave, camdiff + real(r8), dimension(pcols) :: xct, xfac, xfbc, xfaq + + integer lon, long + + integer i, ictot, ifac, ifbc, ifaq, & + ict1, ict2, ifac1, ifac2, & + ifbc1, ifbc2, ifaq1, ifaq2 + + real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2, & + t_faq1, t_faq2, t_xfaq, t_fbc1, t_fbc2, t_xfbc + real(r8) r1, r2, s1, s2, tmp, e + real(r8) d2mx(4), dxm1(4), invd(4) + real(r8) sizepar4d(2,2,2,2) + + real(r8), parameter :: eps=1.0e-10_r8 + + ! Initialize excess mass cxs, wrt. maximum allowed internal mixing + do lon=1,ncol + cxs(lon) = 0.0_r8 + xct(lon) = 0.0_r8 + xfac(lon) = 0.0_r8 + xfbc(lon) = 0.0_r8 + xfaq(lon) = 0.0_r8 + enddo + + !ces: All loops "do long=1,nlons" combined to one loop: + + ! do lon=1,ncol + do long=1,ncol + lon=ind(long) + xstdv(lon) = 0._r8 + xrk(lon) = 0._r8 + + xct(lon) = min(max(xctin(lon)/(Nnat(lon)+eps),cat(kcomp,1)),cat(kcomp,6)) + xfac(lon) = min(max(xfacin(lon),fac(1)),fac(6)) + xfbc(lon) = min(max(xfbcin(lon),fbc(1)),fbc(6)) + xfaq(lon) = min(max(xfaqin(lon),faq(1)),faq(6)) + + camdiff = xctin(lon)-xct(lon)*(Nnat(lon)+eps) + + cxs(lon) = max(0.0_r8,camdiff) + + ictot=1 + tmp = xct(lon) + do while (ictot.lt.5.and.(tmp.lt.cat(kcomp,ictot).or. & + tmp.gt.cat(kcomp,ictot+1))) + ictot=ictot+1 + enddo + ict1=ictot + ict2=ictot+1 + + ifac=1 + tmp = xfac(lon) + do while (ifac.lt.5.and.(tmp.lt.fac(ifac).or. & + tmp.gt.fac(ifac+1))) + ifac=ifac+1 + enddo + ifac1=ifac + ifac2=ifac+1 + + ifbc=1 + tmp = xfbc(lon) + do while (ifbc.lt.5.and.(tmp.lt.fbc(ifbc).or. & + tmp.gt.fbc(ifbc+1))) + ifbc=ifbc+1 + enddo + ifbc1=ifbc + ifbc2=ifbc+1 + + ifaq=1 + tmp = xfaq(lon) + do while (ifaq.lt.5.and.(tmp.lt.faq(ifaq) & + .or.tmp.gt.faq(ifaq+1))) + ifaq=ifaq+1 + enddo + ifaq1=ifaq + ifaq2=ifaq+1 + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + t_cat1 = cat(kcomp,ict1) + t_cat2 = cat(kcomp,ict2) + t_fac1 = fac(ifac1) + t_fac2 = fac(ifac2) + t_fbc1 = fbc(ifbc1) + t_fbc2 = fbc(ifbc2) + t_faq1 = faq(ifaq1) + t_faq2 = faq(ifaq2) + + t_xct = xct(lon) + t_xfac = xfac(lon) + t_xfbc = xfbc(lon) + t_xfaq = xfaq(lon) + + ! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_cat2-t_xct) + dxm1(1) = (t_xct-t_cat1) + invd(1) = 1.0_r8/(t_cat2-t_cat1) + d2mx(2) = (t_fac2-t_xfac) + dxm1(2) = (t_xfac-t_fac1) + invd(2) = 1.0_r8/(t_fac2-t_fac1) + d2mx(3) = (t_fbc2-t_xfbc) + dxm1(3) = (t_xfbc-t_fbc1) + invd(3) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(4) = (t_faq2-t_xfaq) + dxm1(4) = (t_xfaq-t_faq1) + invd(4) = 1.0_r8/(t_faq2-t_faq1) + + ! Table points as basis for multidimentional linear interpolation, + ! modal median radius: + + sizepar4d(1,1,1,1)=rrr(kcomp,ict1,ifac1,ifbc1,ifaq1) + sizepar4d(1,1,1,2)=rrr(kcomp,ict1,ifac1,ifbc1,ifaq2) + sizepar4d(1,1,2,1)=rrr(kcomp,ict1,ifac1,ifbc2,ifaq1) + sizepar4d(1,1,2,2)=rrr(kcomp,ict1,ifac1,ifbc2,ifaq2) + sizepar4d(1,2,1,1)=rrr(kcomp,ict1,ifac2,ifbc1,ifaq1) + sizepar4d(1,2,1,2)=rrr(kcomp,ict1,ifac2,ifbc1,ifaq2) + sizepar4d(1,2,2,1)=rrr(kcomp,ict1,ifac2,ifbc2,ifaq1) + sizepar4d(1,2,2,2)=rrr(kcomp,ict1,ifac2,ifbc2,ifaq2) + sizepar4d(2,1,1,1)=rrr(kcomp,ict2,ifac1,ifbc1,ifaq1) + sizepar4d(2,1,1,2)=rrr(kcomp,ict2,ifac1,ifbc1,ifaq2) + sizepar4d(2,1,2,1)=rrr(kcomp,ict2,ifac1,ifbc2,ifaq1) + sizepar4d(2,1,2,2)=rrr(kcomp,ict2,ifac1,ifbc2,ifaq2) + sizepar4d(2,2,1,1)=rrr(kcomp,ict2,ifac2,ifbc1,ifaq1) + sizepar4d(2,2,1,2)=rrr(kcomp,ict2,ifac2,ifbc1,ifaq2) + sizepar4d(2,2,2,1)=rrr(kcomp,ict2,ifac2,ifbc2,ifaq1) + sizepar4d(2,2,2,2)=rrr(kcomp,ict2,ifac2,ifbc2,ifaq2) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol4dim (d2mx, dxm1, invd, sizepar4d, r1, r2) + + ! finally, interpolation in the cat dimension + xrk(lon)=(d2mx(1)*r1+dxm1(1)*r2)*invd(1)*1.e-6_r8 ! look-up table radii in um + + ! Table points as basis for multidimentional linear interpolation, + ! modal standard deviation: + + sizepar4d(1,1,1,1)=sss(kcomp,ict1,ifac1,ifbc1,ifaq1) + sizepar4d(1,1,1,2)=sss(kcomp,ict1,ifac1,ifbc1,ifaq2) + sizepar4d(1,1,2,1)=sss(kcomp,ict1,ifac1,ifbc2,ifaq1) + sizepar4d(1,1,2,2)=sss(kcomp,ict1,ifac1,ifbc2,ifaq2) + sizepar4d(1,2,1,1)=sss(kcomp,ict1,ifac2,ifbc1,ifaq1) + sizepar4d(1,2,1,2)=sss(kcomp,ict1,ifac2,ifbc1,ifaq2) + sizepar4d(1,2,2,1)=sss(kcomp,ict1,ifac2,ifbc2,ifaq1) + sizepar4d(1,2,2,2)=sss(kcomp,ict1,ifac2,ifbc2,ifaq2) + sizepar4d(2,1,1,1)=sss(kcomp,ict2,ifac1,ifbc1,ifaq1) + sizepar4d(2,1,1,2)=sss(kcomp,ict2,ifac1,ifbc1,ifaq2) + sizepar4d(2,1,2,1)=sss(kcomp,ict2,ifac1,ifbc2,ifaq1) + sizepar4d(2,1,2,2)=sss(kcomp,ict2,ifac1,ifbc2,ifaq2) + sizepar4d(2,2,1,1)=sss(kcomp,ict2,ifac2,ifbc1,ifaq1) + sizepar4d(2,2,1,2)=sss(kcomp,ict2,ifac2,ifbc1,ifaq2) + sizepar4d(2,2,2,1)=sss(kcomp,ict2,ifac2,ifbc2,ifaq1) + sizepar4d(2,2,2,2)=sss(kcomp,ict2,ifac2,ifbc2,ifaq2) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol4dim (d2mx, dxm1, invd, sizepar4d, s1, s2) + + ! finally, interpolation in the cat dimension + xstdv(lon)=(d2mx(1)*s1+dxm1(1)*s2)*invd(1) + + end do ! lon + end subroutine intlog5to10_sub + +end module intlog + diff --git a/src/chemistry/oslo_aero/intlog1to3.F90 b/src/chemistry/oslo_aero/intlog1to3.F90 deleted file mode 100644 index 86ab2cc4f0..0000000000 --- a/src/chemistry/oslo_aero/intlog1to3.F90 +++ /dev/null @@ -1,137 +0,0 @@ -module intlog1to3 - -contains - - subroutine intlog1to3_sub (ncol, ind, kcomp, xctin, & - Nnat, xfacin, cxs, xstdv, xrk) - -! Created by Trude Storelvmo, fall 2007. This subroutine gives as output -! the "new" modal radius and standard deviation for a given aerosol mode, kcomp -! 1-3. These parameters are calculated for a best lognormal fit approximation of -! the aerosol size distribution. This because the aerosol activation routine -! (developed by Abdul-Razzak & Ghan, 2000) requiers the size distribution to be -! described by lognormal modes. -! Changed by Alf KirkevÃ¥g to take into account condensation of SOA, September 2015, - - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols - use const, only: sss1to3, rrr1to3 - use opttab, only: cate, fac - - implicit none - - integer, intent(in) :: ncol - integer, intent(in) :: ind(pcols) - integer, intent(in) :: kcomp - real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration - real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) - real(r8), intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass - real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit - real(r8), intent(out) :: xrk(pcols) ! Modal radius for lognormal fit - real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. - - real(r8) camdiff - real(r8), dimension(pcols) :: xct - real(r8) xfac(ncol) - integer lon, long - - integer i, ictot, ict1, ict2 - real(r8) r1, r2, s1, s2 - integer ifac, ifac1, ifac2 - real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2 - real(r8) r11, r12, r21, r22, s11, s12, s21, s22 - real(r8) d2mx(2), dxm1(2), invd(2) - - real(r8) esssf10, ess - - real(r8), parameter :: eps= 1.0e-10_r8 - -! Initialize excess mass cxs, wrt. maximum allowed internal mixing - do lon=1,ncol - cxs(lon) = 0.0_r8 - xct(lon) = 0.0_r8 - xfac(lon) = 0.0_r8 - enddo - - do long=1,ncol - lon=ind(long) - xstdv(lon) = 0._r8 - xrk(lon) = 0._r8 - - xct(lon) = min(max(xctin(lon)/(Nnat(lon)+eps),cate(kcomp,1)),cate(kcomp,16)) - xfac(lon) = min(max(xfacin(lon),fac(1)),fac(6)) - camdiff = xctin(lon)-xct(lon)*(Nnat(lon)+eps) - - cxs(lon) = max(0.0_r8,camdiff) - - ictot=1 - ess = xct(lon) - do while (ictot.lt.15.and.(ess.lt.cate(kcomp,ictot).or. & - ess.gt.cate(kcomp,ictot+1))) - ictot=ictot+1 - enddo - ict1=ictot - ict2=ictot+1 - - ifac=1 - ess = xfac(lon) - do while (ifac.lt.5.and.(ess.lt.fac(ifac).or. & - ess.gt.fac(ifac+1))) - ifac=ifac+1 - enddo - ifac1=ifac - ifac2=ifac+1 - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - - t_cat1 = cate(kcomp,ict1) - t_cat2 = cate(kcomp,ict2) - t_fac1 = fac(ifac1) - t_fac2 = fac(ifac2) - - t_xct = xct(lon) - t_xfac = xfac(lon) - -! partial lengths along each dimension (1-2) for interpolation - - d2mx(1) = (t_cat2-t_xct) - dxm1(1) = (t_xct-t_cat1) - invd(1) = 1.0_r8/(t_cat2-t_cat1) - d2mx(2) = (t_fac2-t_xfac) - dxm1(2) = (t_xfac-t_fac1) - invd(2) = 1.0_r8/(t_fac2-t_fac1) - -! interpolated (in 2 dimensions) modal median radius: - - r11=rrr1to3(kcomp,ict1,ifac1) - r12=rrr1to3(kcomp,ict1,ifac2) - r21=rrr1to3(kcomp,ict2,ifac1) - r22=rrr1to3(kcomp,ict2,ifac2) - - r1 =d2mx(2)*r11+dxm1(2)*r12 - r2 =d2mx(2)*r21+dxm1(2)*r22 - - xrk(lon) = (d2mx(1)*r1+dxm1(1)*r2)*invd(2)*invd(1)*1.e-6_r8 !Look-up table radii in um - -! interpolated (in 2 dimensions) modal standard deviation: - - s11=sss1to3(kcomp,ict1,ifac1) - s12=sss1to3(kcomp,ict1,ifac2) - s21=sss1to3(kcomp,ict2,ifac1) - s22=sss1to3(kcomp,ict2,ifac2) - - s1 =d2mx(2)*s11+dxm1(2)*s12 - s2 =d2mx(2)*s21+dxm1(2)*s22 - - xstdv(lon) = (d2mx(1)*s1+dxm1(1)*s2)*invd(2)*invd(1) - - - end do ! lon - - return - end subroutine intlog1to3_sub - -end module intlog1to3 - diff --git a/src/chemistry/oslo_aero/intlog4.F90 b/src/chemistry/oslo_aero/intlog4.F90 deleted file mode 100644 index 0c8466e86d..0000000000 --- a/src/chemistry/oslo_aero/intlog4.F90 +++ /dev/null @@ -1,171 +0,0 @@ -module intlog4 - -contains - subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & - xfacin, xfaqin, cxs, xstdv, xrk) - -! Created by Trude Storelvmo, fall 2007. This subroutine gives as output -! the "new" modal radius and standard deviation for aerosol mode kcomp=4. -! These parameters are calculated for a best lognormal fit approximation of -! the aerosol size distribution. This because the aerosol activation routine -! (developed by Abdul-Razzak & Ghan, 2000) requires the size distribution -! to be described by lognormal modes. -! Changed by Alf KirkevÃ¥g to take into account condensation of SOA, September -! 2015, and also rewritten to a more generalized for for interpolations using -! common subroutines interpol*dim. - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols - use const, only: sss4, rrr4 - use opttab, only: nbmp1, cate, fac, faq - implicit none - - integer, intent(in) :: ncol - integer, intent(in) :: ind(pcols) - integer, intent(in) :: kcomp - real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration - real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) - real(r8), intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass - real(r8), intent(in) :: xfaqin(pcols) ! = Cso4a2/(Cso4a1+Cso4a2) - real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit - real(r8), intent(out) :: xrk(pcols) ! Modal radius for lognormal fit - real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. - - real(r8) camdiff - real(r8), dimension(pcols) :: xct, xfac, xfaq -!ces: integer arrays ict1, ict2, ifaq1 and ifaq2 -! substituted with scalar variables with the same name. - - integer lon, long - - integer i, ictot, ifac, ifaq, & - ict1, ict2, ifac1, ifac2, ifaq1, ifaq2 - - real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2, & - t_faq1, t_faq2, t_xfaq - real(r8) r1, r2, s1, s2, tmp, e - real(r8) d2mx(3), dxm1(3), invd(3) - real(r8) sizepar3d(2,2,2) - -!ces: New local variables introduced by (or inspired by) Egil Stoeren: - - real(r8), parameter :: eps=1.0e-60_r8 - -! Initialize excess mass cxs, wrt. maximum allowed internal mixing - do lon=1,ncol - cxs(lon) = 0.0_r8 - xct(lon) = 0.0_r8 - xfac(lon) = 0.0_r8 - xfaq(lon) = 0.0_r8 - enddo - -!ces: All loops "do long=1,nlons" combined to one loop: - -! do lon=1,ncol - do long=1,ncol - lon=ind(long) - xstdv(lon) = 0._r8 - xrk(lon) = 0._r8 - - xct(lon) = min(max(xctin(lon)/(Nnat(lon)+eps),cate(kcomp,1)),cate(kcomp,16)) - xfac(lon) = min(max(xfacin(lon),fac(1)),fac(6)) - xfaq(lon) = min(max(xfaqin(lon),faq(1)),faq(6)) - - camdiff = xctin(lon)-xct(lon)*(Nnat(lon)+eps) - - cxs(lon) = max(0.0_r8,camdiff) - - ictot=1 - tmp = xct(lon) - do while (ictot.lt.15.and.(tmp.lt.cate(kcomp,ictot).or. & - tmp.gt.cate(kcomp,ictot+1))) - ictot=ictot+1 - enddo - ict1=ictot - ict2=ictot+1 - - ifac=1 - tmp = xfac(lon) - do while (ifac.lt.5.and.(tmp.lt.fac(ifac).or. & - tmp.gt.fac(ifac+1))) - ifac=ifac+1 - enddo - ifac1=ifac - ifac2=ifac+1 - - ifaq=1 - tmp = xfaq(lon) - do while (ifaq.lt.5.and.(tmp.lt.faq(ifaq) & - .or.tmp.gt.faq(ifaq+1))) - ifaq=ifaq+1 - enddo - ifaq1=ifaq - ifaq2=ifaq+1 - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - t_cat1 = cate(kcomp,ict1) - t_cat2 = cate(kcomp,ict2) - t_fac1 = fac(ifac1) - t_fac2 = fac(ifac2) - t_faq1 = faq(ifaq1) - t_faq2 = faq(ifaq2) - - t_xct = xct(lon) - t_xfac = xfac(lon) - t_xfaq = xfaq(lon) - -! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_cat2-t_xct) - dxm1(1) = (t_xct-t_cat1) - invd(1) = 1.0_r8/(t_cat2-t_cat1) - d2mx(2) = (t_fac2-t_xfac) - dxm1(2) = (t_xfac-t_fac1) - invd(2) = 1.0_r8/(t_fac2-t_fac1) - d2mx(3) = (t_faq2-t_xfaq) - dxm1(3) = (t_xfaq-t_faq1) - invd(3) = 1.0_r8/(t_faq2-t_faq1) - -! Table points as basis for multidimentional linear interpolation, -! modal median radius: - - sizepar3d(1,1,1)=rrr4(ict1,ifac1,ifaq1) - sizepar3d(1,1,2)=rrr4(ict1,ifac1,ifaq2) - sizepar3d(1,2,1)=rrr4(ict1,ifac2,ifaq1) - sizepar3d(1,2,2)=rrr4(ict1,ifac2,ifaq2) - sizepar3d(2,1,1)=rrr4(ict2,ifac1,ifaq1) - sizepar3d(2,1,2)=rrr4(ict2,ifac1,ifaq2) - sizepar3d(2,2,1)=rrr4(ict2,ifac2,ifaq1) - sizepar3d(2,2,2)=rrr4(ict2,ifac2,ifaq2) - -! interpolation in the faq and fac dimension - call lininterpol3dim (d2mx, dxm1, invd, sizepar3d, r1, r2) - -! finally, interpolation in the cate dimension - xrk(lon)=(d2mx(1)*r1+dxm1(1)*r2)*invd(1)*1.e-6_r8 ! look up table radii in um - - -! Table points as basis for multidimentional linear interpolation, -! modal standard deviation: - sizepar3d(1,1,1)=sss4(ict1,ifac1,ifaq1) - sizepar3d(1,1,2)=sss4(ict1,ifac1,ifaq2) - sizepar3d(1,2,1)=sss4(ict1,ifac2,ifaq1) - sizepar3d(1,2,2)=sss4(ict1,ifac2,ifaq2) - sizepar3d(2,1,1)=sss4(ict2,ifac1,ifaq1) - sizepar3d(2,1,2)=sss4(ict2,ifac1,ifaq2) - sizepar3d(2,2,1)=sss4(ict2,ifac2,ifaq1) - sizepar3d(2,2,2)=sss4(ict2,ifac2,ifaq2) - -! interpolation in the faq and fac dimension - call lininterpol3dim (d2mx, dxm1, invd, sizepar3d, s1, s2) - -! finally, interpolation in the cate dimension - xstdv(lon)=(d2mx(1)*s1+dxm1(1)*s2)*invd(1) - - end do ! lon - - return -end subroutine intlog4_sub - -end module intlog4 - diff --git a/src/chemistry/oslo_aero/intlog5to10.F90 b/src/chemistry/oslo_aero/intlog5to10.F90 deleted file mode 100644 index 4c32b525d1..0000000000 --- a/src/chemistry/oslo_aero/intlog5to10.F90 +++ /dev/null @@ -1,203 +0,0 @@ -module intlog5to10 - -contains - - subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & - xfacin, xfbcin, xfaqin, cxs, xstdv, xrk) - -!Created by Trude Storelvmo, fall 2007, based on method of A. Kirkevag. -!This subroutine gives as output the "new" modal radius and standard deviation -!for a given aerosol mode, kcomp 1-5. These parameters are calculated for a -!best lognormal fit approximation of the aerosol size distribution. -!This because the aerosol activation routine (developed by Abdul-Razzak & Ghan, -!2000) requires the size distribution to be described by lognormal modes. -!Rewritten by Alf Kirkevaag September 2015 to a more generalized for for -!interpolations using common subroutines interpol*dim. - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only : pcols - use commondefinitions, only: nmodes, nbmodes - use const, only : sss, rrr - use opttab, only: cat, fbc, fac, faq - - implicit none - - integer, intent(in) :: ncol - integer, intent(in) :: ind(pcols) - integer, intent(in) :: kcomp - real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration - real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) - real(r8), intent(in) :: xfacin(pcols) ! = (Cbc+Coc)/(Cbc+Coc+Cso4) - real(r8), intent(in) :: xfbcin(pcols) ! = Cbc/(Cbc+Coc) - real(r8), intent(in) :: xfaqin(pcols) ! = Cso4a2/(Cso4a1+Cso4a2) - real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation of lognormal fit - real(r8), intent(out) :: xrk(pcols) ! Modal radius of lognormal fit - real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. - - real(r8) xctsave, camdiff - real(r8), dimension(pcols) :: xct, xfac, xfbc, xfaq - - integer lon, long - - integer i, ictot, ifac, ifbc, ifaq, & - ict1, ict2, ifac1, ifac2, & - ifbc1, ifbc2, ifaq1, ifaq2 - - real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2, & - t_faq1, t_faq2, t_xfaq, t_fbc1, t_fbc2, t_xfbc - real(r8) r1, r2, s1, s2, tmp, e - real(r8) d2mx(4), dxm1(4), invd(4) - real(r8) sizepar4d(2,2,2,2) - - real(r8), parameter :: eps=1.0e-10_r8 - -! Initialize excess mass cxs, wrt. maximum allowed internal mixing - do lon=1,ncol - cxs(lon) = 0.0_r8 - xct(lon) = 0.0_r8 - xfac(lon) = 0.0_r8 - xfbc(lon) = 0.0_r8 - xfaq(lon) = 0.0_r8 - enddo - -!ces: All loops "do long=1,nlons" combined to one loop: - -! do lon=1,ncol - do long=1,ncol - lon=ind(long) - xstdv(lon) = 0._r8 - xrk(lon) = 0._r8 - - xct(lon) = min(max(xctin(lon)/(Nnat(lon)+eps),cat(kcomp,1)),cat(kcomp,6)) - xfac(lon) = min(max(xfacin(lon),fac(1)),fac(6)) - xfbc(lon) = min(max(xfbcin(lon),fbc(1)),fbc(6)) - xfaq(lon) = min(max(xfaqin(lon),faq(1)),faq(6)) - - camdiff = xctin(lon)-xct(lon)*(Nnat(lon)+eps) - - cxs(lon) = max(0.0_r8,camdiff) - - ictot=1 - tmp = xct(lon) - do while (ictot.lt.5.and.(tmp.lt.cat(kcomp,ictot).or. & - tmp.gt.cat(kcomp,ictot+1))) - ictot=ictot+1 - enddo - ict1=ictot - ict2=ictot+1 - - ifac=1 - tmp = xfac(lon) - do while (ifac.lt.5.and.(tmp.lt.fac(ifac).or. & - tmp.gt.fac(ifac+1))) - ifac=ifac+1 - enddo - ifac1=ifac - ifac2=ifac+1 - - ifbc=1 - tmp = xfbc(lon) - do while (ifbc.lt.5.and.(tmp.lt.fbc(ifbc).or. & - tmp.gt.fbc(ifbc+1))) - ifbc=ifbc+1 - enddo - ifbc1=ifbc - ifbc2=ifbc+1 - - ifaq=1 - tmp = xfaq(lon) - do while (ifaq.lt.5.and.(tmp.lt.faq(ifaq) & - .or.tmp.gt.faq(ifaq+1))) - ifaq=ifaq+1 - enddo - ifaq1=ifaq - ifaq2=ifaq+1 - -! Collect all the vector elements into temporary storage -! to avoid cache conflicts and excessive cross-referencing - t_cat1 = cat(kcomp,ict1) - t_cat2 = cat(kcomp,ict2) - t_fac1 = fac(ifac1) - t_fac2 = fac(ifac2) - t_fbc1 = fbc(ifbc1) - t_fbc2 = fbc(ifbc2) - t_faq1 = faq(ifaq1) - t_faq2 = faq(ifaq2) - - t_xct = xct(lon) - t_xfac = xfac(lon) - t_xfbc = xfbc(lon) - t_xfaq = xfaq(lon) - -! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_cat2-t_xct) - dxm1(1) = (t_xct-t_cat1) - invd(1) = 1.0_r8/(t_cat2-t_cat1) - d2mx(2) = (t_fac2-t_xfac) - dxm1(2) = (t_xfac-t_fac1) - invd(2) = 1.0_r8/(t_fac2-t_fac1) - d2mx(3) = (t_fbc2-t_xfbc) - dxm1(3) = (t_xfbc-t_fbc1) - invd(3) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(4) = (t_faq2-t_xfaq) - dxm1(4) = (t_xfaq-t_faq1) - invd(4) = 1.0_r8/(t_faq2-t_faq1) - -! Table points as basis for multidimentional linear interpolation, -! modal median radius: - - sizepar4d(1,1,1,1)=rrr(kcomp,ict1,ifac1,ifbc1,ifaq1) - sizepar4d(1,1,1,2)=rrr(kcomp,ict1,ifac1,ifbc1,ifaq2) - sizepar4d(1,1,2,1)=rrr(kcomp,ict1,ifac1,ifbc2,ifaq1) - sizepar4d(1,1,2,2)=rrr(kcomp,ict1,ifac1,ifbc2,ifaq2) - sizepar4d(1,2,1,1)=rrr(kcomp,ict1,ifac2,ifbc1,ifaq1) - sizepar4d(1,2,1,2)=rrr(kcomp,ict1,ifac2,ifbc1,ifaq2) - sizepar4d(1,2,2,1)=rrr(kcomp,ict1,ifac2,ifbc2,ifaq1) - sizepar4d(1,2,2,2)=rrr(kcomp,ict1,ifac2,ifbc2,ifaq2) - sizepar4d(2,1,1,1)=rrr(kcomp,ict2,ifac1,ifbc1,ifaq1) - sizepar4d(2,1,1,2)=rrr(kcomp,ict2,ifac1,ifbc1,ifaq2) - sizepar4d(2,1,2,1)=rrr(kcomp,ict2,ifac1,ifbc2,ifaq1) - sizepar4d(2,1,2,2)=rrr(kcomp,ict2,ifac1,ifbc2,ifaq2) - sizepar4d(2,2,1,1)=rrr(kcomp,ict2,ifac2,ifbc1,ifaq1) - sizepar4d(2,2,1,2)=rrr(kcomp,ict2,ifac2,ifbc1,ifaq2) - sizepar4d(2,2,2,1)=rrr(kcomp,ict2,ifac2,ifbc2,ifaq1) - sizepar4d(2,2,2,2)=rrr(kcomp,ict2,ifac2,ifbc2,ifaq2) - -! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol4dim (d2mx, dxm1, invd, sizepar4d, r1, r2) - -! finally, interpolation in the cat dimension - xrk(lon)=(d2mx(1)*r1+dxm1(1)*r2)*invd(1)*1.e-6_r8 ! look-up table radii in um - -! Table points as basis for multidimentional linear interpolation, -! modal standard deviation: - - sizepar4d(1,1,1,1)=sss(kcomp,ict1,ifac1,ifbc1,ifaq1) - sizepar4d(1,1,1,2)=sss(kcomp,ict1,ifac1,ifbc1,ifaq2) - sizepar4d(1,1,2,1)=sss(kcomp,ict1,ifac1,ifbc2,ifaq1) - sizepar4d(1,1,2,2)=sss(kcomp,ict1,ifac1,ifbc2,ifaq2) - sizepar4d(1,2,1,1)=sss(kcomp,ict1,ifac2,ifbc1,ifaq1) - sizepar4d(1,2,1,2)=sss(kcomp,ict1,ifac2,ifbc1,ifaq2) - sizepar4d(1,2,2,1)=sss(kcomp,ict1,ifac2,ifbc2,ifaq1) - sizepar4d(1,2,2,2)=sss(kcomp,ict1,ifac2,ifbc2,ifaq2) - sizepar4d(2,1,1,1)=sss(kcomp,ict2,ifac1,ifbc1,ifaq1) - sizepar4d(2,1,1,2)=sss(kcomp,ict2,ifac1,ifbc1,ifaq2) - sizepar4d(2,1,2,1)=sss(kcomp,ict2,ifac1,ifbc2,ifaq1) - sizepar4d(2,1,2,2)=sss(kcomp,ict2,ifac1,ifbc2,ifaq2) - sizepar4d(2,2,1,1)=sss(kcomp,ict2,ifac2,ifbc1,ifaq1) - sizepar4d(2,2,1,2)=sss(kcomp,ict2,ifac2,ifbc1,ifaq2) - sizepar4d(2,2,2,1)=sss(kcomp,ict2,ifac2,ifbc2,ifaq1) - sizepar4d(2,2,2,2)=sss(kcomp,ict2,ifac2,ifbc2,ifaq2) - -! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol4dim (d2mx, dxm1, invd, sizepar4d, s1, s2) - -! finally, interpolation in the cat dimension - xstdv(lon)=(d2mx(1)*s1+dxm1(1)*s2)*invd(1) - - end do ! lon - return -end subroutine intlog5to10_sub - -end module intlog5to10 - diff --git a/src/chemistry/oslo_aero/parmix_progncdnc.F90 b/src/chemistry/oslo_aero/parmix_progncdnc.F90 index aa9296ded0..fdbc076bb7 100644 --- a/src/chemistry/oslo_aero/parmix_progncdnc.F90 +++ b/src/chemistry/oslo_aero/parmix_progncdnc.F90 @@ -9,9 +9,7 @@ module parmix_progncdnc use aerosoldef use physconst, only: pi use constituents, only: pcnst, cnst_name - use intlog1to3, only: intlog1to3_sub - use intlog4, only: intlog4_sub - use intlog5to10, only: intlog5to10_sub + use intlog, only : intlog1to3_sub, intlog4_sub, intlog5to10_sub use constituents, only: cnst_name implicit none diff --git a/src/physics/cam_oslo/aerodry_mod.F90 b/src/physics/cam_oslo/aerodry_mod.F90 index 490492bdb7..117e18c058 100644 --- a/src/physics/cam_oslo/aerodry_mod.F90 +++ b/src/physics/cam_oslo/aerodry_mod.F90 @@ -1,29 +1,30 @@ -module aerdry_mod +module aerodry_mod use shr_kind_mod , only: r8 => shr_kind_r8 use ppgrid , only: pcols, pver use commondefinitions , only: nmodes, nbmodes - use opttab , only: cate, cat, fac, faq, fbc, fombg, fbcbg - use optinterpol , only: lininterpol3dim, lininterpol4dim, lininterpol5dim + use opttab , only: cate, cat, fac, faq, fbc, fombg, fbcbg, nbmp1 + use lininterpol_mod , only: lininterpol3dim, lininterpol4dim, lininterpol5dim use oslo_control , only: oslo_getopts, dir_string_length use cam_logfile , only: iulog implicit none private + ! Set by init_dryp Mode0 real(r8) :: a0cintbg, a0cintbg05, a0cintbg125 real(r8) :: a0aaeros, a0aaerol, a0vaeros, a0vaerol - ! Set by init_dryp Mode1 + ! Used by init_dryp Mode1 real(r8) :: a1var(19,6,16,6) - ! Set by init_dryp Mode2to3 + ! Used by init_dryp Mode2to3 real(r8) :: a2to3var(19,16,6,2:3) - ! Set by init_dryp Mode4 + ! Used by init_dryp Mode4 real(r8) :: a4var(19,6,16,6,6) - ! Set by init_dryp Mode5 + ! Used by init_dryp Mode5 real(r8) :: a5to10var(19,6,6,6,6,5:10) type, public :: aerodry_prop_type @@ -48,7 +49,7 @@ module aerdry_mod real(r8) :: cintsa05(pcols,pver,0:nbmodes) real(r8) :: cintsa125(pcols,pver,0:nbmodes) real(r8) :: aaeros(pcols,pver,0:nbmodes) - real(r8) :: aaerol(pcols,pver,0:nbmodes), + real(r8) :: aaerol(pcols,pver,0:nbmodes) real(r8) :: vaeros(pcols,pver,0:nbmodes) real(r8) :: vaerol(pcols,pver,0:nbmodes) @@ -61,7 +62,6 @@ module aerdry_mod real(r8) :: ckngt125(pcols,pver,0:nmodes) contains - procedure :: initdryp procedure :: intdrypar0 procedure :: intdrypar1 procedure :: intdrypar2to3 @@ -72,13 +72,15 @@ module aerdry_mod end type aerodry_prop_type - type(aero_prop_type) :: aerodry_prop + type(aerodry_prop_type), public :: aerodry_prop - ! ========================================================== + public :: initdryp + +! ========================================================== contains - ! ========================================================== +! ========================================================== - subroutine initdryp + subroutine initdryp() !Purpose: To read in the AeroCom look-up tables for calculation of dry ! aerosol size and mass distribution properties. The grid for discrete @@ -95,6 +97,7 @@ subroutine initdryp ! Modified for optimized added masses and mass fractions for concentrations from ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + ! local variables integer :: iv, kcomp, ifombg, ifbcbg, ictot, ifac, ifbc, ifaq integer :: ic, ifil, lin real(r8) :: frombg, frbcbg, catot, frac, fabc, fraq @@ -130,8 +133,6 @@ subroutine initdryp ! Mode 0, BC(ax) !------------------------------------------- ! - ifil = 11 - read(20,996) kcomp, cintbg, cintbg05, cintbg125, aaeros, aaerol, vaeros, vaerol ! no ictot-, ifac-, ifbc- or ifaq-dependency for this mode, @@ -179,25 +180,25 @@ subroutine initdryp ! no ifombg-dependency for this mode, since all catot ! comes from condensate or from wet-phase sulfate - a1var(1,ifombg,ictot,ifac)=cintbg - a1var(2,ifombg,ictot,ifac)=cintbg05 - a1var(3,ifombg,ictot,ifac)=cintbg125 - a1var(4,ifombg,ictot,ifac)=cintbc - a1var(5,ifombg,ictot,ifac)=cintbc05 - a1var(6,ifombg,ictot,ifac)=cintbc125 - a1var(7,ifombg,ictot,ifac)=cintoc - a1var(8,ifombg,ictot,ifac)=cintoc05 - a1var(9,ifombg,ictot,ifac)=cintoc125 - a1var(10,ifombg,ictot,ifac)=cintsc - a1var(11,ifombg,ictot,ifac)=cintsc05 - a1var(12,ifombg,ictot,ifac)=cintsc125 - a1var(13,ifombg,ictot,ifac)=cintsa - a1var(14,ifombg,ictot,ifac)=cintsa05 - a1var(15,ifombg,ictot,ifac)=cintsa125 - a1var(16,ifombg,ictot,ifac)=aaeros - a1var(17,ifombg,ictot,ifac)=aaerol - a1var(18,ifombg,ictot,ifac)=vaeros - a1var(19,ifombg,ictot,ifac)=vaerol + a1var(1,ifombg,ictot,ifac) =cintbg + a1var(2,ifombg,ictot,ifac) =cintbg05 + a1var(3,ifombg,ictot,ifac) =cintbg125 + a1var(4,ifombg,ictot,ifac) =cintbc + a1var(5,ifombg,ictot,ifac) =cintbc05 + a1var(6,ifombg,ictot,ifac) =cintbc125 + a1var(7,ifombg,ictot,ifac) =cintoc + a1var(8,ifombg,ictot,ifac) =cintoc05 + a1var(9,ifombg,ictot,ifac) =cintoc125 + a1var(10,ifombg,ictot,ifac) =cintsc + a1var(11,ifombg,ictot,ifac) =cintsc05 + a1var(12,ifombg,ictot,ifac) =cintsc125 + a1var(13,ifombg,ictot,ifac) =cintsa + a1var(14,ifombg,ictot,ifac) =cintsa05 + a1var(15,ifombg,ictot,ifac) =cintsa125 + a1var(16,ifombg,ictot,ifac) =aaeros + a1var(17,ifombg,ictot,ifac) =aaerol + a1var(18,ifombg,ictot,ifac) =vaeros + a1var(19,ifombg,ictot,ifac) =vaerol if(cintsa2.5um and PM<2.5um (PM2.5) - !akc6+ real(r8) c_tot(pcols,pver), c_tot125(pcols,pver), c_pm25(pcols,pver), & - mmr_pm25(pcols,pver), c_tot05(pcols,pver), c_pm1(pcols,pver), mmr_pm1(pcols,pver) - !akc6- + mmr_pm25(pcols,pver), c_tot05(pcols,pver), c_pm1(pcols,pver), mmr_pm1(pcols,pver) real(r8) aaeros_tot(pcols,pver), aaerol_tot(pcols,pver), vaeros_tot(pcols,pver), & - vaerol_tot(pcols,pver), aaercols(pcols), aaercoll(pcols), vaercols(pcols), & - vaercoll(pcols), derlt05(pcols), dergt05(pcols), der(pcols), & - erlt053d(pcols,pver), ergt053d(pcols,pver), er3d(pcols,pver) + vaerol_tot(pcols,pver), aaercols(pcols), aaercoll(pcols), vaercols(pcols), & + vaercoll(pcols), derlt05(pcols), dergt05(pcols), der(pcols), & + erlt053d(pcols,pver), ergt053d(pcols,pver), er3d(pcols,pver) real(r8) bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & - bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & - beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & - bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes), backsc550x(pcols,pver,nbmp1:nmodes), & - backsc550tot(pcols,pver), ec550_aer(pcols,pver), abs550_aer(pcols,pver), & - bs550_aer(pcols,pver) + bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & + beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & + bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes), backsc550x(pcols,pver,nbmp1:nmodes), & + backsc550tot(pcols,pver), ec550_aer(pcols,pver), abs550_aer(pcols,pver), & + bs550_aer(pcols,pver) ! Additional AeroCom Phase III output: real(r8) asydry_aer(pcols,pver) ! dry asymtot in the visible band ! real(r8) ec550_so4(pcols,pver),ec550_bc(pcols,pver), ec550_pom(pcols,pver), & - ec550_ss(pcols,pver), ec550_du(pcols,pver) + ec550_ss(pcols,pver), ec550_du(pcols,pver) real(r8) bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & - bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & - beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & - bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & - backsc550n(pcols,pver,0:nbmodes) + bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & + beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & + bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & + backsc550n(pcols,pver,0:nbmodes) real(r8) bext440tot(pcols,pver), babs440tot(pcols,pver), & - bext500tot(pcols,pver), babs500tot(pcols,pver), & - bext550tot(pcols,pver), babs550tot(pcols,pver), & - bext670tot(pcols,pver), babs670tot(pcols,pver), & - bext870tot(pcols,pver), babs870tot(pcols,pver), & - bebg440tot(pcols,pver), & - bebg500tot(pcols,pver), & - bebg550tot(pcols,pver), babg550tot(pcols,pver), & - bebg670tot(pcols,pver), & - bebg870tot(pcols,pver), & - bebc440tot(pcols,pver), & - bebc500tot(pcols,pver), & - bebc550tot(pcols,pver), babc550tot(pcols,pver), & - bebc670tot(pcols,pver), & - bebc870tot(pcols,pver), & - beoc440tot(pcols,pver), & - beoc500tot(pcols,pver), & - beoc550tot(pcols,pver), baoc550tot(pcols,pver), & - beoc670tot(pcols,pver), & - beoc870tot(pcols,pver), & - besu440tot(pcols,pver), & - besu500tot(pcols,pver), & - besu550tot(pcols,pver), basu550tot(pcols,pver), & - besu670tot(pcols,pver), & - besu870tot(pcols,pver) + bext500tot(pcols,pver), babs500tot(pcols,pver), & + bext550tot(pcols,pver), babs550tot(pcols,pver), & + bext670tot(pcols,pver), babs670tot(pcols,pver), & + bext870tot(pcols,pver), babs870tot(pcols,pver), & + bebg440tot(pcols,pver), & + bebg500tot(pcols,pver), & + bebg550tot(pcols,pver), babg550tot(pcols,pver), & + bebg670tot(pcols,pver), & + bebg870tot(pcols,pver), & + bebc440tot(pcols,pver), & + bebc500tot(pcols,pver), & + bebc550tot(pcols,pver), babc550tot(pcols,pver), & + bebc670tot(pcols,pver), & + bebc870tot(pcols,pver), & + beoc440tot(pcols,pver), & + beoc500tot(pcols,pver), & + beoc550tot(pcols,pver), baoc550tot(pcols,pver), & + beoc670tot(pcols,pver), & + beoc870tot(pcols,pver), & + besu440tot(pcols,pver), & + besu500tot(pcols,pver), & + besu550tot(pcols,pver), basu550tot(pcols,pver), & + besu670tot(pcols,pver), & + besu870tot(pcols,pver) real(r8) bebglt1t(pcols,pver), bebggt1t(pcols,pver), bebclt1t(pcols,pver), & - bebcgt1t(pcols,pver), beoclt1t(pcols,pver), beocgt1t(pcols,pver), & - bes4lt1t(pcols,pver), bes4gt1t(pcols,pver) + bebcgt1t(pcols,pver), beoclt1t(pcols,pver), beocgt1t(pcols,pver), & + bes4lt1t(pcols,pver), bes4gt1t(pcols,pver) real(r8) be440x(pcols,pver,nbmp1:nmodes), ba440x(pcols,pver,nbmp1:nmodes), & - be500x(pcols,pver,nbmp1:nmodes), ba500x(pcols,pver,nbmp1:nmodes), & - be550x(pcols,pver,nbmp1:nmodes), ba550x(pcols,pver,nbmp1:nmodes), & - be670x(pcols,pver,nbmp1:nmodes), ba670x(pcols,pver,nbmp1:nmodes), & - be870x(pcols,pver,nbmp1:nmodes), ba870x(pcols,pver,nbmp1:nmodes), & - belt1x(pcols,pver,nbmp1:nmodes), begt1x(pcols,pver,nbmp1:nmodes) - - real(r8) bebc440xt(pcols,pver), & - bebc500xt(pcols,pver), & - bebc550xt(pcols,pver),babc550xt(pcols,pver), & - bebc670xt(pcols,pver), & - bebc870xt(pcols,pver), & - beoc440xt(pcols,pver), & - beoc500xt(pcols,pver), & - beoc550xt(pcols,pver),baoc550xt(pcols,pver), & - beoc670xt(pcols,pver), & - beoc870xt(pcols,pver) + be500x(pcols,pver,nbmp1:nmodes), ba500x(pcols,pver,nbmp1:nmodes), & + be550x(pcols,pver,nbmp1:nmodes), ba550x(pcols,pver,nbmp1:nmodes), & + be670x(pcols,pver,nbmp1:nmodes), ba670x(pcols,pver,nbmp1:nmodes), & + be870x(pcols,pver,nbmp1:nmodes), ba870x(pcols,pver,nbmp1:nmodes), & + belt1x(pcols,pver,nbmp1:nmodes), begt1x(pcols,pver,nbmp1:nmodes) + + real(r8) bebc440xt(pcols,pver),babc440xt(pcols,pver), & + bebc500xt(pcols,pver),babc500xt(pcols,pver), & + bebc550xt(pcols,pver),babc550xt(pcols,pver), & + bebc670xt(pcols,pver),babc670xt(pcols,pver), & + bebc870xt(pcols,pver),babc870xt(pcols,pver), & + beoc440xt(pcols,pver),baoc440xt(pcols,pver), & + beoc500xt(pcols,pver),baoc500xt(pcols,pver), & + beoc550xt(pcols,pver),baoc550xt(pcols,pver), & + beoc670xt(pcols,pver),baoc670xt(pcols,pver), & + beoc870xt(pcols,pver),baoc870xt(pcols,pver) + real(r8) bbclt1xt(pcols,pver), & - bbcgt1xt(pcols,pver), boclt1xt(pcols,pver), bocgt1xt(pcols,pver) + bbcgt1xt(pcols,pver), boclt1xt(pcols,pver), bocgt1xt(pcols,pver) + real(r8) bint440du(pcols,pver), bint500du(pcols,pver), bint550du(pcols,pver), & - bint670du(pcols,pver), bint870du(pcols,pver), & - bint440ss(pcols,pver), bint500ss(pcols,pver), bint550ss(pcols,pver), & - bint670ss(pcols,pver), bint870ss(pcols,pver), & - baint550du(pcols,pver), baint550ss(pcols,pver) + bint670du(pcols,pver), bint870du(pcols,pver), & + bint440ss(pcols,pver), bint500ss(pcols,pver), bint550ss(pcols,pver), & + bint670ss(pcols,pver), bint870ss(pcols,pver), & + baint550du(pcols,pver), baint550ss(pcols,pver) + real(r8) bedustlt1(pcols,pver), bedustgt1(pcols,pver), & - besslt1(pcols,pver), bessgt1(pcols,pver) + besslt1(pcols,pver), bessgt1(pcols,pver) + real(r8) dod4403d(pcols,pver), abs4403d(pcols,pver), & - dod4403d_ss(pcols,pver), & ! abs4403d_ss(pcols,pver), & - dod4403d_dust(pcols,pver), & ! abs4403d_dust(pcols,pver), & - dod4403d_so4(pcols,pver), & ! abs4403d_so4(pcols,pver), & - dod4403d_bc(pcols,pver), & ! abs4403d_bc(pcols,pver), & - dod4403d_pom(pcols,pver), & ! abs4403d_pom(pcols,pver), & - dod5003d(pcols,pver), abs5003d(pcols,pver), & - dod5003d_ss(pcols,pver), & ! abs5003d_ss(pcols,pver), & - dod5003d_dust(pcols,pver), & ! abs5003d_dust(pcols,pver), & - dod5003d_so4(pcols,pver), & ! abs5003d_so4(pcols,pver), & - dod5003d_bc(pcols,pver), & ! abs5003d_bc(pcols,pver), & - dod5003d_pom(pcols,pver), & ! abs5003d_pom(pcols,pver), & - dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver), & - dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver), & - dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver), & - dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver), & - dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver), & - dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver), & - dod6703d(pcols,pver), abs6703d(pcols,pver), & - dod6703d_ss(pcols,pver), & ! abs6703d_ss(pcols,pver), & - dod6703d_dust(pcols,pver), & ! abs6703d_dust(pcols,pver), & - dod6703d_so4(pcols,pver), & ! abs6703d_so4(pcols,pver), & - dod6703d_bc(pcols,pver), & ! abs6703d_bc(pcols,pver), & - dod6703d_pom(pcols,pver), & ! abs6703d_pom(pcols,pver), & - dod8703d(pcols,pver), abs8703d(pcols,pver), & - dod8703d_ss(pcols,pver), & ! abs8703d_ss(pcols,pver), & - dod8703d_dust(pcols,pver), & ! abs8703d_dust(pcols,pver), & - dod8703d_so4(pcols,pver), & ! abs8703d_so4(pcols,pver), & - dod8703d_bc(pcols,pver), & ! abs8703d_bc(pcols,pver), & - dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) + dod4403d_ss(pcols,pver), & ! abs4403d_ss(pcols,pver), & + dod4403d_dust(pcols,pver), & ! abs4403d_dust(pcols,pver), & + dod4403d_so4(pcols,pver), & ! abs4403d_so4(pcols,pver), & + dod4403d_bc(pcols,pver), & ! abs4403d_bc(pcols,pver), & + dod4403d_pom(pcols,pver), & ! abs4403d_pom(pcols,pver), & + dod5003d(pcols,pver), abs5003d(pcols,pver), & + dod5003d_ss(pcols,pver), & ! abs5003d_ss(pcols,pver), & + dod5003d_dust(pcols,pver), & ! abs5003d_dust(pcols,pver), & + dod5003d_so4(pcols,pver), & ! abs5003d_so4(pcols,pver), & + dod5003d_bc(pcols,pver), & ! abs5003d_bc(pcols,pver), & + dod5003d_pom(pcols,pver), & ! abs5003d_pom(pcols,pver), & + dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver), & + dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver), & + dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver), & + dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver), & + dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver), & + dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver), & + dod6703d(pcols,pver), abs6703d(pcols,pver), & + dod6703d_ss(pcols,pver), & ! abs6703d_ss(pcols,pver), & + dod6703d_dust(pcols,pver), & ! abs6703d_dust(pcols,pver), & + dod6703d_so4(pcols,pver), & ! abs6703d_so4(pcols,pver), & + dod6703d_bc(pcols,pver), & ! abs6703d_bc(pcols,pver), & + dod6703d_pom(pcols,pver), & ! abs6703d_pom(pcols,pver), & + dod8703d(pcols,pver), abs8703d(pcols,pver), & + dod8703d_ss(pcols,pver), & ! abs8703d_ss(pcols,pver), & + dod8703d_dust(pcols,pver), & ! abs8703d_dust(pcols,pver), & + dod8703d_so4(pcols,pver), & ! abs8703d_so4(pcols,pver), & + dod8703d_bc(pcols,pver), & ! abs8703d_bc(pcols,pver), & + dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) + real(r8) dod5503dlt1_ss(pcols,pver), dod5503dgt1_ss(pcols,pver), & dod5503dlt1_dust(pcols,pver), dod5503dgt1_dust(pcols,pver), & dod5503dlt1_so4(pcols,pver), dod5503dgt1_so4(pcols,pver), & @@ -340,7 +337,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & dod550gt1_so4(pcols), dod550lt1_bc(pcols), dod550gt1_bc(pcols), & dod550lt1_pom(pcols), dod550gt1_pom(pcols) real(r8) abs550_ss(pcols), abs550_dust(pcols), & - abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) + abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) character(len=10) :: modeString character(len=20) :: varname @@ -1045,17 +1042,9 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & dload(icol,i)=0.0_r8 enddo enddo - bext550n(:,:,:) = 0._r8 - babs550n(:,:,:) = 0._r8 - bext440n(:,:,:) = 0._r8 - babs440n(:,:,:) = 0._r8 - bext870n(:,:,:) = 0._r8 - babs870n(:,:,:) = 0._r8 - babs500n(:,:,:) = 0._r8 - babs670n(:,:,:) = 0._r8 - vnbcarr(:,:) =0.0_r8 - vaitbcarr(:,:) =0.0_r8 - cknorm(:,:,:) =0.0_r8 + vnbcarr(:,:) = 0.0_r8 + vaitbcarr(:,:) = 0.0_r8 + cknorm(:,:,:) = 0.0_r8 !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 ! AeroCom diagnostics requiring table look-ups with ambient RH. @@ -1132,82 +1121,64 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & do k=1,pver do icol=1,ncol ! total internal extinction and absorption for 0.44, 0.50, 0.55, 0.68 and 0.87 um - bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*bext440(icol,k,i) - babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i) - bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*bext500(icol,k,i) - babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i) - bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*bext550(icol,k,i) - babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i) - bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*bext670(icol,k,i) - babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i) - bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*bext870(icol,k,i) - babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i) - backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*backsc550(icol,k,i) + bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext440(icol,k,i) + babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i) + bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext500(icol,k,i) + babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs500(icol,k,i) + bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext550(icol,k,i) + babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i) + bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext670(icol,k,i) + babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs670(icol,k,i) + bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext870(icol,k,i) + babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i) + backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%backsc550(icol,k,i) ! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um ! for the whole background aerosol (icluding SO4,BC, and OC for modes 0-5) - bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*bebg440(icol,k,i) - bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*bebg500(icol,k,i) - bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*bebg550(icol,k,i) - babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*babg550(icol,k,i) - bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*bebg670(icol,k,i) - bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*bebg870(icol,k,i) - besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*besu440(icol,k,i) - besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*besu500(icol,k,i) - besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*besu550(icol,k,i) - basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*basu550(icol,k,i) - besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*besu670(icol,k,i) - besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*besu870(icol,k,i) + bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg440(icol,k,i) + bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg500(icol,k,i) + bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg550(icol,k,i) + babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babg550(icol,k,i) + bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg670(icol,k,i) + bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg870(icol,k,i) + besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu440(icol,k,i) + besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu500(icol,k,i) + besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu550(icol,k,i) + basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%basu550(icol,k,i) + besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu670(icol,k,i) + besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu870(icol,k,i) ! ! Condensed OC on modes 1-4 and coagulated BC and OC on modes 5-10: if(i>=1) then - bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i)*bebc440(icol,k,i) - ! babc440tot(icol,k)=babc440tot(icol,k)+Nnatk(icol,k,i)*babc440(icol,k,i) - bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i)*bebc500(icol,k,i) - ! babc500tot(icol,k)=babc500tot(icol,k)+Nnatk(icol,k,i)*babc500(icol,k,i) - bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i)*bebc550(icol,k,i) - babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i)*babc550(icol,k,i) - bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i)*bebc670(icol,k,i) - ! babc670tot(icol,k)=babc670tot(icol,k)+Nnatk(icol,k,i)*babc670(icol,k,i) - bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i)*bebc870(icol,k,i) - ! babc870tot(icol,k)=babc870tot(icol,k)+Nnatk(icol,k,i)*babc870(icol,k,i) - beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i)*beoc440(icol,k,i) - ! baoc440tot(icol,k)=baoc440tot(icol,k)+Nnatk(icol,k,i)*baoc440(icol,k,i) - beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i)*beoc500(icol,k,i) - ! baoc500tot(icol,k)=baoc500tot(icol,k)+Nnatk(icol,k,i)*baoc500(icol,k,i) - beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i)*beoc550(icol,k,i) - baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i)*baoc550(icol,k,i) - beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i)*beoc670(icol,k,i) - ! baoc670tot(icol,k)=baoc670tot(icol,k)+Nnatk(icol,k,i)*baoc670(icol,k,i) - beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i)*beoc870(icol,k,i) - ! baoc870tot(icol,k)=baoc870tot(icol,k)+Nnatk(icol,k,i)*baoc870(icol,k,i) + bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc440(icol,k,i) + bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc500(icol,k,i) + bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc550(icol,k,i) + babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babc550(icol,k,i) + bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc670(icol,k,i) + bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc870(icol,k,i) + beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc440(icol,k,i) + beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc500(icol,k,i) + beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc550(icol,k,i) + baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%baoc550(icol,k,i) + beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc670(icol,k,i) + beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc870(icol,k,i) endif ! i>=1 if(i==6.or.i==7) then - bedustlt1(icol,k)=bedustlt1(icol,k) & - +Nnatk(icol,k,i)*bebglt1(icol,k,i) - bedustgt1(icol,k)=bedustgt1(icol,k) & - +Nnatk(icol,k,i)*bebggt1(icol,k,i) + bedustlt1(icol,k)=bedustlt1(icol,k) +Nnatk(icol,k,i)*bebglt1(icol,k,i) + bedustgt1(icol,k)=bedustgt1(icol,k) +Nnatk(icol,k,i)*bebggt1(icol,k,i) elseif(i>=8.and.i<=10) then - besslt1(icol,k)=besslt1(icol,k) & - +Nnatk(icol,k,i)*bebglt1(icol,k,i) - bessgt1(icol,k)=bessgt1(icol,k) & - +Nnatk(icol,k,i)*bebggt1(icol,k,i) + besslt1(icol,k)=besslt1(icol,k) +Nnatk(icol,k,i)*bebglt1(icol,k,i) + bessgt1(icol,k)=bessgt1(icol,k) +Nnatk(icol,k,i)*bebggt1(icol,k,i) endif ! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: - bes4lt1t(icol,k)=bes4lt1t(icol,k) & - +Nnatk(icol,k,i)*bes4lt1(icol,k,i) - bes4gt1t(icol,k)=bes4gt1t(icol,k) & - +Nnatk(icol,k,i)*bes4gt1(icol,k,i) + bes4lt1t(icol,k)=bes4lt1t(icol,k) +Nnatk(icol,k,i)*bes4lt1(icol,k,i) + bes4gt1t(icol,k)=bes4gt1t(icol,k) +Nnatk(icol,k,i)*bes4gt1(icol,k,i) ! Condensed OC on mode 1 and coagulated BC and OC on modes 5-10: if(i>=1) then - bebclt1t(icol,k)=bebclt1t(icol,k) & - +Nnatk(icol,k,i)*bebclt1(icol,k,i) - bebcgt1t(icol,k)=bebcgt1t(icol,k) & - +Nnatk(icol,k,i)*bebcgt1(icol,k,i) - beoclt1t(icol,k)=beoclt1t(icol,k) & - +Nnatk(icol,k,i)*beoclt1(icol,k,i) - beocgt1t(icol,k)=beocgt1t(icol,k) & - +Nnatk(icol,k,i)*beocgt1(icol,k,i) + bebclt1t(icol,k)=bebclt1t(icol,k) +Nnatk(icol,k,i)*bebclt1(icol,k,i) + bebcgt1t(icol,k)=bebcgt1t(icol,k) +Nnatk(icol,k,i)*bebcgt1(icol,k,i) + beoclt1t(icol,k)=beoclt1t(icol,k) +Nnatk(icol,k,i)*beoclt1(icol,k,i) + beocgt1t(icol,k)=beocgt1t(icol,k) +Nnatk(icol,k,i)*beocgt1(icol,k,i) endif ! i>=1 end do ! icol enddo ! k @@ -1217,55 +1188,65 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & ! in the internal mixture are do k=1,pver do icol=1,ncol - bint440du(icol,k)=Nnatk(icol,k,6)*bebg440(icol,k,6) & - +Nnatk(icol,k,7)*bebg440(icol,k,7) - bint500du(icol,k)=Nnatk(icol,k,6)*bebg500(icol,k,6) & - +Nnatk(icol,k,7)*bebg500(icol,k,7) - bint550du(icol,k)=Nnatk(icol,k,6)*bebg550(icol,k,6) & - +Nnatk(icol,k,7)*bebg550(icol,k,7) - bint670du(icol,k)=Nnatk(icol,k,6)*bebg670(icol,k,6) & - +Nnatk(icol,k,7)*bebg670(icol,k,7) - bint870du(icol,k)=Nnatk(icol,k,6)*bebg870(icol,k,6) & - +Nnatk(icol,k,7)*bebg870(icol,k,7) - bint440ss(icol,k)=Nnatk(icol,k,8)*bebg440(icol,k,8) & - +Nnatk(icol,k,9)*bebg440(icol,k,9) & - +Nnatk(icol,k,10)*bebg440(icol,k,10) - bint500ss(icol,k)=Nnatk(icol,k,8)*bebg500(icol,k,8) & - +Nnatk(icol,k,9)*bebg500(icol,k,9) & - +Nnatk(icol,k,10)*bebg500(icol,k,10) - bint550ss(icol,k)=Nnatk(icol,k,8)*bebg550(icol,k,8) & - +Nnatk(icol,k,9)*bebg550(icol,k,9) & - +Nnatk(icol,k,10)*bebg550(icol,k,10) - bint670ss(icol,k)=Nnatk(icol,k,8)*bebg670(icol,k,8) & - +Nnatk(icol,k,9)*bebg670(icol,k,9) & - +Nnatk(icol,k,10)*bebg670(icol,k,10) - bint870ss(icol,k)=Nnatk(icol,k,8)*bebg870(icol,k,8) & - +Nnatk(icol,k,9)*bebg870(icol,k,9) & - +Nnatk(icol,k,10)*bebg870(icol,k,10) - baint550du(icol,k)=Nnatk(icol,k,6)*babg550(icol,k,6) & - +Nnatk(icol,k,7)*babg550(icol,k,7) - baint550ss(icol,k)=Nnatk(icol,k,8)*babg550(icol,k,8) & - +Nnatk(icol,k,9)*babg550(icol,k,9) & - +Nnatk(icol,k,10)*babg550(icol,k,10) + bint440du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg440(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg440(icol,k,7) + bint500du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg500(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg500(icol,k,7) + bint550du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg550(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg550(icol,k,7) + bint670du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg670(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg670(icol,k,7) + bint870du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg870(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg870(icol,k,7) + bint440ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg440(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg440(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg440(icol,k,10) + bint500ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg500(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg500(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg500(icol,k,10) + bint550ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg550(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg550(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg550(icol,k,10) + bint670ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg670(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg670(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg670(icol,k,10) + bint870ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg870(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg870(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg870(icol,k,10) + baint550du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%babg550(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%babg550(icol,k,7) + baint550ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%babg550(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%babg550(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%babg550(icol,k,10) end do enddo + ! Need to make the following substitutions + ! bebglt1 bebglt1n => extinction_coeffs%bebg550lt1 + ! bebggt1 bebggt1n => extinction_coeffs%bebg550gt1 + ! bebclt1 bebclt1n => extinction_coeffs%bebc550lt1 + ! bebcgt1 bebcgt1n => extinction_coeffs%bebc550gt1 + ! beoclt1 beoclt1n => extinction_coeffs%beoc550lt1 + ! beocgt1 beocgt1n => extinction_coeffs%beoc550gt1 + ! bes4lt1 bes4lt1n => extinction_coeffs%besu550lt1 + ! bes4gt1 bes4gt1n => extinction_coeffs%besu550gt1 + do i=11,14 do k=1,pver do icol=1,ncol - be440x(icol,k,i)=bext440n(icol,k,i-10) - ba440x(icol,k,i)=babs440n(icol,k,i-10) - be500x(icol,k,i)=bext500n(icol,k,i-10) - ba500x(icol,k,i)=babs500n(icol,k,i-10) - be550x(icol,k,i)=bext550n(icol,k,i-10) - ba550x(icol,k,i)=babs550n(icol,k,i-10) - be670x(icol,k,i)=bext670n(icol,k,i-10) - ba670x(icol,k,i)=babs670n(icol,k,i-10) - be870x(icol,k,i)=bext870n(icol,k,i-10) - ba870x(icol,k,i)=babs870n(icol,k,i-10) - belt1x(icol,k,i)=bebglt1n(icol,k,i-10) - begt1x(icol,k,i)=bebggt1n(icol,k,i-10) - backsc550x(icol,k,i)=backsc550n(icol,k,i-10) + be440x(icol,k,i) = extinction_coeffsn%bext440(icol,k,i-10) + ba440x(icol,k,i) = extinction_coeffsn%babs440(icol,k,i-10) + be500x(icol,k,i) = extinction_coeffsn%bext500(icol,k,i-10) + ba500x(icol,k,i) = extinction_coeffsn%babs500(icol,k,i-10) + be550x(icol,k,i) = extinction_coeffsn%bext550(icol,k,i-10) + ba550x(icol,k,i) = extinction_coeffsn%babs550(icol,k,i-10) + be670x(icol,k,i) = extinction_coeffsn%bext670(icol,k,i-10) + ba670x(icol,k,i) = extinction_coeffsn%babs670(icol,k,i-10) + be870x(icol,k,i) = extinction_coeffsn%bext870(icol,k,i-10) + ba870x(icol,k,i) = extinction_coeffsn%babs870(icol,k,i-10) + belt1x(icol,k,i) = extinction_coeffsn%bebg550lt1(icol,k,i-10) + begt1x(icol,k,i) = extinction_coeffsn%bebg550gt1(icol,k,i-10) + backsc550x(icol,k,i) = extinction_coeffsn%backsc550(icol,k,i-10) end do enddo enddo @@ -1279,29 +1260,29 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & +(1.0_r8-fnbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) vnbc = vnbcarr(icol,k) bebc440xt(icol,k) =Nnatk(icol,k,12)*be440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) babc440xt(icol,k) =Nnatk(icol,k,12)*ba440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) bebc500xt(icol,k) =Nnatk(icol,k,12)*be500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) babc500xt(icol,k) =Nnatk(icol,k,12)*ba500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) bebc550xt(icol,k) =Nnatk(icol,k,12)*be550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) babc550xt(icol,k) =Nnatk(icol,k,12)*ba550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) bebc670xt(icol,k) =Nnatk(icol,k,12)*be670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) babc670xt(icol,k) =Nnatk(icol,k,12)*ba670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) bebc870xt(icol,k) =Nnatk(icol,k,12)*be870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) babc870xt(icol,k) =Nnatk(icol,k,12)*ba870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) bbclt1xt(icol,k)=Nnatk(icol,k,12)*belt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) bbcgt1xt(icol,k)=Nnatk(icol,k,12)*begt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) + +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) !OC beoc440xt(icol,k) = & +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be440x(icol,k,14) @@ -1430,78 +1411,72 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & !SO4 !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 dod4403d_so4(icol,k) = (besu440tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) dod5003d_so4(icol,k) = (besu500tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) dod5503d_so4(icol,k) = (besu550tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) abs5503d_so4(icol,k) = (basu550tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*babg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) dod6703d_so4(icol,k) = (besu670tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) dod8703d_so4(icol,k) = (besu870tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) !BC vaitbcarr(icol,k) = faitbc(icol,k)/(faitbc(icol,k) & +(1.0_r8-faitbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) vaitbc = vaitbcarr(icol,k) dod4403d_bc(icol,k) = (bebc440tot(icol,k)+bebc440xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg440(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) + + Nnatk(icol,k,2)*extinction_coeffs%bebg440(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) dod5003d_bc(icol,k) = (bebc500tot(icol,k)+bebc500xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg500(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) + + Nnatk(icol,k,2)*extinction_coeffs%bebg500(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) dod5503d_bc(icol,k) = (bebc550tot(icol,k)+bebc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + + Nnatk(icol,k,2)*extinction_coeffs%bebg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) abs5503d_bc(icol,k) = (babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*babg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + + Nnatk(icol,k,2)*extinction_coeffs%babg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) dod6703d_bc(icol,k) = (bebc670tot(icol,k)+bebc670xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg670(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) + + Nnatk(icol,k,2)*extinction_coeffs%bebg670(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) dod8703d_bc(icol,k) = (bebc870tot(icol,k)+bebc870xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebg870(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) + + Nnatk(icol,k,2)*extinction_coeffs%bebg870(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) !OC !soa + v_soana part of mode 11 for the OC volume fraction of that mode ! v_soana(icol,k) dod4403d_pom(icol,k) = (beoc440tot(icol,k)+beoc440xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*bebg440(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg440(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*extinction_coeffs%bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg440(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) dod5003d_pom(icol,k) = (beoc500tot(icol,k)+beoc500xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*bebg500(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg500(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*extinction_coeffs%bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg500(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) dod5503d_pom(icol,k) = (beoc550tot(icol,k)+beoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*bebg550(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*extinction_coeffs%bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) abs5503d_pom(icol,k) = (baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*babg550(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*babg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) dod6703d_pom(icol,k) = (beoc670tot(icol,k)+beoc670xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*bebg670(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg670(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*extinction_coeffs%bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg670(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) dod8703d_pom(icol,k) = (beoc870tot(icol,k)+beoc870xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*bebg870(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebg870(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*extinction_coeffs%bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg870(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) ec550_so4(icol,k) = 1.e-3*dod5503d_so4(icol,k)/deltah ec550_bc(icol,k) = 1.e-3*dod5503d_bc(icol,k)/deltah @@ -1534,18 +1509,18 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & ! (Note: Local abs550alt is up to 6% larger (annually averaged) in typical b.b. ! regions, compared to abs550. This is most likely most correct, but should be checked!) do i=0,10 - abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440(icol,k,i)*deltah - abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500(icol,k,i)*deltah - abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670(icol,k,i)*deltah - abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870(icol,k,i)*deltah - abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550(icol,k,i)*deltah + abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i)*deltah + abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs500(icol,k,i)*deltah + abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs670(icol,k,i)*deltah + abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i)*deltah + abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i)*deltah enddo do i=11,14 - abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*babs440n(icol,k,i-10)*deltah - abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*babs500n(icol,k,i-10)*deltah - abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*babs670n(icol,k,i-10)*deltah - abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*babs870n(icol,k,i-10)*deltah - abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*babs550n(icol,k,i-10)*deltah + abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs440(icol,k,i-10)*deltah + abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs500(icol,k,i-10)*deltah + abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs670(icol,k,i-10)*deltah + abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs870(icol,k,i-10)*deltah + abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs550(icol,k,i-10)*deltah enddo !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc ! optical depths for d<1um and d>1um (r<0.5um and r>0.5um) @@ -1743,39 +1718,20 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & ! Dry parameters of each aerosol component ! BC(ax) mode - call intdrypar0(lchnk, ncol, Nnatk, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - cknorm,cknlt05,ckngt125) + call aerodry_prop%intdrypar0(lchnk, ncol, Nnatk) + ! SO4&SOA(Ait,n) mode - call intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, & - xct, ict1, xfac, ifac1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) + call aerodry_prop%intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) + ! BC(Ait,n) and OC(Ait,n) modes - call intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) + call aerodry_prop%intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1) + ! BC&OC(Ait,n) mode ------ fcm not valid here (=0). Use faitbc or fnbc instead - call intdrypar4(lchnk, ncol, Nnatk, & - xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & - xct, ict1, xfac, ifac1, xfaq, ifaq1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol, & - aaerosn,aaeroln,vaerosn,vaeroln,cknorm,cknlt05,ckngt125) + call aerodry_prop%intdrypar4(lchnk, ncol, Nnatk, xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & + xct, ict1, xfac, ifac1, xfaq, ifaq1) + ! SO4(Ait75) (5), mineral (6-7) and Sea-salt (8-10) modes: - call intdrypar5to10(lchnk, ncol, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol,& - cknorm,cknlt05,ckngt125) + call aerodry_prop%intdrypar5to10(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) do k=1,pver do icol=1,ncol @@ -1786,22 +1742,23 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & do k=1,pver do icol=1,ncol - ! mineral and sea-salt background concentrations, internally mixed - c_mi(icol,k) = Nnatk(icol,k,6)*cintbg(icol,k,6) & - +Nnatk(icol,k,7)*cintbg(icol,k,7) - c_mi05(icol,k) = Nnatk(icol,k,6)*cintbg05(icol,k,6) & - +Nnatk(icol,k,7)*cintbg05(icol,k,7) - c_mi125(icol,k) = Nnatk(icol,k,6)*cintbg125(icol,k,6)& - +Nnatk(icol,k,7)*cintbg125(icol,k,7) - c_ss(icol,k) = Nnatk(icol,k,8)*cintbg(icol,k,8) & - +Nnatk(icol,k,9)*cintbg(icol,k,9) & - +Nnatk(icol,k,10)*cintbg(icol,k,10) - c_ss05(icol,k) = Nnatk(icol,k,8)*cintbg05(icol,k,8) & - +Nnatk(icol,k,9)*cintbg05(icol,k,9) & - +Nnatk(icol,k,10)*cintbg05(icol,k,10) - c_ss125(icol,k) = Nnatk(icol,k,8)*cintbg125(icol,k,8)& - +Nnatk(icol,k,9)*cintbg125(icol,k,9) & - +Nnatk(icol,k,10)*cintbg125(icol,k,10) + ! mineral and sea-salt background concentrations, internally mixed + c_mi(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg(icol,k,6) & + +Nnatk(icol,k,7) * aerodry_prop%cintbg(icol,k,7) + c_mi05(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg05(icol,k,6) & + +Nnatk(icol,k,7) * aerodry_prop%cintbg05(icol,k,7) + c_mi125(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg125(icol,k,6)& + +Nnatk(icol,k,7) * aerodry_prop%cintbg125(icol,k,7) + c_ss(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg(icol,k,8) & + +Nnatk(icol,k,9) * aerodry_prop%cintbg(icol,k,9) & + +Nnatk(icol,k,10) * aerodry_prop%cintbg(icol,k,10) + c_ss05(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg05(icol,k,8) & + +Nnatk(icol,k,9) * aerodry_prop%cintbg05(icol,k,9) & + +Nnatk(icol,k,10) * aerodry_prop%cintbg05(icol,k,10) + c_ss125(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg125(icol,k,8)& + +Nnatk(icol,k,9) * aerodry_prop%cintbg125(icol,k,9) & + +Nnatk(icol,k,10) * aerodry_prop%cintbg125(icol,k,10) + ! internally mixed bc and oc (from coagulation) and so4 concentrations ! (sa=so4(aq) and sc=so4(cond+coag), separated because of different density: ! necessary for calculation of volume fractions!), and total aerosol surface @@ -1833,7 +1790,6 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & c_bc_14(icol,k)=0.0_r8 c_oc_4(icol,k)=0.0_r8 c_oc_14(icol,k)=0.0_r8 - !akc6+ c_tot(icol,k)=0.0_r8 c_tot125(icol,k)=0.0_r8 c_tot05(icol,k)=0.0_r8 @@ -1841,64 +1797,42 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & c_pm1(icol,k)=0.0_r8 mmr_pm25(icol,k)=0.0_r8 mmr_pm1(icol,k)=0.0_r8 - !akc6- do i=0,nbmodes if(i.ne.3) then - c_bc(icol,k) = c_bc(icol,k) & - +Nnatk(icol,k,i)*cintbc(icol,k,i) - c_bc05(icol,k) = c_bc05(icol,k) & - +Nnatk(icol,k,i)*cintbc05(icol,k,i) - c_bc125(icol,k) = c_bc125(icol,k) & - +Nnatk(icol,k,i)*cintbc125(icol,k,i) - c_oc(icol,k) = c_oc(icol,k) & - +Nnatk(icol,k,i)*cintoc(icol,k,i) - c_oc05(icol,k) = c_oc05(icol,k) & - +Nnatk(icol,k,i)*cintoc05(icol,k,i) - c_oc125(icol,k) = c_oc125(icol,k) & - +Nnatk(icol,k,i)*cintoc125(icol,k,i) - c_sa(icol,k) = c_sa(icol,k) & - +Nnatk(icol,k,i)*cintsa(icol,k,i) - c_sa05(icol,k) = c_sa05(icol,k) & - +Nnatk(icol,k,i)*cintsa05(icol,k,i) - c_sa125(icol,k) = c_sa125(icol,k) & - +Nnatk(icol,k,i)*cintsa125(icol,k,i) - c_sc(icol,k) = c_sc(icol,k) & - +Nnatk(icol,k,i)*cintsc(icol,k,i) - c_sc05(icol,k) = c_sc05(icol,k) & - +Nnatk(icol,k,i)*cintsc05(icol,k,i) - c_sc125(icol,k) = c_sc125(icol,k) & - +Nnatk(icol,k,i)*cintsc125(icol,k,i) - aaeros_tot(icol,k) = aaeros_tot(icol,k) & - +Nnatk(icol,k,i)*aaeros(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) & - +Nnatk(icol,k,i)*aaerol(icol,k,i) - vaeros_tot(icol,k) =vaeros_tot(icol,k) & - +Nnatk(icol,k,i)*vaeros(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) & - +Nnatk(icol,k,i)*vaerol(icol,k,i) + c_bc(icol,k) = c_bc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc(icol,k,i) + c_bc05(icol,k) = c_bc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc05(icol,k,i) + c_bc125(icol,k) = c_bc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc125(icol,k,i) + c_oc(icol,k) = c_oc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc(icol,k,i) + c_oc05(icol,k) = c_oc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc05(icol,k,i) + c_oc125(icol,k) = c_oc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc125(icol,k,i) + c_sa(icol,k) = c_sa(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa(icol,k,i) + c_sa05(icol,k) = c_sa05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa05(icol,k,i) + c_sa125(icol,k) = c_sa125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa125(icol,k,i) + c_sc(icol,k) = c_sc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc(icol,k,i) + c_sc05(icol,k) = c_sc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc05(icol,k,i) + c_sc125(icol,k) = c_sc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc125(icol,k,i) + aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeros(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerol(icol,k,i) + vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeros(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerol(icol,k,i) endif enddo ! add dry aerosol area and volume of externally mixed modes do i=nbmp1,nmodes - aaeros_tot(icol,k) = aaeros_tot(icol,k) & - +Nnatk(icol,k,i)*aaerosn(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) & - +Nnatk(icol,k,i)*aaeroln(icol,k,i) - vaeros_tot(icol,k) =vaeros_tot(icol,k) & - +Nnatk(icol,k,i)*vaerosn(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) & - +Nnatk(icol,k,i)*vaeroln(icol,k,i) + aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerosn(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeroln(icol,k,i) + vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerosn(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeroln(icol,k,i) end do + !c_er3d ! Effective radii for particles smaller and greater than 0.5um, ! and for all radii, in each layer (er=3*V/A): - erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) & - /(aaeros_tot(icol,k)+eps) - ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) & - /(aaerol_tot(icol,k)+eps) - er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) & - /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) + erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) /(aaeros_tot(icol,k)+eps) + ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) /(aaerol_tot(icol,k)+eps) + er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) + !c_er3d ! column integrated dry aerosol surface areas and volumes ! for r<0.5um and r>0.5um (s and l, respectively). @@ -1906,72 +1840,66 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & aaercoll(icol)=aaercoll(icol)+aaerol_tot(icol,k) vaercols(icol)=vaercols(icol)+vaeros_tot(icol,k) vaercoll(icol)=vaercoll(icol)+vaerol_tot(icol,k) + ! then add background and externally mixed BC, OC and SO4 to mass concentrations c_bc_ac(icol,k)= c_bc(icol,k) - c_bc_0(icol,k) = Nnatk(icol,k,0)*cintbg(icol,k,0) - c_bc_2(icol,k) = Nnatk(icol,k,2)*cintbg(icol,k,2) - c_bc_4(icol,k) = Nnatk(icol,k,4)*cintbg(icol,k,4)*faitbc(icol,k) - c_bc_12(icol,k)= Nnatk(icol,k,12)*cknorm(icol,k,12) - c_bc_14(icol,k)= Nnatk(icol,k,14)*cknorm(icol,k,14)*fnbc(icol,k) + c_bc_0(icol,k) = Nnatk(icol,k,0) * aerodry_prop%cintbg(icol,k,0) + c_bc_2(icol,k) = Nnatk(icol,k,2) * aerodry_prop%cintbg(icol,k,2) + c_bc_4(icol,k) = Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*faitbc(icol,k) + c_bc_12(icol,k)= Nnatk(icol,k,12) * aerodry_prop%cknorm(icol,k,12) + c_bc_14(icol,k)= Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) c_bc(icol,k) = c_bc(icol,k) & - +Nnatk(icol,k,2)*cintbg(icol,k,2) & - +Nnatk(icol,k,4)*cintbg(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0)*cintbg(icol,k,0) & - +Nnatk(icol,k,12)*cknorm(icol,k,12) & - +Nnatk(icol,k,14)*cknorm(icol,k,14)*fnbc(icol,k) + +Nnatk(icol,k,2) * aerodry_prop%cintbg(icol,k,2) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4) * faitbc(icol,k) & + +Nnatk(icol,k,0) * aerodry_prop%cintbg(icol,k,0) & + +Nnatk(icol,k,12) * aerodry_prop%cknorm(icol,k,12) & + +Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) c_bc05(icol,k) = c_bc05(icol,k) & - +Nnatk(icol,k,2)*cintbg05(icol,k,2) & - +Nnatk(icol,k,4)*cintbg05(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0)*cintbg05(icol,k,0) & - +Nnatk(icol,k,12)*cknlt05(icol,k,12) & - +Nnatk(icol,k,14)*cknlt05(icol,k,14)*fnbc(icol,k) + +Nnatk(icol,k,2) * aerodry_prop%cintbg05(icol,k,2) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg05(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0) * aerodry_prop%cintbg05(icol,k,0) & + +Nnatk(icol,k,12) * aerodry_prop%cknlt05(icol,k,12) & + +Nnatk(icol,k,14) * aerodry_prop%cknlt05(icol,k,14)*fnbc(icol,k) c_bc125(icol,k) = c_bc125(icol,k) & - +Nnatk(icol,k,2)*cintbg125(icol,k,2) & - +Nnatk(icol,k,4)*cintbg125(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0)*cintbg125(icol,k,0) & - +Nnatk(icol,k,12)*ckngt125(icol,k,12) & - +Nnatk(icol,k,14)*ckngt125(icol,k,14)*fnbc(icol,k) + +Nnatk(icol,k,2) * aerodry_prop%cintbg125(icol,k,2) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg125(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0) * aerodry_prop%cintbg125(icol,k,0) & + +Nnatk(icol,k,12) * aerodry_prop%ckngt125(icol,k,12) & + +Nnatk(icol,k,14) * aerodry_prop%ckngt125(icol,k,14)*fnbc(icol,k) c_oc_ac(icol,k)= c_oc(icol,k) - c_oc_4(icol,k) = Nnatk(icol,k,4)*cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) - c_oc_14(icol,k) = Nnatk(icol,k,14)*cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc_4(icol,k) = Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) + c_oc_14(icol,k) = Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) c_oc(icol,k) = c_oc(icol,k) & - +Nnatk(icol,k,1)*cintbg(icol,k,1)*f_soana(icol,k) & - !-3 +Nnatk(icol,k,3)*cintbg(icol,k,3) & - +Nnatk(icol,k,4)*cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14)*cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + +Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*f_soana(icol,k) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) c_oc05(icol,k) = c_oc05(icol,k) & - +Nnatk(icol,k,1)*cintbg05(icol,k,1)*f_soana(icol,k) & - !-3 +Nnatk(icol,k,3)*cintbg05(icol,k,3) & - +Nnatk(icol,k,4)*cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14)*cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) + +Nnatk(icol,k,1) * aerodry_prop%cintbg05(icol,k,1)*f_soana(icol,k) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14) * aerodry_prop%cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) c_oc125(icol,k) = c_oc125(icol,k) & - +Nnatk(icol,k,1)*cintbg125(icol,k,1)*f_soana(icol,k) & - !-3 +Nnatk(icol,k,3)*cintbg125(icol,k,3) & - +Nnatk(icol,k,4)*cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14)*ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) + +Nnatk(icol,k,1) * aerodry_prop%cintbg125(icol,k,1)*f_soana(icol,k) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14) * aerodry_prop%ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) c_s4(icol,k) = c_sa(icol,k)+c_sc(icol,k) & - +Nnatk(icol,k,1)*cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5)*cintbg(icol,k,5) + +Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5) * aerodry_prop%cintbg(icol,k,5) c_s405(icol,k) = c_sa05(icol,k)+c_sc05(icol,k) & - +Nnatk(icol,k,1)*cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5)*cintbg05(icol,k,5) + +Nnatk(icol,k,1) * aerodry_prop%cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5) * aerodry_prop%cintbg05(icol,k,5) c_s4125(icol,k) = c_sa125(icol,k)+c_sc125(icol,k) & - +Nnatk(icol,k,1)*cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5)*cintbg125(icol,k,5) - - !akc6+ - c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) & - + c_mi(icol,k) + c_ss(icol,k) - c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) & - + c_mi125(icol,k) + c_ss125(icol,k) - c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) & - + c_mi05(icol,k) + c_ss05(icol,k) - c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) - c_pm1(icol,k) = c_tot05(icol,k) - ! mass mixing ratio: + +Nnatk(icol,k,1) * aerodry_prop%cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5) * aerodry_prop%cintbg125(icol,k,5) + + c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) + c_mi(icol,k) + c_ss(icol,k) + c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) + c_mi125(icol,k) + c_ss125(icol,k) + c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) + c_mi05(icol,k) + c_ss05(icol,k) + c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) + c_pm1(icol,k) = c_tot05(icol,k) + + ! mass mixing ratio: mmr_pm25(icol,k) = 1.e-9*c_pm25(icol,k)/rhoda(icol,k) mmr_pm1(icol,k) = 1.e-9*c_pm1(icol,k)/rhoda(icol,k) - !akc6- ! converting from S to SO4 concentrations is no longer necessary, since ! sc=H2SO4 and sa=(NH4)2SO4 now, not SO4 as in CAM4-Oslo @@ -1980,24 +1908,17 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & ! c_s4125(icol,k)=c_s4125(icol,k)/3._r8 c_s4_a(icol,k) = c_sa(icol,k)+c_sc(icol,k) - c_s4_1(icol,k) = Nnatk(icol,k,1)*cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) - c_s4_5(icol,k) = Nnatk(icol,k,5)*cintbg05(icol,k,5) + c_s4_1(icol,k) = Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) + c_s4_5(icol,k) = Nnatk(icol,k,5) * aerodry_prop%cintbg05(icol,k,5) end do ! icol enddo ! k ! Total PM and PM2.5 (dry r>1.25um), surface values (ug/m3) do icol=1,ncol - ! c_tots(icol) = c_s4(icol,pver) + c_oc(icol,pver) + c_bc(icol,pver) & - ! + c_mi(icol,pver) + c_ss(icol,pver) - ! c_tot125s(icol) = c_s4125(icol,pver) + c_oc125(icol,pver) + c_bc125(icol,pver) & - ! + c_mi125(icol,pver) + c_ss125(icol,pver) - ! c_pm25s(icol) = c_tots(icol) - c_tot125s(icol) - !akc6+ c_tots(icol) = c_tot(icol,pver) c_tot125s(icol) = c_tot125(icol,pver) c_pm25s(icol) = c_pm25(icol,pver) - !akc6- enddo ! Effective, column integrated, radii for particles @@ -2005,8 +1926,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & do icol=1,ncol derlt05(icol)=3.0_r8*vaercols(icol)/(aaercols(icol)+eps) dergt05(icol)=3.0_r8*vaercoll(icol)/(aaercoll(icol)+eps) - der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) & - /(aaercols(icol)+aaercoll(icol)+eps) + der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) /(aaercols(icol)+aaercoll(icol)+eps) enddo do icol=1,ncol diff --git a/src/physics/cam_oslo/preprocessorDefinitions.h b/src/physics/cam_oslo/preprocessorDefinitions.h deleted file mode 100644 index a666051540..0000000000 --- a/src/physics/cam_oslo/preprocessorDefinitions.h +++ /dev/null @@ -1,4 +0,0 @@ -#undef AEROCOM -#undef AEROFFL -#undef COLTST4INTCONS -#undef AEROCOM_INSITU diff --git a/src/physics/cam_oslo/radiation.F90 b/src/physics/cam_oslo/radiation.F90 index 496537b676..c7d4ae8504 100644 --- a/src/physics/cam_oslo/radiation.F90 +++ b/src/physics/cam_oslo/radiation.F90 @@ -6,8 +6,6 @@ module radiation ! !--------------------------------------------------------------------------------- -#include - use shr_kind_mod, only: r8=>shr_kind_r8 use spmd_utils, only: masterproc use ppgrid, only: pcols, pver, pverp, begchunk, endchunk @@ -44,14 +42,11 @@ module radiation use error_messages, only: handle_err use perf_mod, only: t_startf, t_stopf use cam_logfile, only: iulog -#ifdef DIRIND use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands -use pmxsub_mod, only: pmxsub -#endif +use pmxsub_mod, only: pmxsub implicit none private -save public :: & radiation_readnl, &! read namelist variables @@ -129,12 +124,7 @@ module radiation ! run continuously from the start of an ! initial or restart run logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations -!logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. -!#ifdef RFMIPIRF -! logical :: spectralflux = .true. ! calculate fluxes (up and down) per band. -!#else - logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. -!#endif +logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. ! Physics buffer indices integer :: qrs_idx = 0 @@ -150,9 +140,7 @@ module radiation integer :: flnt_idx = 0 integer :: cldfsnow_idx = 0 integer :: cld_idx = 0 -#ifdef DIRIND integer :: volc_idx = 0 -#endif character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) @@ -162,6 +150,12 @@ module radiation ! PIO descriptors (for restarts) type(var_desc_t) :: cospcnt_desc +#ifdef AEROCOM +logical :: do_aerocom = .true. +#else +logical :: do_aerocom = .false. +#endif + !=============================================================================== contains !=============================================================================== @@ -183,11 +177,6 @@ subroutine radiation_readnl(nlfile) namelist /radiation_nl/ iradsw, iradlw, irad_always, & use_rad_dt_cosz, spectralflux - -!#ifdef RFMIPIRF -! spectralflux = .true. ! calculate fluxes (up and down) per band. -!#endif - !----------------------------------------------------------------------------- if (masterproc) then @@ -260,7 +249,6 @@ subroutine radiation_register ! If the namelist has been configured for preserving the spectral fluxes, then create ! physics buffer variables to store the results. -! legg til #ifndef RFMIPIRF her ogsaa?! if (spectralflux) then call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) @@ -506,10 +494,6 @@ subroutine radiation_init(pbuf2d) call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') -!#ifdef AEROFFL -! call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') -! call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') -!#endif if (history_amwg) then call add_default('SOLIN'//diag(icall), 1, ' ') @@ -529,10 +513,8 @@ subroutine radiation_init(pbuf2d) end if end do -#ifdef AEROFFL - call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') - call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') -#endif + call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') + call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') if (scm_crm_mode) then call add_default('FUS ', 1, ' ') @@ -698,11 +680,7 @@ end subroutine radiation_read_restart !=============================================================================== subroutine radiation_tend( & -!#ifdef SPAERO -! state, ptend, pbuf, cam_out, cam_in, net_flx, xcdnc, rd_out) -!#else state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) -!#endif !----------------------------------------------------------------------- ! @@ -743,28 +721,18 @@ subroutine radiation_tend( & use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps -#ifdef DIRIND - use commondefinitions - use aerosoldef - use opttab, only: nbands, eps - use constituents, only: pcnst - use oslo_control, only: oslo_getopts - use physics_buffer, only: pbuf_get_index -!#ifdef SPAERO -! use time_manager, only: get_curr_date -! use physconst, only: rair -!#endif -#endif + use commondefinitions + use aerosoldef + use opttab, only: nbands, eps + use constituents, only: pcnst + use oslo_control, only: oslo_getopts + use physics_buffer, only: pbuf_get_index -#ifdef DIRIND real(r8) flnt_tmp(pcols) ! Net outgoing lw flux at model top for AIE calculations real(r8) volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode integer :: band character(len=3) :: c3 -#ifdef AEROFFL logical idrf -#endif -#endif ! Arguments type(physics_state), intent(in), target :: state @@ -787,10 +755,8 @@ subroutine radiation_tend( & integer :: lchnk, ncol logical :: dosw, dolw -#ifdef DIRIND - real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr - real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) -#endif + real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr + real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) real(r8) :: calday ! current calendar day real(r8) :: delta ! Solar declination angle in radians real(r8) :: eccf ! Earth orbit eccentricity factor @@ -849,19 +815,6 @@ subroutine radiation_tend( & real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) -!#ifdef SPAERO - ! cloud radiative parameters are "in cloud" not "in cell" with SP aerosols -! real(r8) :: sp_liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth -! real(r8) :: sp_liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau -! real(r8) :: sp_liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w -! real(r8) :: sp_liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w -! real(r8) :: sp_cld_tau (nswbands,pcols,pver) ! liquid extinction optical depth -! real(r8) :: sp_cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau -! real(r8) :: sp_cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau -! real(r8) :: sp_cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau -! real(r8) :: sp_cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) -!#endif - ! cloud radiative parameters are "in cloud" not "in cell" real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau @@ -876,12 +829,6 @@ subroutine radiation_tend( & real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) -!#ifdef SPAERO ! and for SP aerosols (only for SW) -! real(r8) :: sp_c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth -! real(r8) :: sp_c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau -! real(r8) :: sp_c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau -! real(r8) :: sp_c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau -!#endif real(r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band @@ -895,36 +842,6 @@ subroutine radiation_tend( & real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) -#ifdef DIRIND - -!#ifdef SPAERO -! Aerosol optical properties, simple plume aerosols -! real(r8) :: sp_tau (pcols,pver,nswbands) ! aerosol extinction optical depth, simple plumes -! real(r8) :: sp_ssa (pcols,pver,nswbands) ! aerosol single scattering albedo, simple plumes -! real(r8) :: sp_asy (pcols,pver,nswbands) ! aerosol assymetry parameter, simple plumes -! -! Aerosol optical properties, sum of NorESM + simple plume aerosols -! real(r8) :: sp_per_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth -! real(r8) :: sp_per_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau -! real(r8) :: sp_per_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau -! real(r8) :: sp_per_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau -! -! real(r8), intent(out) :: xcdnc(pcols) ! CDNC modification factor -! real(r8) :: re_mult(pcols,pver) ! Multiplication factor of liquid cloud effective radius, simple plumes -! real(r8) :: re_multeq1(pcols,pver) ! Dummy multiplication factor (=1.0) of liquid cloud effective radius, simple plumes -! real(r8) :: xcdnceq1(pcols) ! Dummy xcdnc -! -!!ak real(r8) :: sp_relca(pcols,pver) ! Modified liquid cloud effective radius, simple plumes -! -! real(r8) :: year_fr ! Fractional year (1903.0 is the 0Z on the first of January 1903, Gregorian) -! -! integer :: yr, mon, day, tod ! date components -!#endif -!#ifdef RFMIPIRF -! real(r8) :: per_aod (pcols,pver,nswbands) ! aerosol single scattering albedo -! real(r8) :: per_ssa (pcols,pver,nswbands) ! aerosol single scattering albedo -! real(r8) :: per_asy (pcols,pver,nswbands) ! aerosol assymetry parameter -!#endif ! Local variables used for calculating aerosol optics and direct and indirect forcings. ! aodvis and absvis are AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) @@ -933,13 +850,10 @@ subroutine radiation_tend( & real(r8) aodvis(pcols) ! AOD vis real(r8) absvis(pcols) ! absorptive AOD vis real(r8) clearodvis(pcols), clearabsvis(pcols), cloudfree(pcols), cloudfreemax(pcols) -#ifdef AEROCOM + ! AEROCOM beg real(r8) dod440(pcols),dod550(pcols),dod870(pcols),abs550(pcols),abs550alt(pcols) real(r8) clearod440(pcols),clearod550(pcols),clearod870(pcols),clearabs550(pcols),clearabs550alt(pcols) -!#ifdef RFMIPIRF -! character(len=2) :: c2 -!#endif -#endif ! AEROCOM + ! AEROCOM end real(r8) ftem_1d(pcols) ! work-array to avoid NAN and pcols/ncol confusion real(r8) Nnatk(pcols,pver,0:nmodes) ! Modal aerosol number concentration real(r8) batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW @@ -958,10 +872,6 @@ subroutine radiation_tend( & real(r8) :: volc_g_sun(pcols,pver,nswbands) ! volcanic aerosol g for solar bands, CMIP6 real(r8) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 real(r8) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 -!#ifdef SPAERO -! real(r8) deltah_km(pcols,pver) ! Layer thickness, unit km -!#endif -#endif real(r8) :: fns(pcols,pverp) ! net shortwave flux real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux @@ -1057,7 +967,6 @@ subroutine radiation_tend( & end do end if -#ifdef DIRIND qdirind(:ncol,:,:) = state%q(:ncol,:,:) if (has_prescribed_volcaero) then call oslo_getopts(volc_fraction_coarse_out = volc_fraction_coarse) @@ -1065,7 +974,7 @@ subroutine radiation_tend( & qdirind(:ncol,:,l_so4_pr) = qdirind(:ncol,:,l_so4_pr) + (1.0_r8 - volc_fraction_coarse)*rvolcmmr(:ncol,:) qdirind(:ncol,:,l_ss_a3) = qdirind(:ncol,:,l_ss_a3) + volc_fraction_coarse*rvolcmmr(:ncol,:) end if -#endif + ! Find tropopause height if needed for diagnostic output if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) @@ -1091,47 +1000,6 @@ subroutine radiation_tend( & if (dosw) then -!#ifdef SPAERO -!*********************************** SPAERO + ********************************************* -! Define anthrop. aerosol optical properties and "cdnc" for the "simple plumes" climatology - -! CALL get_curr_date(yr, mon, day, tod) - -! Petri used a hard-coded year for BACCHUS: either 1850, 1975 or 2005 - -! yr=2005 - -! year_fr = yr + (calday-1.0_r8) / 365.0_r8 - -!ak+ Need deltah_km before pmxsub is called, due to cloud optics (-> input to pmxsub later) -! do k=1,pver -!! NB have to multiply with 10 to get the same values as in pmxsub, due to different p units! -! rhoda(1:ncol,k) = state%pmid(1:ncol,k)/(rair*state%t(1:ncol,k)) ! unit kg/m^3 -! deltah_km(1:ncol,k)=10._r8*1.e-4_r8*(state%pint(1:ncol,k+1)-state%pint(1:ncol,k))/(rhoda(1:ncol,k)*9.8_r8) -! end do - -! initialization -! re_mult(1:ncol,1:pver) = 1._r8 -! xcdnc(1:ncol) = 1._r8 -! for use in calls without the effect of SP aerosols -! re_multeq1(1:ncol,1:pver) = 1._r8 -! xcdnceq1(1:ncol) = 1._r8 -!ak- - -! CALL simple_plumes_interface(lchnk, ncol, nswbands,state%phis, & -! deltah_km, clon, clat, year_fr, & -! sp_tau, sp_ssa, sp_asy, re_mult, xcdnc) - -! When using year 1850 for the MACv2-SP aerosols, switch them off entirely -! IF (yr==1850) THEN -! sp_tau(1:ncol,1:pver,1:nswbands)=0._r8 -! sp_ssa(1:ncol,1:pver,1:nswbands)=0._r8 -! sp_asy(1:ncol,1:pver,1:nswbands)=0._r8 -! re_mult(1:ncol,1:pver) = 1._r8 -! xcdnc(1:ncol) = 1._r8 -! END IF -!*********************************** SPAERO - ********************************************* -!#endif if (oldcldoptics) then call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) @@ -1151,13 +1019,8 @@ subroutine radiation_tend( & call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) case ('gammadist') -!#ifdef SPAERO -! The order of the two calls below has been tested not to make any difference -! call get_liquid_optics_sw(state, pbuf, xcdnceq1, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) -! call get_liquid_optics_sw(state, pbuf, xcdnc, sp_liq_tau, sp_liq_tau_w, sp_liq_tau_w_g, sp_liq_tau_w_f) -!#else call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) -!#endif + case default call endrun('liqcldoptics must be either slingo or gammadist') end select @@ -1167,12 +1030,6 @@ subroutine radiation_tend( & cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) -!#ifdef SPAERO -! sp_cld_tau(:,:ncol,:) = sp_liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) -! sp_cld_tau_w(:,:ncol,:) = sp_liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) -! sp_cld_tau_w_g(:,:ncol,:) = sp_liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) -! sp_cld_tau_w_f(:,:ncol,:) = sp_liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) -!#endif if (cldfsnow_idx > 0) then ! add in snow @@ -1201,38 +1058,11 @@ subroutine radiation_tend( & end if end do end do -!#ifdef SPAERO -! do i = 1, ncol -! do k = 1, pver -! if (cldfprime(i,k) > 0._r8) then -! sp_c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & -! + cld(i,k)*sp_cld_tau(:,i,k) )/cldfprime(i,k) -! sp_c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & -! + cld(i,k)*sp_cld_tau_w(:,i,k) )/cldfprime(i,k) -! sp_c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & -! + cld(i,k)*sp_cld_tau_w_g(:,i,k) )/cldfprime(i,k) -! sp_c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & -! + cld(i,k)*sp_cld_tau_w_f(:,i,k) )/cldfprime(i,k) -! else -! sp_c_cld_tau(:,i,k) = 0._r8 -! sp_c_cld_tau_w(:,i,k) = 0._r8 -! sp_c_cld_tau_w_g(:,i,k) = 0._r8 -! sp_c_cld_tau_w_f(:,i,k) = 0._r8 -! end if -! end do -! end do -!#endif else c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) -!#ifdef SPAERO -! sp_c_cld_tau(:,:ncol,:) = sp_cld_tau(:,:ncol,:) -! sp_c_cld_tau_w(:,:ncol,:) = sp_cld_tau_w(:,:ncol,:) -! sp_c_cld_tau_w_g(:,:ncol,:) = sp_cld_tau_w_g(:,:ncol,:) -! sp_c_cld_tau_w_f(:,:ncol,:) = sp_cld_tau_w_f(:,:ncol,:) -!#endif end if ! Output cloud optical depth fields for the visible band @@ -1316,7 +1146,6 @@ subroutine radiation_tend( & if (dosw) then -#ifdef DIRIND !TEST ! qdirind(:ncol,:,l_soa_a1) = 0.0_r8 ! qdirind(:ncol,:,l_soa_na) = 0.0_r8 @@ -1364,68 +1193,13 @@ subroutine radiation_tend( & enddo endif - call pmxsub(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & - coszrs, state, state%t, cld, qdirind, Nnatk, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & - per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, & - volc_ext_earth, volc_omega_earth, & -#ifdef AEROCOM - aodvis, absvis, dod440, dod550, dod870, abs550, abs550alt) -#else - aodvis, absvis) -#endif - -!#ifdef RFMIPIRF -!! Extra RFMIP-IRF diagnostics for each SW wave-length/number band -! per_aod(:,:,:)=0._r8 -! per_ssa(:,:,:)=0._r8 -! per_asy(:,:,:)=0._r8 -! DO i=1,ncol -!! DO k=0,pver -! DO k=1,pver -! DO ns=1,nswbands -! per_aod(i,k,ns)=per_tau(i,k,ns) -! per_ssa(i,k,ns)=min(per_tau_w(i,k,ns)/(per_tau(i,k,ns)+eps),1._r8) -! per_asy(i,k,ns)=min(per_tau_w_g(i,k,ns)/(per_tau_w(i,k,ns)+eps),1._r8) -! ENDDO -! ENDDO -! ENDDO -! do ns=1,nswbands -! write(c2,'(I2)') ns -! call outfld('AERTAUBND'//trim(adjustl(c2)),per_aod(:,:,ns),pcols,lchnk) -! call outfld('AERSSABND'//trim(adjustl(c2)),per_ssa(:,:,ns),pcols,lchnk) -! call outfld('AERASYBND'//trim(adjustl(c2)),per_asy(:,:,ns),pcols,lchnk) -! enddo -!#endif - -!#ifdef SPAERO -!*********************************** SPAERO + ********************************************* -! Use the anthropogenic aerosol optical properties for the "simple plumes" climatology - -! Add "simple plumes" to NorESM2 aerosols (which should be defined using year 1850 emissions) - -! Set aerosol optical properties zero for the top layer (0) -! sp_per_tau(1:ncol,0,1:nswbands) = 0._r8 -! sp_per_tau_w(1:ncol,0,1:nswbands) = 0._r8 -! sp_per_tau_w_g(1:ncol,0,1:nswbands) = 0._r8 -! sp_per_tau_w_f(1:ncol,0,1:nswbands) = 0._r8 - -! Other layers -! DO i=1,ncol -! DO k=1,pver -! DO ns=1,nswbands -! sp_per_tau(i,k,ns)=per_tau(i,k,ns) + sp_tau(i,k,ns) -! sp_per_tau_w(i,k,ns)=per_tau_w(i,k,ns) + sp_tau(i,k,ns)*sp_ssa(i,k,ns) -! sp_per_tau_w_g(i,k,ns)=per_tau_w_g(i,k,ns) + sp_tau(i,k,ns)*sp_ssa(i,k,ns)*sp_asy(i,k,ns) -! sp_per_tau_w_f(i,k,ns)=per_tau_w_f(i,k,ns) + sp_tau(i,k,ns)*sp_ssa(i,k,ns)*sp_asy(i,k,ns)**2 -! ENDDO -! ENDDO -! ENDDO -!*********************************** SPAERO - ********************************************* -!#endif - -#endif ! DIRIND + call pmxsub(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & + coszrs, state, state%t, cld, qdirind, Nnatk, & + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & + per_lw_abs, & + volc_ext_sun, volc_omega_sun, volc_g_sun, & + volc_ext_earth, volc_omega_earth, & + aodvis, absvis, dod440, dod550, dod870, abs550, abs550alt) call get_variability(sfac) @@ -1442,11 +1216,10 @@ subroutine radiation_tend( & !call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & ! aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) -#ifdef DIRIND ! A first call with Oslo aerosols set to zero for radiative forcing diagnostics ! follwoing the Ghan (2013) method: -#ifdef AEROFFL ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore + ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore ! (just nudged), but with an extra call with 0 aerosol extiction. ! !akc6+ @@ -1455,21 +1228,13 @@ subroutine radiation_tend( & call rad_rrtmg_sw( & lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & cldfprime, & -!orig aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & per_tau*0.0_r8, per_tau_w, per_tau_w_g, per_tau_w_f, & eccf, coszrs, rd%solin, sfac, cam_in%asdir, & cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & -!akc6+ -!#ifdef AEROFFL -! cam_out%solld, fns, fcns, fds, fdsc, Nday, Nnite, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & -!#else -! cam_out%solld, fns, fcns, Nday, Nnite, & -!#endif -!akc6- + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) @@ -1487,16 +1252,14 @@ subroutine radiation_tend( & call outfld('FSNS_DRF',fsns(:) ,pcols,lchnk) call outfld('FSNTCDRF',rd%fsntc(:) ,pcols,lchnk) call outfld('FSNSCDRF',rd%fsnsc(:) ,pcols,lchnk) -!#ifdef AEROCOM + ! AEROCOM beg call outfld('FSUTADRF',rd%fsutoa(:),pcols,lchnk) call outfld('FSDS_DRF',fsds(:) ,pcols,lchnk) ftem_1d(1:ncol) = fsds(1:ncol)-fsns(1:ncol) call outfld('FSUS_DRF',ftem_1d,pcols,lchnk) call outfld('FSDSCDRF',rd%fsdsc(:) ,pcols,lchnk) -!#endif + ! AEROCOM end idrf = .false. -#endif ! AEROFFL -#endif ! DIRIND rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) @@ -1508,126 +1271,18 @@ subroutine radiation_tend( & call rad_rrtmg_sw( & lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & cldfprime, & -#ifdef DIRIND - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & -#else - aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & -#endif + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & eccf, coszrs, rd%solin, sfac, cam_in%asdir, & cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & -!akc6+ -#ifdef AEROFFL -! cam_out%solld, fns, fcns, fds, fdsc, Nday, Nnite, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & -#else - cam_out%solld, fns, fcns, Nday, Nnite, & -#endif -!akc6- + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) -!#ifdef SPAERO - ! - ! Dump shortwave radiation information to history tape buffer (diagnostics) - ! -! Added, as for BACCHUS by P. Räisänen -! call outfld('FSNT_SP ',fsnt ,pcols,lchnk) -! call outfld('FSNS_SP ',fsns ,pcols,lchnk) -! call outfld('FSNTC_SP',rd%fsntc ,pcols,lchnk) -! call outfld('FSNSC_SP',rd%fsnsc ,pcols,lchnk) -!#endif - - -!#ifdef SPAERO -!*********************************** SPAERO + ********************************************* -! THIRD CALL INCLUDING SIMPLE PLUME AEROSOLS FOR ONLY THE DIRECT EFFECT (SW ERF ari) - -! call rad_rrtmg_sw( & -! lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & -! cldfprime, & -!ak+ per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & -! sp_per_tau, sp_per_tau_w, sp_per_tau_w_g, sp_per_tau_w_f, & -!ak- -! eccf, coszrs, rd%solin, sfac, cam_in%asdir, & -! cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & -! fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & -! rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & -! rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & -!akc6+ -!#ifdef AEROFFL -! cam_out%solld, fns, fcns, idrf, Nday, Nnite, & -!#else -! cam_out%solld, fns, fcns, Nday, Nnite, & -!#endif -!akc6- -! IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & -! E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & -! E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) - - - ! - ! Dump shortwave radiation information to history tape buffer (diagnostics) - ! -! Added, as for BACCHUS by P. Räisänen -! call outfld('FSNT_SP2',fsnt ,pcols,lchnk) -! call outfld('FSNS_SP2',fsns ,pcols,lchnk) -! call outfld('FSNTCSP2',rd%fsntc ,pcols,lchnk) -! call outfld('FSNSCSP2',rd%fsnsc ,pcols,lchnk) - -! FOURTH CALL INCLUDING SIMPLE PLUME AEROSOLS FOR BOTH THE DIRECT AND THE 1. INDIRECT EFFECT - -! call rad_rrtmg_sw( & -! lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & -! cldfprime, & -!ak+ per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & -! sp_per_tau, sp_per_tau_w, sp_per_tau_w_g, sp_per_tau_w_f, & -!ak- -! eccf, coszrs, rd%solin, sfac, cam_in%asdir, & -! cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & -! fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & -! rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & -! rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & -!akc6+ -!#ifdef AEROFFL -! cam_out%solld, fns, fcns, idrf, Nday, Nnite, & -!#else -! cam_out%solld, fns, fcns, Nday, Nnite, & -!#endif -!akc6- -!ak+ IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & -!ak+ E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & -!ak+ E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) -! IdxDay, IdxNite, su, sd, E_cld_tau=sp_c_cld_tau, & -! E_cld_tau_w=sp_c_cld_tau_w, E_cld_tau_w_g=sp_c_cld_tau_w_g,& -! E_cld_tau_w_f=sp_c_cld_tau_w_f, old_convert=.false.) -!ak- - - ! - ! Dump shortwave radiation information to history tape buffer (diagnostics) - ! -! Added, as for BACCHUS by P. Räisänen -! call outfld('FSNT_SP3',fsnt ,pcols,lchnk) -! call outfld('FSNS_SP3',fsns ,pcols,lchnk) -! call outfld('FSNTCSP3',rd%fsntc ,pcols,lchnk) -! call outfld('FSNSCSP3',rd%fsnsc ,pcols,lchnk) - -!*********************************** SPAERO + ********************************************* -!#endif - -!#ifdef RFMIPIRF -! Extra RFMIP-IRF diagnostics for each SW wave-length/number band -! do ns=1,nswbands -! write(c2,'(I2)') ns -! call outfld('SDBND'//trim(adjustl(c2)),sd(:,:,ns),pcols,lchnk) -! call outfld('SUBND'//trim(adjustl(c2)),su(:,:,ns),pcols,lchnk) -! enddo -!#endif - !ak+ Has been moved from above to after the last rad_rrtmg_sw call... ! Output net fluxes at 200 mb call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) @@ -1644,9 +1299,8 @@ subroutine radiation_tend( & end if -#ifdef DIRIND - !Calculate cloud-free fraction assuming random overlap - !(kind of duplicated from cloud_cover_diags::cldsav) + !Calculate cloud-free fraction assuming random overlap + !(kind of duplicated from cloud_cover_diags::cldsav) cloudfree(1:ncol) = 1.0_r8 cloudfreemax(1:ncol) = 1.0_r8 @@ -1663,26 +1317,25 @@ subroutine radiation_tend( & clearodvis(i)=cloudfree(i)*aodvis(i) clearabsvis(i)=cloudfree(i)*absvis(i) end do -! clear-sky AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) -! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values + ! clear-sky AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) + ! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values call outfld('CAODVIS ',clearodvis,pcols,lchnk) call outfld('CABSVIS ',clearabsvis,pcols,lchnk) call outfld('CLDFREE ',cloudfree,pcols,lchnk) -#ifdef AEROCOM - do i = 1, ncol - clearod440(i)=cloudfree(i)*dod440(i) - clearod550(i)=cloudfree(i)*dod550(i) - clearod870(i)=cloudfree(i)*dod870(i) - clearabs550(i)=cloudfree(i)*abs550(i) - clearabs550alt(i)=cloudfree(i)*abs550alt(i) - end do - call outfld('CDOD440 ',clearod440 ,pcols,lchnk) - call outfld('CDOD550 ',clearod550 ,pcols,lchnk) - call outfld('CDOD870 ',clearod870 ,pcols,lchnk) - call outfld('CABS550 ',clearabs550 ,pcols,lchnk) - call outfld('CABS550A',clearabs550alt,pcols,lchnk) -#endif ! AEROCOM -#endif ! DIRIND + if (do_aerocom) then + do i = 1, ncol + clearod440(i)=cloudfree(i)*dod440(i) + clearod550(i)=cloudfree(i)*dod550(i) + clearod870(i)=cloudfree(i)*dod870(i) + clearabs550(i)=cloudfree(i)*abs550(i) + clearabs550alt(i)=cloudfree(i)*abs550alt(i) + end do + call outfld('CDOD440 ',clearod440 ,pcols,lchnk) + call outfld('CDOD550 ',clearod550 ,pcols,lchnk) + call outfld('CDOD870 ',clearod870 ,pcols,lchnk) + call outfld('CABS550 ',clearabs550 ,pcols,lchnk) + call outfld('CABS550A',clearabs550alt,pcols,lchnk) + end if ! Output aerosol mmr call rad_cnst_out(0, state, pbuf) @@ -1703,9 +1356,8 @@ subroutine radiation_tend( & call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) -#ifdef DIRIND -#ifdef AEROFFL ! for calculation of direct and direct radiative forcing -! + ! for calculation of direct and direct radiative forcing + call rad_rrtmg_lw( & lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & per_lw_abs*0.0_r8, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & @@ -1715,47 +1367,17 @@ subroutine radiation_tend( & call outfld('FLNT_DRF',flnt(:) ,pcols,lchnk) call outfld('FLNTCDRF',rd%flntc(:) ,pcols,lchnk) -#endif ! AEROFFL -#endif ! DIRIND call rad_rrtmg_lw( & lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & -#ifdef DIRIND per_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & -#else - aer_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & -#endif flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & lu, ld) -#ifdef DIRIND -#ifdef AEROFFL ! FLNT_ORG is just for temporary testing vs. FLNT -!#ifdef AEROCOM -! call outfld('FLNT_ORG',flnt(:) ,pcols,lchnk) - ftem_1d(1:ncol) = cam_out%flwds(1:ncol) - flns(1:ncol) - call outfld('FLUS ',ftem_1d ,pcols,lchnk) -!#endif ! AEROCOM -#endif ! AEROFFL -!#ifdef AEROCOM -! do i=1,ncol -! do k=1,pver -! aerlwabs01(i,k) = aer_lw_abs(i,k,16) -! end do -! end do -! call outfld('AERLWA01',aerlwabs01,pcols,lchnk) -!#endif - -!#ifdef RFMIPIRF -! Extra RFMIP-IRF diagnostics for each LW wave-length/number band -! do ns=1,nlwbands -! write(c2,'(I2)') ns -! call outfld('LDBND'//trim(adjustl(c2)),ld(:,:,ns),pcols,lchnk) -! call outfld('LUBND'//trim(adjustl(c2)),lu(:,:,ns),pcols,lchnk) -! enddo -!#endif - -#endif ! DIRIND + ! FLNT_ORG is just for temporary testing vs. FLNT + ftem_1d(1:ncol) = cam_out%flwds(1:ncol) - flns(1:ncol) + call outfld('FLUS ',ftem_1d ,pcols,lchnk) ! Output fluxes at 200 mb call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) diff --git a/src/physics/cam_oslo/radlw.F90 b/src/physics/cam_oslo/radlw.F90 index df8dd0c4b5..59fa3d641c 100644 --- a/src/physics/cam_oslo/radlw.F90 +++ b/src/physics/cam_oslo/radlw.F90 @@ -6,10 +6,6 @@ module radlw ! !----------------------------------------------------------------------- -!akc6+ -#include -!akc6- - use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols, pver, pverp use scamMod, only: single_column, scm_crm_mode @@ -193,10 +189,6 @@ subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & if (associated(lu)) lu(1:ncol,:,:) = 0.0_r8 if (associated(ld)) ld(1:ncol,:,:) = 0.0_r8 -!#ifdef RFMIPIRF -! lu(1:ncol,:,:) = 0.0_r8 -! ld(1:ncol,:,:) = 0.0_r8 -!#endif call rrtmg_lw(lchnk ,ncol ,rrtmg_levs ,icld , & r_state%pmidmb ,r_state%pintmb ,r_state%tlay ,r_state%tlev ,tsfc ,r_state%h2ovmr, & @@ -237,16 +229,10 @@ subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & fsul(:ncol,pverp-rrtmg_levs+1:pverp)=uflxc(:ncol,rrtmg_levs:1:-1) fsdl(:ncol,pverp-rrtmg_levs+1:pverp)=dflxc(:ncol,rrtmg_levs:1:-1) -#ifndef OSLO_AERO - if (single_column.and.scm_crm_mode) then -#endif call outfld('FUL ',ful,pcols,lchnk) call outfld('FDL ',fdl,pcols,lchnk) call outfld('FULC ',fsul,pcols,lchnk) call outfld('FDLC ',fsdl,pcols,lchnk) -#ifndef OSLO_AERO - endif -#endif fnl(:ncol,:) = ful(:ncol,:) - fdl(:ncol,:) ! mji/ cam excluded this? @@ -266,23 +252,15 @@ subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & ! Pass spectral fluxes, reverse layering ! order=(/3,1,2/) maps the first index of lwuflxs to the third index of lu. -!#ifndef RFMIPIRF if (associated(lu)) then -!#endif lu(:ncol,pverp-rrtmg_levs+1:pverp,:) = reshape(lwuflxs(:,:ncol,rrtmg_levs:1:-1), & (/ncol,rrtmg_levs,nbndlw/), order=(/3,1,2/)) -!#ifndef RFMIPIRF end if -!#endif -!#ifndef RFMIPIRF if (associated(ld)) then -!#endif ld(:ncol,pverp-rrtmg_levs+1:pverp,:) = reshape(lwdflxs(:,:ncol,rrtmg_levs:1:-1), & (/ncol,rrtmg_levs,nbndlw/), order=(/3,1,2/)) -!#ifndef RFMIPIRF end if -!#endif call t_stopf('rrtmg_lw') diff --git a/src/physics/cam_oslo/radsw.F90 b/src/physics/cam_oslo/radsw.F90 index 24a3b865fd..25bab39646 100644 --- a/src/physics/cam_oslo/radsw.F90 +++ b/src/physics/cam_oslo/radsw.F90 @@ -6,10 +6,6 @@ module radsw ! !----------------------------------------------------------------------- -!akc6+ -#include -!akc6- - use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols, pver, pverp use cam_abortutils, only: endrun @@ -27,7 +23,6 @@ module radsw implicit none private -save real(r8) :: fractional_solar_irradiance(1:nbndsw) ! fraction of solar irradiance in each band real(r8) :: solar_band_irrad(1:nbndsw) ! rrtmg-assumed solar irradiance in each sw band @@ -54,13 +49,7 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & qrs ,qrsc ,fsnt ,fsntc ,fsntoa,fsutoa, & fsntoac ,fsnirtoa ,fsnrtoac ,fsnrtoaq ,fsns , & fsnsc ,fsdsc ,fsds ,sols ,soll , & - solsd ,solld ,fns ,fcns , & -!akc6+ -#ifdef AEROFFL -! fds , fdsc , & - idrf , & -#endif -!akc6- + solsd ,solld ,fns ,fcns ,idrf , & Nday ,Nnite ,IdxDay ,IdxNite , & su ,sd , & E_cld_tau, E_cld_tau_w, E_cld_tau_w_g, E_cld_tau_w_f, & @@ -275,14 +264,7 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & real(r8) :: fusc(pcols,pverp) ! Upward clear-sky flux (added for CRM) real(r8) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM) -#ifdef AEROFFL -! real(r8), intent(out) :: fds(pcols,pverp) ! Downward flux (added for CRM) -! real(r8), intent(out) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM) -!#else -! real(r8) :: fds(pcols,pverp) ! Downward flux (added for CRM) -! real(r8) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM) logical, intent(in) :: idrf -#endif integer :: kk @@ -324,23 +306,13 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & qrsc(1:ncol,1:pver) = 0.0_r8 fns(1:ncol,1:pverp) = 0.0_r8 fcns(1:ncol,1:pverp) = 0.0_r8 -#ifndef OSLO_AERO - if (single_column.and.scm_crm_mode) then -#endif fus(1:ncol,1:pverp) = 0.0_r8 fds(1:ncol,1:pverp) = 0.0_r8 fusc(:ncol,:pverp) = 0.0_r8 fdsc(:ncol,:pverp) = 0.0_r8 -#ifndef OSLO_AERO - endif -#endif if (associated(su)) su(1:ncol,:,:) = 0.0_r8 if (associated(sd)) sd(1:ncol,:,:) = 0.0_r8 -!#ifdef RFMIPIRF -! su(1:ncol,:,:) = 0.0_r8 -! sd(1:ncol,:,:) = 0.0_r8 -!#endif ! If night everywhere, return: if ( Nday == 0 ) then @@ -603,23 +575,15 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & ! Set spectral fluxes, reverse layering ! order=(/3,1,2/) maps the first index of swuflxs to the third index of su. -!#ifndef RFMIPIRF if (associated(su)) then -!#endif su(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swuflxs(:,1:Nday,rrtmg_levs:1:-1), & (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/)) -!#ifndef RFMIPIRF end if -!#endif -!#ifndef RFMIPIRF if (associated(sd)) then -!#endif sd(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swdflxs(:,1:Nday,rrtmg_levs:1:-1), & (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/)) -!#ifndef RFMIPIRF end if -!#endif call t_stopf('rrtmg_sw') @@ -649,26 +613,15 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & call ExpDayNite(fsnrtoac, Nday, IdxDay, Nnite, IdxNite, 1, pcols) call ExpDayNite(fsnrtoaq, Nday, IdxDay, Nnite, IdxNite, 1, pcols) -!#ifndef RFMIPIRF if (associated(su)) then -!#endif call ExpDayNite(su, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw) -!#ifndef RFMIPIRF end if -!#endif -!#ifndef RFMIPIRF if (associated(sd)) then -!#endif call ExpDayNite(sd, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw) -!#ifndef RFMIPIRF end if -!#endif ! these outfld calls don't work for spmd only outfield in scm mode (nonspmd) -#ifndef OSLO_AERO - if (single_column .and. scm_crm_mode) then -#endif ! Following outputs added for CRM call ExpDayNite(fus,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) @@ -678,18 +631,11 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call outfld('FDS ', fds, pcols, lchnk) call outfld('FDSC ', fdsc, pcols, lchnk) -#ifndef OSLO_AERO - endif -#endif -#ifdef AEROFFL if(idrf) then -! call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) -! call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call outfld('FUSCDRF ', fusc, pcols, lchnk) call outfld('FDSCDRF ', fdsc, pcols, lchnk) endif -#endif end subroutine rad_rrtmg_sw From 18029037f0f074858f0edba05c38c67b5036b900 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 16 Aug 2023 18:53:53 +0200 Subject: [PATCH 06/71] refactored ndrop.F90 --- src/chemistry/oslo_aero/ndrop.F90 | 5144 ++++++++++++----------------- 1 file changed, 2069 insertions(+), 3075 deletions(-) diff --git a/src/chemistry/oslo_aero/ndrop.F90 b/src/chemistry/oslo_aero/ndrop.F90 index 1db290295e..ba343cb3cf 100644 --- a/src/chemistry/oslo_aero/ndrop.F90 +++ b/src/chemistry/oslo_aero/ndrop.F90 @@ -1,3135 +1,2129 @@ module ndrop -!--------------------------------------------------------------------------------- -! Purpose: -! CAM Interface for droplet activation by modal aerosols -! -! ***N.B.*** This module is currently hardcoded to recognize only the modes that -! affect the climate calculation. This is implemented by using list -! index 0 in all the calls to rad_constituent interfaces. -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8 => shr_kind_r8 -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver, pverp -use physconst, only: pi, rhoh2o, mwh2o, r_universal, rh2o, & - gravit, latvap, cpair, epsilo, rair -use constituents, only: pcnst, cnst_get_ind, cnst_name, cnst_spec_class_gas, cnst_species_class -use physics_types, only: physics_state, physics_ptend, physics_ptend_init -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field - -use wv_saturation, only: qsat -use phys_control, only: phys_getopts -use ref_pres, only: top_lev => trop_cloud_top_lev -use shr_spfn_mod, only: erf => shr_spfn_erf -use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & - rad_cnst_get_aer_props, rad_cnst_get_mode_props, & - rad_cnst_get_mam_mmr_idx, rad_cnst_get_mode_num_idx -use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld -use cam_abortutils, only: endrun -use cam_logfile, only: iulog -!++ MH_2015/09/09 -use phys_control, only: use_hetfrz_classnuc -!-- MH_2015/09/09 - -#ifdef OSLO_AERO -!++oslo -use aerosoldef -use parmix_progncdnc -use oslo_utils, only: calculateNumberMedianRadius -!--oslo -#endif - - -implicit none -private -save - -public ndrop_init, dropmixnuc, activate_modal, loadaer - -#ifndef OSLO_AERO -real(r8), allocatable :: alogsig(:) ! natl log of geometric standard dev of aerosol -real(r8), allocatable :: exp45logsig(:) -real(r8), allocatable, target :: f1(:) ! abdul-razzak functions of width -real(r8), allocatable, target :: f2(:) ! abdul-razzak functions of width -#endif - -real(r8) :: t0 ! reference temperature -real(r8) :: aten -real(r8) :: surften ! surface tension of water w/respect to air (N/m) -real(r8) :: alog2, alog3, alogaten -real(r8) :: third, twothird, sixth, zero -real(r8) :: sq2, sqpi - -! CCN diagnostic fields -!integer, parameter :: psat=6 ! number of supersaturations to calc ccn concentration -!real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration -! (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) -!character(len=8) :: ccn_name(psat)= & -! (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6'/) -!akc6+ -integer, parameter :: psat=7 ! number of supersaturations to calc ccn concentration -real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration - (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.15_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) -character(len=8) :: ccn_name(psat)= & - (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6','CCN7'/) -!akc6- - -! indices in state and pbuf structures -integer :: numliq_idx = -1 -integer :: kvh_idx = -1 - -! description of modal aerosols -integer :: ntot_amode ! number of aerosol modes -integer, allocatable :: nspec_amode(:) ! number of chemical species in each aerosol mode -real(r8), allocatable :: sigmag_amode(:)! geometric standard deviation for each aerosol mode -real(r8), allocatable :: dgnumlo_amode(:) -real(r8), allocatable :: dgnumhi_amode(:) -real(r8), allocatable :: voltonumblo_amode(:) -real(r8), allocatable :: voltonumbhi_amode(:) - -logical :: history_aerosol ! Output the MAM aerosol tendencies -character(len=fieldname_len), allocatable :: fieldname(:) ! names for drop nuc tendency output fields -character(len=fieldname_len), allocatable :: fieldname_cw(:) ! names for drop nuc tendency output fields - -! local indexing for MAM -integer, allocatable :: mam_idx(:,:) ! table for local indexing of modal aero number and mmr -integer :: ncnst_tot ! total number of mode number conc + mode species - -! Indices for MAM species in the ptend%q array. Needed for prognostic aerosol case. -integer, allocatable :: mam_cnst_idx(:,:) - -#ifdef OSLO_AERO -logical :: tendencyCounted(pcnst) = .false. ! set flags true for constituents with non-zero tendencies -integer :: n_aerosol_tracers -integer :: aerosolTracerList(pcnst) !List where indexes 1...n_aerosol_tracers are the indexes in pcnst - !..something like (/ l_so4_a1, l_bc_a, .../)etc -integer :: inverseAerosolTracerList(pcnst) !List where you can back the place in aerosolTracerList if you know the - !tracer index. So in the example above inverseAerosolTracerList(l_so4_a1) = 1 -#endif - -! ptr2d_t is used to create arrays of pointers to 2D fields -type ptr2d_t - real(r8), pointer :: fld(:,:) -end type ptr2d_t - -! modal aerosols -logical :: prog_modal_aero ! true when modal aerosols are prognostic -logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies - ! in the ptend object + !--------------------------------------------------------------------------------- + ! Purpose: + ! CAM Interface for droplet activation by modal aerosols + !--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp + use physconst, only: pi, rhoh2o, mwh2o, r_universal, rh2o + use physconst, only: gravit, latvap, cpair, epsilo, rair + use constituents, only: pcnst, cnst_get_ind, cnst_name, cnst_spec_class_gas, cnst_species_class + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field + use wv_saturation, only: qsat + use phys_control, only: phys_getopts + use ref_pres, only: top_lev => trop_cloud_top_lev + use shr_spfn_mod, only: erf => shr_spfn_erf + use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use phys_control, only: use_hetfrz_classnuc + use aerosoldef + use parmix_progncdnc + use oslo_utils, only: calculateNumberMedianRadius + + implicit none + + public :: ndrop_init, dropmixnuc, activate_modal + + real(r8) :: t0 ! reference temperature + real(r8) :: aten + real(r8) :: surften ! surface tension of water w/respect to air (N/m) + real(r8) :: alog2, alog3, alogaten + real(r8) :: third, twothird, sixth, zero + real(r8) :: sq2, sqpi + + integer, parameter :: psat=7 ! number of supersaturations to calc ccn concentration + real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration + (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.15_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) + character(len=8) :: ccn_name(psat)= & + (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6','CCN7'/) + + ! indices in state and pbuf structures + integer :: numliq_idx = -1 + integer :: kvh_idx = -1 + + ! description of modal aerosols + integer :: ntot_amode ! number of aerosol modes + integer, allocatable :: nspec_amode(:) ! number of chemical species in each aerosol mode + real(r8), allocatable :: sigmag_amode(:)! geometric standard deviation for each aerosol mode + real(r8), allocatable :: dgnumlo_amode(:) + real(r8), allocatable :: dgnumhi_amode(:) + real(r8), allocatable :: voltonumblo_amode(:) + real(r8), allocatable :: voltonumbhi_amode(:) + + logical :: history_aerosol ! Output the MAM aerosol tendencies + character(len=fieldname_len), allocatable :: fieldname(:) ! names for drop nuc tendency output fields + character(len=fieldname_len), allocatable :: fieldname_cw(:) ! names for drop nuc tendency output fields + + ! local indexing for MAM + integer, allocatable :: mam_idx(:,:) ! table for local indexing of modal aero number and mmr + integer :: ncnst_tot ! total number of mode number conc + mode species + + ! Indices for MAM species in the ptend%q array. Needed for prognostic aerosol case. + integer, allocatable :: mam_cnst_idx(:,:) + + logical :: tendencyCounted(pcnst) = .false. ! set flags true for constituents with non-zero tendencies + integer :: n_aerosol_tracers + integer :: aerosolTracerList(pcnst) !List where indexes 1...n_aerosol_tracers are the indexes in pcnst + !..something like (/ l_so4_a1, l_bc_a, .../)etc + integer :: inverseAerosolTracerList(pcnst) !List where you can back the place in aerosolTracerList if you know the + !tracer index. So in the example above inverseAerosolTracerList(l_so4_a1) = 1 + + ! ptr2d_t is used to create arrays of pointers to 2D fields + type ptr2d_t + real(r8), pointer :: fld(:,:) + end type ptr2d_t + + ! modal aerosols + logical :: prog_modal_aero ! true when modal aerosols are prognostic + logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies !=============================================================================== contains !=============================================================================== -subroutine ndrop_init - - integer :: ii, l, lptr, m, mm - integer :: nspec_max ! max number of species in a mode - character(len=32) :: tmpname - character(len=32) :: tmpname_cw - character(len=128) :: long_name - character(len=8) :: unit - logical :: history_amwg ! output the variables used by the AMWG diag package -#ifdef OSLO_AERO - character(len=10) :: modeString - character(len=20) :: varname -#endif - - !------------------------------------------------------------------------------- - - ! get indices into state%q and pbuf structures - call cnst_get_ind('NUMLIQ', numliq_idx) - - kvh_idx = pbuf_get_index('kvh') - - zero = 0._r8 - third = 1._r8/3._r8 - twothird = 2._r8*third - sixth = 1._r8/6._r8 - sq2 = sqrt(2._r8) - sqpi = sqrt(pi) - - t0 = 273._r8 - surften = 0.076_r8 - aten = 2._r8*mwh2o*surften/(r_universal*t0*rhoh2o) - alogaten = log(aten) - alog2 = log(2._r8) - alog3 = log(3._r8) - - ! get info about the modal aerosols - ! get ntot_amode -#ifdef OSLO_AERO - ntot_amode = nmodes !from opttab -#else - call rad_cnst_get_info(0, nmodes=ntot_amode) -#endif - allocate( & - nspec_amode(ntot_amode), & - sigmag_amode(ntot_amode), & - dgnumlo_amode(ntot_amode), & - dgnumhi_amode(ntot_amode), & -#ifndef OSLO_AERO - alogsig(ntot_amode), & - exp45logsig(ntot_amode), & - f1(ntot_amode), & - f2(ntot_amode), & -#endif - voltonumblo_amode(ntot_amode), & - voltonumbhi_amode(ntot_amode) ) - -#ifdef OSLO_AERO - do m = 1,ntot_amode - nspec_amode(m) = getNumberOfTracersInMode(m) - enddo -#else - do m = 1, ntot_amode - ! use only if width of size distribution is prescribed - - ! get mode info - call rad_cnst_get_info(0, m, nspec=nspec_amode(m)) - - ! get mode properties - call rad_cnst_get_mode_props(0, m, sigmag=sigmag_amode(m), & - dgnumhi=dgnumhi_amode(m), dgnumlo=dgnumlo_amode(m)) - - alogsig(m) = log(sigmag_amode(m)) - exp45logsig(m) = exp(4.5_r8*alogsig(m)*alogsig(m)) - f1(m) = 0.5_r8*exp(2.5_r8*alogsig(m)*alogsig(m)) - f2(m) = 1._r8 + 0.25_r8*alogsig(m) - - voltonumblo_amode(m) = 1._r8 / ( (pi/6._r8)* & - (dgnumlo_amode(m)**3._r8)*exp(4.5_r8*alogsig(m)**2._r8) ) - voltonumbhi_amode(m) = 1._r8 / ( (pi/6._r8)* & - (dgnumhi_amode(m)**3._r8)*exp(4.5_r8*alogsig(m)**2._r8) ) - end do -#endif - ! Init the table for local indexing of mam number conc and mmr. - ! This table uses species index 0 for the number conc. - - ! Find max number of species in all the modes, and the total - ! number of mode number concentrations + mode species - nspec_max = nspec_amode(1) - ncnst_tot = nspec_amode(1) + 1 - do m = 2, ntot_amode - nspec_max = max(nspec_max, nspec_amode(m)) - ncnst_tot = ncnst_tot + nspec_amode(m) + 1 - end do - - allocate( & - mam_idx(ntot_amode,0:nspec_max), & - mam_cnst_idx(ntot_amode,0:nspec_max), & - fieldname(ncnst_tot), & - fieldname_cw(ncnst_tot) ) - - ! Local indexing compresses the mode and number/mass indicies into one index. - ! This indexing is used by the pointer arrays used to reference state and pbuf - ! fields. - ii = 0 - do m = 1, ntot_amode - do l = 0, nspec_amode(m) - ii = ii + 1 - mam_idx(m,l) = ii - end do - end do - - ! Add dropmixnuc tendencies for all modal aerosol species - - call phys_getopts(history_amwg_out = history_amwg, & - history_aerosol_out = history_aerosol, & - prog_modal_aero_out=prog_modal_aero) - -#ifdef OSLO_AERO - prog_modal_aero = .TRUE. - n_aerosol_tracers = getNumberOfAerosolTracers() - call fillAerosolTracerList(aerosolTracerList) - call fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) - do ii=1,n_aerosol_tracers - print*, "aerosolTracerList", ii, aerosolTracerList(ii), inverseAerosolTracerList(aerosolTracerList(ii)) - end do -#endif - -#ifdef OSLO_AERO - lq(:)=.FALSE. !Initialize - - !Set up tendencies for tracers (output) - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.false.) - - if(.NOT. lq(lptr))then - !add dropmixnuc tendencies - mm=mam_idx(m,l) - fieldname(mm)=trim(cnst_name(lptr))//"_mixnuc1" - fieldname_cw(mm)=trim(getCloudTracerName(lptr))//"_mixnuc1" - - long_name = trim(fieldname(mm)) // ' dropmixnuc column tendency' - call addfld(trim(fieldname(mm)), horiz_only ,'A', "kg/m2/s",long_name) - - long_name = trim(fieldname_cw(mm)) // ' dropmixnuc column tendency' - call addfld(trim(fieldname_cw(mm)), horiz_only, 'A', "kg/m2/s",long_name) - - if (history_aerosol) then - call add_default(trim(fieldname(mm)), 1, ' ') - call add_default(trim(fieldname_cw(mm)),1,' ') - endif - - !Do tendencies of this tracer - lq(lptr)=.TRUE. - endif - enddo - enddo - do m=1,ntot_amode - modeString=" " - write(modeString,"(I2)"),m - if(m .lt. 10) modeString="0"//adjustl(modeString) - varName = "NMR"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', 'm ', 'number median radius mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - varName = "NCONC"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', '#/m3 ', 'number concentration mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - varName = "VCONC"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', 'm3/m3 ','volume concentration mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - varName = "SIGMA"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', '-','Std. dev. mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - varName = "HYGRO"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A','-','Hygroscopicity '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - end do -#else - do m = 1, ntot_amode - do l = 0, nspec_amode(m) ! loop over number + chem constituents - - mm = mam_idx(m,l) - - unit = 'kg/m2/s' - if (l == 0) then ! number - unit = '#/m2/s' - end if - - if (l == 0) then ! number - call rad_cnst_get_info(0, m, num_name=tmpname, num_name_cw=tmpname_cw) - else - call rad_cnst_get_info(0, m, l, spec_name=tmpname, spec_name_cw=tmpname_cw) - end if - - fieldname(mm) = trim(tmpname) // '_mixnuc1' - fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' - - if (prog_modal_aero) then - - ! To set tendencies in the ptend object need to get the constituent indices - ! for the prognostic species - if (l == 0) then ! number - call rad_cnst_get_mode_num_idx(m, lptr) - else - call rad_cnst_get_mam_mmr_idx(m, l, lptr) - end if - mam_cnst_idx(m,l) = lptr - lq(lptr) = .true. - - ! Add tendency fields to the history only when prognostic MAM is enabled. - long_name = trim(tmpname) // ' dropmixnuc mixnuc column tendency' - call addfld(fieldname(mm), horiz_only, 'A', unit, long_name) - - long_name = trim(tmpname_cw) // ' dropmixnuc mixnuc column tendency' - call addfld(fieldname_cw(mm), horiz_only, 'A', unit, long_name) - - if (history_aerosol) then - call add_default(fieldname(mm), 1, ' ') - call add_default(fieldname_cw(mm), 1, ' ') - end if - - - - end if - - end do - end do - -#endif - -! call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%') -! call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%') -! call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%') -! call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%') -! call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%') -! call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%') -!akc6+ - call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%') - call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%') - call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%') - call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.15%') - call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%') - call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%') - call addfld('CCN7',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%') -!akc6- - -#ifdef OSLO_AERO - if(history_aerosol)then - do l = 1, psat - call add_default(ccn_name(l), 1, ' ') - enddo - end if -#endif - - call addfld('WTKE', (/ 'lev' /), 'A', 'm/s', 'Standard deviation of updraft velocity') - call addfld('NDROPMIX', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number mixing') - call addfld('NDROPSRC', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number source') - call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics') - call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number') - -#ifndef OSLO_AERO - - ! set the add_default fields - if (history_amwg) then - call add_default('CCN3', 1, ' ') - endif - - if (history_aerosol .and. prog_modal_aero) then - do m = 1, ntot_amode - do l = 0, nspec_amode(m) ! loop over number + chem constituents - mm = mam_idx(m,l) - if (l == 0) then ! number - call rad_cnst_get_info(0, m, num_name=tmpname, num_name_cw=tmpname_cw) - else - call rad_cnst_get_info(0, m, l, spec_name=tmpname, spec_name_cw=tmpname_cw) - end if - fieldname(mm) = trim(tmpname) // '_mixnuc1' - fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' - end do - end do - endif - -#endif - -end subroutine ndrop_init - -!=============================================================================== + subroutine ndrop_init + + integer :: ii, l, lptr, m, mm + integer :: nspec_max ! max number of species in a mode + character(len=32) :: tmpname + character(len=32) :: tmpname_cw + character(len=128) :: long_name + character(len=8) :: unit + logical :: history_amwg ! output the variables used by the AMWG diag package + character(len=10) :: modeString + character(len=20) :: varname + !------------------------------------------------------------------------------- + + ! get indices into state%q and pbuf structures + call cnst_get_ind('NUMLIQ', numliq_idx) + + kvh_idx = pbuf_get_index('kvh') + + zero = 0._r8 + third = 1._r8/3._r8 + twothird = 2._r8*third + sixth = 1._r8/6._r8 + sq2 = sqrt(2._r8) + sqpi = sqrt(pi) + + t0 = 273._r8 + surften = 0.076_r8 + aten = 2._r8*mwh2o*surften/(r_universal*t0*rhoh2o) + alogaten = log(aten) + alog2 = log(2._r8) + alog3 = log(3._r8) + + ! get info about the modal aerosols + ! get ntot_amode + ! TODO: make these local variables and don't allocate + ntot_amode = nmodes !from opttab + allocate( & + nspec_amode(ntot_amode), & + sigmag_amode(ntot_amode), & + dgnumlo_amode(ntot_amode), & + dgnumhi_amode(ntot_amode), & + voltonumblo_amode(ntot_amode), & + voltonumbhi_amode(ntot_amode) ) + + do m = 1,ntot_amode + nspec_amode(m) = getNumberOfTracersInMode(m) + enddo + + ! Init the table for local indexing of mam number conc and mmr. + ! This table uses species index 0 for the number conc. + + ! Find max number of species in all the modes, and the total + ! number of mode number concentrations + mode species + nspec_max = nspec_amode(1) + ncnst_tot = nspec_amode(1) + 1 + do m = 2, ntot_amode + nspec_max = max(nspec_max, nspec_amode(m)) + ncnst_tot = ncnst_tot + nspec_amode(m) + 1 + end do -subroutine dropmixnuc( & - state, ptend, dtmicro, pbuf, wsub, & ! Input - cldn, cldo, cldliqf, & - !++ MH_2015/09/07 - hasAerosol, & - CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, & - cam, f_acm, f_bcm, f_aqm, f_so4_condm, & - f_soam, & - numberConcentration, volumeConcentration, & - hygroscopicity, lnsigma, & - !-- MH_2015/09/07 - tendnd, & ! Output - !++ MH_2015/04/10 - fn_in, & - from_spcam ) - !-- MH_2015/04/10 - - ! vertical diffusion and nucleation of cloud droplets - ! assume cloud presence controlled by cloud fraction - ! doesn't distinguish between warm, cold clouds - - ! arguments - type(physics_state), target, intent(in) :: state - type(physics_ptend), intent(out) :: ptend - real(r8), intent(in) :: dtmicro ! time step for microphysics (s) - - type(physics_buffer_desc), pointer :: pbuf(:) - - ! arguments - real(r8), intent(in) :: wsub(pcols,pver) ! subgrid vertical velocity - real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction - real(r8), intent(in) :: cldo(pcols,pver) ! cloud fraction on previous time step - real(r8), intent(in) :: cldliqf(pcols,pver) ! liquid cloud fraction (liquid / (liquid + ice)) - logical, intent(in),optional :: from_spcam ! value insignificant - if variable present, is called from spcam - -!++ MH_2015/09/07 - logical, intent(in) :: hasAerosol(pcols, pver, nmodes) - real(r8), intent(in) :: CProcessModes(pcols,pver) - real(r8), intent(in) :: cam(pcols,pver,nbmodes) - real(r8), intent(in) :: f_c(pcols,pver) - real(r8), intent(in) :: f_aq(pcols,pver) - real(r8), intent(in) :: f_bc(pcols,pver) - real(r8), intent(in) :: f_so4_cond(pcols,pver) - real(r8), intent(in) :: f_soa(pcols,pver) - real(r8), intent(in) :: f_acm(pcols,pver, nbmodes) - real(r8), intent(in) :: f_bcm(pcols,pver, nbmodes) - real(r8), intent(in) :: f_aqm(pcols, pver, nbmodes) - real(r8), intent(in) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction - real(r8), intent(in) :: f_soam(pcols,pver,nbmodes) - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration - real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) ![-] hygroscopicity - real(r8), intent(in) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma -!-- MH_2015/09/07 - - ! output arguments - real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) - - !--------------------Local storage------------------------------------- - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of columns - - real(r8), pointer :: ncldwtr(:,:) ! droplet number concentration (#/kg) - real(r8), pointer :: temp(:,:) ! temperature (K) - real(r8), pointer :: omega(:,:) ! vertical velocity (Pa/s) - real(r8), pointer :: pmid(:,:) ! mid-level pressure (Pa) - real(r8), pointer :: pint(:,:) ! pressure at layer interfaces (Pa) - real(r8), pointer :: pdel(:,:) ! pressure thickess of layer (Pa) - real(r8), pointer :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) - real(r8), pointer :: zm(:,:) ! geopotential height of level (m) - - real(r8), pointer :: kvh(:,:) ! vertical diffusivity (m2/s) - - type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios - type(ptr2d_t), allocatable :: qqcw(:) - real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios - real(r8) :: qqcwtend(pver) ! tendency of cloudborne aerosol mass, number mixing ratios - - - real(r8), parameter :: zkmin = 0.01_r8, zkmax = 100._r8 - real(r8), parameter :: wmixmin = 0.1_r8 ! minimum turbulence vertical velocity (m/s) - real(r8) :: sq2pi - - integer :: i, k, l, m, mm, n - integer :: km1, kp1 - integer :: nnew, nsav, ntemp - integer :: lptr - integer :: nsubmix, nsubmix_bnd - integer, save :: count_submix(100) - integer :: phase ! phase of aerosol - - real(r8) :: arg - real(r8) :: dtinv - real(r8) :: dtmin, tinv, dtt - real(r8) :: lcldn(pcols,pver) - real(r8) :: lcldo(pcols,pver) - - real(r8) :: zs(pver) ! inverse of distance between levels (m) - real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) - real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries - real(r8) :: srcn(pver) ! droplet source rate (/s) - real(r8) :: cs(pcols,pver) ! air density (kg/m3) - real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) - real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) - real(r8) :: dz(pcols,pver) ! geometric thickness of layers (m) - - real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) - real(r8) :: wtke_cen(pcols,pver) ! turbulent vertical velocity at center of layer k (m/s) - real(r8) :: wbar, wmix, wmin, wmax - - real(r8) :: zn(pver) ! g/pdel (m2/g) for layer - real(r8) :: flxconv ! convergence of flux into lowest layer - - real(r8) :: wdiab ! diabatic vertical velocity - real(r8) :: ekd(pver) ! diffusivity for droplets (m2/s) - real(r8) :: ekk(0:pver) ! density*diffusivity for droplets (kg/m3 m2/s) - real(r8) :: ekkp(pver) ! zn*zs*density*diffusivity - real(r8) :: ekkm(pver) ! zn*zs*density*diffusivity - - real(r8) :: dum, dumc - real(r8) :: tmpa - real(r8) :: dact - real(r8) :: fluxntot ! (#/cm2/s) - real(r8) :: dtmix - real(r8) :: alogarg - real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap - - real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) - real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) - real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) - real(r8) :: cldo_tmp, cldn_tmp - real(r8) :: tau_cld_regenerate - real(r8) :: zeroaer(pver) - real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) - - - real(r8), allocatable :: nact(:,:) ! fractional aero. number activation rate (/s) - real(r8), allocatable :: mact(:,:) ! fractional aero. mass activation rate (/s) - - real(r8), allocatable :: raercol(:,:,:) ! single column of aerosol mass, number mixing ratios - real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase -#ifdef OSLO_AERO - !to avoid excessive calls to boundary layer scheme - real(r8), allocatable :: raercol_tracer(:,:,:) - real(r8), allocatable :: raercol_cw_tracer(:,:,:) - real(r8), allocatable :: mact_tracer(:,:) - real(r8), allocatable :: mfullact_tracer(:,:) -#endif - - real(r8) :: na(pcols), va(pcols), hy(pcols) - real(r8), allocatable :: naermod(:) ! (1/m3) - real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode - real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) - - real(r8) :: source(pver) - -!++ MH_2015/04/10 - real(r8), allocatable :: fn(:) ! activation fraction for aerosol number - real(r8), intent(out) :: fn_in(pcols,pver,0:nmodes) -!-- MH_2015/04/10 - real(r8), allocatable :: fm(:) ! activation fraction for aerosol mass - - real(r8), allocatable :: fluxn(:) ! number activation fraction flux (cm/s) - real(r8), allocatable :: fluxm(:) ! mass activation fraction flux (cm/s) - real(r8) :: flux_fullact(pver) ! 100% activation fraction flux (cm/s) - ! note: activation fraction fluxes are defined as - ! fluxn = [flux of activated aero. number into cloud (#/cm2/s)] - ! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] - - - real(r8), allocatable :: coltend(:,:) ! column tendency for diagnostic output - real(r8), allocatable :: coltend_cw(:,:) ! column tendency - real(r8) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat - - !for gas species turbulent mixing - real(r8), pointer :: rgas(:, :, :) - real(r8), allocatable :: rgascol(:, :, :) - real(r8), allocatable :: coltendgas(:) - real(r8) :: zerogas(pver) - character*200 fieldnamegas - - logical :: called_from_spcam - !------------------------------------------------------------------------------- -#ifdef OSLO_AERO - real(r8) :: numberMedianRadius(pcols,pver,nmodes) - real(r8) :: sigma(pcols,pver,nmodes) ![-] sigma - real(r8) :: constituentFraction - !++ MH_2015/04/10 - real(r8) :: volumeCore(pcols,pver,nmodes) - real(r8) :: volumeCoat(pcols,pver,nmodes) - !-- MH_2015/04/10 - integer :: tracerIndex - integer :: cloudTracerIndex - integer :: kcomp - integer :: speciesMap(nmodes) - !++ MH_2015/04/10 -! real(r8) :: fn_tmp(pcols,pver,nmodes) - real(r8), allocatable :: fn_tmp(:), fm_tmp(:) - !-- MH_2015/04/10 - real(r8), allocatable :: fluxn_tmp(:), fluxm_tmp(:) - real(r8) :: componentFraction - real(r8) :: componentFractionOK(pver,nmodes,pcnst) - real(r8) :: sumFraction - logical :: alert - real(r8), dimension(pver, pcnst) :: massBalance - real(r8), dimension(pver, pcnst) :: newMass - real(r8), dimension(pver,pcnst) :: newCloud, oldCloud, newAerosol, oldAerosol, deltaCloud - integer :: kCrit, lptr2 - logical :: stopMe - integer :: iDebug=1, lDebug=15 - real(r8) :: mixRatioToMass - real(r8),dimension(pcnst) :: debugSumFraction - real(r8), allocatable :: lnsigman(:) - character(len=2) :: modeString - character(len=20) :: varname -#endif - integer :: numberOfModes -!------------------------------------------------------------------------------- -#undef EXTRATESTS -#undef MASS_BALANCE_CHECK - - sq2pi = sqrt(2._r8*pi) - - lchnk = state%lchnk - ncol = state%ncol - - ncldwtr => state%q(:,:,numliq_idx) - temp => state%t - omega => state%omega - pmid => state%pmid - pint => state%pint - pdel => state%pdel - rpdel => state%rpdel - zm => state%zm - - call pbuf_get_field(pbuf, kvh_idx, kvh) - - ! Create the liquid weighted cloud fractions that were passsed in - ! before. This doesn't seem like the best variable, since the cloud could - ! have liquid condensate, but the part of it that is changing could be the - ! ice portion; however, this is what was done before. - lcldo(:ncol,:) = cldo(:ncol,:) * cldliqf(:ncol,:) - lcldn(:ncol,:) = cldn(:ncol,:) * cldliqf(:ncol,:) - - - arg = 1.0_r8 - if (abs(0.8427_r8 - erf(arg))/0.8427_r8 > 0.001_r8) then - write(iulog,*) 'erf(1.0) = ',ERF(arg) - call endrun('dropmixnuc: Error function error') - endif - arg = 0.0_r8 - if (erf(arg) /= 0.0_r8) then - write(iulog,*) 'erf(0.0) = ',erf(arg) - write(iulog,*) 'dropmixnuc: Error function error' - call endrun('dropmixnuc: Error function error') - endif - - dtinv = 1._r8/dtmicro - - allocate( & - nact(pver,ntot_amode), & - mact(pver,ntot_amode), & - raer(ncnst_tot), & - qqcw(ncnst_tot), & - raercol(pver,ncnst_tot,2), & - raercol_cw(pver,ncnst_tot,2), & - coltend(pcols,ncnst_tot), & - coltend_cw(pcols,ncnst_tot), & - naermod(ntot_amode), & - hygro(ntot_amode), & -#ifdef OSLO_AERO - lnsigman(ntot_amode), & !variable std. deviation (CAM-Oslo) - raercol_tracer(pver,n_aerosol_tracers,2), & - raercol_cw_tracer(pver,n_aerosol_tracers,2), & - mact_tracer(pver,n_aerosol_tracers), & - mfullact_tracer(pver,n_aerosol_tracers), & -#endif - vaerosol(ntot_amode), & - fn(ntot_amode), & - fm(ntot_amode), & - fluxn(ntot_amode), & - fluxm(ntot_amode) ) - - ! Init pointers to mode number and specie mass mixing ratios in - ! intersitial and cloud borne phases. -#ifdef OSLO_AERO - !Need a list of all aerosol species ==> store in raer (mm) - ! or qqcw for cloud-borne aerosols (?) - do m=1,nmodes !All aerosol modes - - !NOTE: SEVERAL POINTERS POINT TO SAME FIELD, E.G. CONDENSATE WHICH IS IN SEVERAL MODES - do l = 1, nspec_amode(m) - tracerIndex = getTracerIndex(m,l,.false.) !Index in q - cloudTracerIndex = getCloudTracerIndex(m,l) !Index in phys-buffer - mm = mam_idx(m,l) !Index in raer/qqcw - raer(mm)%fld => state%q(:,:,tracerIndex) !NOTE: These are total fields (for example condensate) - call pbuf_get_field(pbuf, CloudTracerIndex, qqcw(mm)%fld) !NOTE: These are total fields (for example condensate) -#ifdef EXTRATESTS -! if(tracerIndex .eq. ldebug)then -! do k=1,pver -! print*,"pointer check",k,m,l,mm,tracerIndex, raer(mm)%fld(idebug,k), state%q(idebug,k,tracerIndex) -! end do -! endf -#endif - enddo - enddo - allocate( & - fn_tmp(ntot_amode), & - fm_tmp(ntot_amode), & - fluxn_tmp(ntot_amode), & - fluxm_tmp(ntot_amode) ) -#else - do m = 1, ntot_amode - mm = mam_idx(m, 0) - call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, raer(mm)%fld) - call rad_cnst_get_mode_num(0, m, 'c', state, pbuf, qqcw(mm)%fld) ! cloud-borne aerosol - do l = 1, nspec_amode(m) - mm = mam_idx(m, l) - call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, raer(mm)%fld) - call rad_cnst_get_aer_mmr(0, m, l, 'c', state, pbuf, qqcw(mm)%fld) ! cloud-borne aerosol - end do - end do -#endif - - called_from_spcam = (present(from_spcam)) - - if (called_from_spcam) then - rgas => state%q - allocate(rgascol(pver, pcnst, 2)) - allocate(coltendgas(pcols)) - endif - wtke = 0._r8 - - if (prog_modal_aero) then - ! aerosol tendencies - call physics_ptend_init(ptend, state%psetcols, 'ndrop', lq=lq) - else - ! no aerosol tendencies - call physics_ptend_init(ptend, state%psetcols, 'ndrop') - end if - -#ifdef OSLO_AERO - !Improve this later by using only cloud points ? - do k = top_lev, pver - do i=1,ncol - cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) - end do - end do - - !Output this - call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) - do n=1,nmodes - sigma(:ncol,:,n) = DEXP(lnSigma(:ncol,:,n)) - modeString=" " - write(modeString,"(I2)"),n - if(n .lt. 10) modeString="0"//adjustl(modeString) - varName = "NMR"//trim(modeString) - call outfld(varName, numberMedianRadius(:,:,n), pcols, lchnk) - varName = "NCONC"//trim(modeString) - call outfld(varName, numberConcentration(:,:,n),pcols, lchnk) - varName = "VCONC"//trim(modeString) - call outfld(varName, volumeConcentration(:,:,n), pcols,lchnk) - varName = "SIGMA"//trim(modeString) - call outfld(varName, sigma(:,:,n), pcols,lchnk) - varName = "HYGRO"//trim(modeString) - call outfld(varName, hygroscopicity(:,:,n), pcols,lchnk) + allocate( & + mam_idx(ntot_amode,0:nspec_max), & + mam_cnst_idx(ntot_amode,0:nspec_max), & + fieldname(ncnst_tot), & + fieldname_cw(ncnst_tot) ) + + ! Local indexing compresses the mode and number/mass indicies into one index. + ! This indexing is used by the pointer arrays used to reference state and pbuf + ! fields. + ii = 0 + do m = 1, ntot_amode + do l = 0, nspec_amode(m) + ii = ii + 1 + mam_idx(m,l) = ii end do + end do - alert = .FALSE. - do k=top_lev,pver - mm = k - top_lev + 1 - do m=1,nmodes - if(.NOT. alert .and. & - ANY(numberConcentration(:ncol,k,m) .lt. 0.0_r8 ))then - alert = .TRUE. - lptr = k - print*,"STRANGE numberconc", m, minval(numberConcentration(:,:,:))*1.e-6_r8, "#/cm3", k, mm - endif - enddo - enddo - - - if(alert)then - print*,"strange stuff here " - stop - - !do m=1,nmodes - ! print*,"numberconc (after alert)", m, modedefs(1)%nnatk(m)*1.e-6_r8, "#/cm3" & - ! ,modedefs(1)%C(m)*1.0e9_r8, "ug/m3" - - ! if(modedefs(1)%nnatk(m) > 1.e-30_r8)then - ! print*, "final weight per particle ",m, modedefs(1)%C(m)/modedefs(1)%nnatk(m) - ! endif - !end do - !stop - endif - -#endif - - ! overall_main_i_loop - do i = 1, ncol - -#ifdef OSLO_AERO - coltend(i,:)=0.0_r8 - coltend_cw(i,:) = 0.0_r8 -#endif - - do k = top_lev, pver-1 - zs(k) = 1._r8/(zm(i,k) - zm(i,k+1)) - end do - zs(pver) = zs(pver-1) - - ! load number nucleated into qcld on cloud boundaries - - do k = top_lev, pver - - qcld(k) = ncldwtr(i,k) - qncld(k) = 0._r8 - srcn(k) = 0._r8 - cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) - dz(i,k) = 1._r8/(cs(i,k)*gravit*rpdel(i,k)) ! layer thickness in m - - do m = 1, ntot_amode - nact(k,m) = 0._r8 - mact(k,m) = 0._r8 - end do - - zn(k) = gravit*rpdel(i,k) - - if (k < pver) then - ekd(k) = kvh(i,k+1) - ekd(k) = max(ekd(k), zkmin) - ekd(k) = min(ekd(k), zkmax) - csbot(k) = 2.0_r8*pint(i,k+1)/(rair*(temp(i,k) + temp(i,k+1))) - csbot_cscen(k) = csbot(k)/cs(i,k) - else - ekd(k) = 0._r8 - csbot(k) = cs(i,k) - csbot_cscen(k) = 1.0_r8 - end if - - ! rce-comment - define wtke at layer centers for new-cloud activation - ! and at layer boundaries for old-cloud activation - !++ag - wtke_cen(i,k) = wsub(i,k) - wtke(i,k) = wsub(i,k) - !--ag - wtke_cen(i,k) = max(wtke_cen(i,k), wmixmin) - wtke(i,k) = max(wtke(i,k), wmixmin) - - nsource(i,k) = 0._r8 - - end do ! k - - nsav = 1 - nnew = 2 -#ifdef OSLO_AERO - - !get constituent fraction - componentFractionOK(:,:,:) = 0.0_r8 - do k=top_lev, pver - do m = 1,ntot_amode - if(m .le. nbmodes)then - do l = 1, nspec_amode(m) - !calculate fraction of component "l" in mode "m" based on concentrations in clear air - componentFractionOK(k,m,getTracerIndex(m,l,.false.)) & - = getConstituentFraction(CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) & - ,Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), f_so4_condm(i,k,m) , f_soam(i,k,m), getTracerIndex(m,l,.false.) ) - end do - else - do l = 1, nspec_amode(m) - componentFractionOK(k,m,getTracerIndex(m,l,.false.)) = 1.0_r8 - end do - endif - end do - - !Loop over all tracers ==> check that sums to one - !for all tracers which exist in the oslo-modes - do l=1,pcnst - sumFraction = 0.0_r8 - do m=1,ntot_amode - sumFraction = sumFraction + componentFractionOK(k,m,l) - end do - if(sumFraction .gt. 1.e-2_r8)then !Just scale what comes out if componentFraction is larger than 1% - do m=1,ntot_amode - componentFractionOK(k,m,l) = & - componentFractionOK(k,m,l)/sumFraction - end do - else !negative or zero fraction for this species - !distribute equal fraction to all receiver modes - sumFraction = 0.0_r8 - do m=1,ntot_amode - do lptr=1,getNumberOfTracersInMode(m) - if(getTracerIndex(m,lptr,.FALSE.) .eq. l ) then - sumFraction = sumFraction + 1.0_r8 - endif - end do ! tracers in mode - end do ! mode - do m=1,ntot_amode - componentFractionOK(k,m,l)=1.0_r8/max(1.e-30_r8, sumFraction) - end do !modes - endif - end do !tracers - end do !levels - !debug sum fraction for "i" done - - - - debugSumFraction(:) = 0.0_r8 !sum of component lDebug in level k - do m = 1, nmodes ! Number of modes - !Get number concentration of this mode - mm =mam_idx(m,0) - do k= top_lev,pver - raercol(k,mm,nsav) = numberConcentration(i,k,m)/cs(i,k) !#/kg air - !In oslo model, number concentrations are diagnostics, so - !Approximate number concentration in each mode by total - !cloud number concentration scaled by how much is available of - !each mode - raercol_cw(k,mm,nsav) = ncldwtr(i,k)*numberConcentration(i,k,m)& - /max(1.e-30_r8, sum(numberConcentration(i,k,1:nmodes))) - enddo - - !These are the mass mixing ratios - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) !index of tracer (all unique) - raercol(:,mm,nsav) = 0.0_r8 - raercol_cw(:,mm,nsav) = 0.0_r8 - !Several of the fields (raer(mm)%fld point to the same - !field in q. To avoid double counting, we take into - !account the component fraction in the mode - do k=top_lev,pver - if(m .gt. nbmodes) then - componentFraction = 1.0_r8 - else - componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) - endif -#ifdef EXTRATESTS - if(i .eq. iDebug .and. getTracerIndex(m,l,.false.) .eq. lDebug)then - !print*,"componentFraction", i,cnst_name(oslo_cnst_idx(m,l)),componentFraction - print*,"assigning cloud/aerosol", k,m,l,qqcw(mm)%fld(i,k), raer(mm)%fld(i,k) & - ,componentFraction - debugSumFraction(k) = debugSumFraction(k) + componentFraction - endif - if(componentFraction > 1.0_r8)then - print*, "wrong component fraction", componentFraction - stop - call endrun("wrong component fraction") - endif -#endif - !Assign to the components used here i.e. distribute condensate/coagulate to modes - raercol_cw(k,mm,nsav) = qqcw(mm)%fld(i,k)*componentFraction - raercol(k,mm,nsav) = raer(mm)%fld(i,k)*componentFraction - enddo ! k (levels) - end do ! l (species) - end do ! m (modes) -#ifdef EXTRATESTS - do k=top_lev,pver - if(i .eq. iDebug .and. (abs(debugSumFraction(k)-1.0_r8).gt.1.e-2_r8) .and. debugSumFraction(k).gt.1.e-6_r8)then - print*, "debugSumFraction", cnst_name(getTracerIndex(m,l,.false.)),i, k, debugSumFraction(k), abs(debugSumFraction(k)-1.0_r8) - componentFraction=0.0_r8 - do m=1,nbmodes - componentFraction = componentFraction + cam(i,k,m) - print*, "MODECONC", m, cam(i,k,m), numberConcentration(i,k,m) - end do - print*, "CS, sumCAM", CProcessModes(i,k), sum(cam(i,k,1:nbmodes)), componentFraction - print*, "q (cond)", state%q(i,k,lDebug)*cs(i,k)!mass in q - print*, "q (aq) " ,state%q(i,k,l_so4_a2)*cs(i,k) - print*, "bulk fractions", f_so4_cond(i,k),f_c(i,k), f_bc(i,k), f_aq(i,k) - !print*, "other levels", debugSumFraction(:) - do m=1,nmodes - do l=1,nspec_amode(m) - if(getTracerIndex(m,l,.false.) == ldebug)then - if(m .gt. nbmodes)then - componentFraction = 1.0_r8 - else - componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) - endif - print*, "nmode, l,k, ", m,l,k , lDebug, componentFraction, cam(i,k,m), f_aqm(i,k,m), f_acm(i,k,m), f_so4_condm(i,k,m) - print*, "fraction2 ", cam(i,k,m), cam(i,k,m)/CProcessModes(i,k)*100.0_r8, " %" - endif - enddo - enddo - call endrun("wrong debugsumfraction") - endif !idebug/ldebug - enddo -#endif - !END OSLO-STUFF, BELOW IS MAM 3 -#else - do m = 1, ntot_amode - mm = mam_idx(m,0) - raercol_cw(:,mm,nsav) = 0.0_r8 - raercol(:,mm,nsav) = 0.0_r8 - raercol_cw(top_lev:pver,mm,nsav) = qqcw(mm)%fld(i,top_lev:pver) - raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - raercol_cw(top_lev:pver,mm,nsav) = qqcw(mm)%fld(i,top_lev:pver) - raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) - end do - end do -#endif - - - if (called_from_spcam) then - ! - ! In the MMF model, turbulent mixing for tracer species are turned off. - ! So the turbulent for gas species mixing are added here. - ! (Previously, it had the turbulent mixing for aerosol species) - ! - do m=1, pcnst - if (cnst_species_class(m) == cnst_spec_class_gas) rgascol(:,m,nsav) = rgas(i,:,m) - end do - - endif - - ! droplet nucleation/aerosol activation - - ! tau_cld_regenerate = time scale for regeneration of cloudy air - ! by (horizontal) exchange with clear air - tau_cld_regenerate = 3600.0_r8 * 3.0_r8 - - if (called_from_spcam) then - ! when this is called in the MMF part, no cloud regeneration and decay. - ! set the time scale be very long so that no cloud regeneration. - tau_cld_regenerate = 3600.0_r8 * 24.0_r8 * 365.0_r8 - endif - - - ! k-loop for growing/shrinking cloud calcs ............................. - ! grow_shrink_main_k_loop: & - do k = top_lev, pver - - ! This code was designed for liquid clouds, but the cloudbourne - ! aerosol can be either from liquid or ice clouds. For the ice clouds, - ! we do not do regeneration, but as cloud fraction decreases the - ! aerosols should be returned interstitial. The lack of a liquid cloud - ! should not mean that all of the aerosol is realease. Therefor a - ! section has been added for shrinking ice clouds and checks were added - ! to protect ice cloudbourne aerosols from being released when no - ! liquid cloud is present. - - ! shrinking ice cloud ...................................................... - cldo_tmp = cldo(i,k) * (1._r8 - cldliqf(i,k)) - cldn_tmp = cldn(i,k) * (1._r8 - cldliqf(i,k)) - - if (cldn_tmp < cldo_tmp) then - - ! convert activated aerosol to interstitial in decaying cloud - - dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * (1._r8 - cldliqf(i,k)) - do m = 1, ntot_amode - mm = mam_idx(m,0) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - end do - end do - end if - - ! shrinking liquid cloud ...................................................... - ! treat the reduction of cloud fraction from when cldn(i,k) < cldo(i,k) - ! and also dissipate the portion of the cloud that will be regenerated - cldo_tmp = lcldo(i,k) - cldn_tmp = lcldn(i,k) * exp( -dtmicro/tau_cld_regenerate ) - ! alternate formulation - ! cldn_tmp = cldn(i,k) * max( 0.0_r8, (1.0_r8-dtmicro/tau_cld_regenerate) ) - - ! fraction is also provided. - if (cldn_tmp < cldo_tmp) then - ! droplet loss in decaying cloud - !++ sungsup - nsource(i,k) = nsource(i,k) + qcld(k)*(cldn_tmp - cldo_tmp)/cldo_tmp*cldliqf(i,k)*dtinv - qcld(k) = qcld(k)*(1._r8 + (cldn_tmp - cldo_tmp)/cldo_tmp) - !-- sungsup - - ! convert activated aerosol to interstitial in decaying cloud - - dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * cldliqf(i,k) - do m = 1, ntot_amode - mm = mam_idx(m,0) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact -#ifdef EXTRATESTS - if(i.eq. iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then - print*,"decaying cloud", k, dact, cldn_tmp, cldo_tmp - endif -#endif - end do - end do - end if - - ! growing liquid cloud ...................................................... - ! treat the increase of cloud fraction from when cldn(i,k) > cldo(i,k) - ! and also regenerate part of the cloud - cldo_tmp = cldn_tmp - cldn_tmp = lcldn(i,k) - - if (cldn_tmp-cldo_tmp > 0.01_r8) then - - ! rce-comment - use wtke at layer centers for new-cloud activation - wbar = wtke_cen(i,k) - wmix = 0._r8 - wmin = 0._r8 - wmax = 10._r8 - wdiab = 0._r8 - - ! load aerosol properties, assuming external mixtures - -#ifdef OSLO_AERO - naermod(:) = 0.0_r8 - vaerosol(:) = 0.0_r8 - hygro(:) = 0.0_r8 - lnsigman(:) = log(2.0_r8) - - m=0 - do kcomp = 1,nmodes - if(hasAerosol(i,k,kcomp) .eqv. .TRUE.)then - m = m + 1 - naermod(m) = numberConcentration(i,k,kcomp) - vaerosol(m) = volumeConcentration(i,k,kcomp) - hygro(m) = hygroscopicity(i,k,kcomp) - lnsigman(m) = lnsigma(i,k,kcomp) - speciesMap(m) = kcomp - end if - end do - numberOfModes = m -#else - numberOfModes = ntot_amode - phase = 1 ! interstitial - do m = 1, ntot_amode - call loadaer( & - state, pbuf, i, i, k, & - m, cs, phase, na, va, & - hy) - naermod(m) = na(i) - vaerosol(m) = va(i) - hygro(m) = hy(i) - end do -#endif - !++ MH_2015/04/10 - !Call the activation procedure - if(numberOfModes .gt. 0)then - if (use_hetfrz_classnuc) then - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes, & - vaerosol, hygro, fn_in(i,k,1:nmodes), fm, fluxn, & - fluxm,flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - else - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes, & - vaerosol, hygro, fn, fm, fluxn, & - fluxm,flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - end if - !-- MH_2015/04/10 - endif - - dumc = (cldn_tmp - cldo_tmp) -#ifdef OSLO_AERO - if (use_hetfrz_classnuc) then - fn_tmp(:) = fn_in(i,k,1:nmodes) - else - fn_tmp(:) = fn(:) - end if - fm_tmp(:) = fm(:) - fluxn_tmp(:) = fluxn(:) - fluxm_tmp(:) = fluxm(:) - fn(:) = 0.0_r8 - fn_in(i,k,:) = 0.0_r8 - fm(:) = 0.0_r8 - fluxn(:)=0.0_r8 - fluxm(:)= 0.0_r8 - do m = 1, numberOfModes !Number of coexisting modes to be used for activation - kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) - if (use_hetfrz_classnuc) then - fn_in(i,k,kcomp) = fn_tmp(m) - else - fn(kcomp) = fn_tmp(m) - end if - fm(kcomp) = fm_tmp(m) - fluxn(kcomp) = fluxn_tmp(m) - fluxm(kcomp) = fluxm_tmp(m) - enddo -#endif - do m = 1, ntot_amode - mm = mam_idx(m,0) -#ifdef OSLO_AERO - if (use_hetfrz_classnuc) then - dact = dumc*fn_in(i,k,m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} - else - dact = dumc*fn(m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} - end if -#else - if (use_hetfrz_classnuc) then - dact = dumc*fn_in(i,k,m)*raer(mm)%fld(i,k) ! interstitial only - else - dact = dumc*fn(m)*raer(mm)%fld(i,k) ! interstitial only - end if -#endif - qcld(k) = qcld(k) + dact - nsource(i,k) = nsource(i,k) + dact*dtinv - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - dum = dumc*fm(m) - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) -#ifdef OSLO_AERO - if(m .gt. nbmodes)then - constituentFraction = 1.0_r8 - else - constituentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.) ) - endif - - dact = dum*raer(mm)%fld(i,k)*constituentFraction -#else - dact = dum*raer(mm)%fld(i,k) ! interstitial only -#endif - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact -#ifdef EXTRATESTS - if(i.eq.iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then - print*,"growing cloud (new/old)", k, raercol_cw(k,mm,nsav), raercol_cw(k,mm,nsav)-dact & - ,raercol(k,mm,nsav),raercol(k,mm,nsav)+dact,dact - endif -#endif - enddo - enddo - endif ! cldn_tmp-cldo_tmp > 0.01_r8 - - enddo ! grow_shrink_main_k_loop - ! end of k-loop for growing/shrinking cloud calcs ...................... - - ! ...................................................................... - ! start of k-loop for calc of old cloud activation tendencies .......... - ! - ! rce-comment - ! changed this part of code to use current cloud fraction (cldn) exclusively - ! consider case of cldo(:)=0, cldn(k)=1, cldn(k+1)=0 - ! previous code (which used cldo below here) would have no cloud-base activation - ! into layer k. however, activated particles in k mix out to k+1, - ! so they are incorrectly depleted with no replacement - - ! old_cloud_main_k_loop - do k = top_lev, pver - kp1 = min0(k+1, pver) - taumix_internal_pver_inv = 0.0_r8 - - if (lcldn(i,k) > 0.01_r8) then - - wdiab = 0._r8 - wmix = 0._r8 ! single updraft - wbar = wtke(i,k) ! single updraft - if (k == pver) wbar = wtke_cen(i,k) ! single updraft - wmax = 10._r8 - wmin = 0._r8 - - if (lcldn(i,k) - lcldn(i,kp1) > 0.01_r8 .or. k == pver) then - - ! cloud base - - ! ekd(k) = wtke(i,k)*dz(i,k)/sq2pi - ! rce-comments - ! first, should probably have 1/zs(k) here rather than dz(i,k) because - ! the turbulent flux is proportional to ekd(k)*zs(k), - ! while the dz(i,k) is used to get flux divergences - ! and mixing ratio tendency/change - ! second and more importantly, using a single updraft velocity here - ! means having monodisperse turbulent updraft and downdrafts. - ! The sq2pi factor assumes a normal draft spectrum. - ! The fluxn/fluxm from activate must be consistent with the - ! fluxes calculated in explmix. - ekd(k) = wbar/zs(k) - - alogarg = max(1.e-20_r8, 1._r8/lcldn(i,k) - 1._r8) - wmin = wbar + wmix*0.25_r8*sq2pi*log(alogarg) - phase = 1 ! interstitial -#ifdef OSLO_AERO - naermod(:) = 0.0_r8 - vaerosol(:) = 0.0_r8 - hygro(:) = 0.0_r8 - lnsigman(:) = log(2.0_r8) - - m=0 - do kcomp = 1,nmodes - if(hasAerosol(i,kp1,kcomp) .eqv. .TRUE.)then - m = m + 1 - naermod(m) = numberConcentration(i,kp1,kcomp) - vaerosol(m) = volumeConcentration(i,kp1,kcomp) - hygro(m) = hygroscopicity(i,kp1,kcomp) - lnsigman(m) = lnsigma(i,kp1,kcomp) - speciesMap(m) = kcomp - end if - end do - numberOfModes = m -#else - numberOfModes = ntot_amode - - do m = 1, ntot_amode - ! rce-comment - use kp1 here as old-cloud activation involves - ! aerosol from layer below - call loadaer( & - state, pbuf, i, i, kp1, & - m, cs, phase, na, va, & - hy) - naermod(m) = na(i) - vaerosol(m) = va(i) - hygro(m) = hy(i) - end do -#endif - !++ MH_2015/04/10 - if(numberOfModes .gt. 0)then - if (use_hetfrz_classnuc) then - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn_in(i,k,:), fm, fluxn, & - fluxm, flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - else - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn, fm, fluxn, & - fluxm, flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - end if - !-- MH_2015/04/10 - endif - - !Difference in cloud fraction this layer and above! - !we are here because there are more clouds above, and some - !aerosols go into that layer! ==> calculate additional cloud fraction - if (k < pver) then - dumc = lcldn(i,k) - lcldn(i,kp1) - else - dumc = lcldn(i,k) - endif - -#ifdef OSLO_AERO - if (use_hetfrz_classnuc) then - fn_tmp(:) = fn_in(i,k,1:nmodes) - else - fn_tmp(:) = fn(:) - end if - fm_tmp(:) = fm(:) - fluxn_tmp(:) = fluxn(:) - fluxm_tmp(:) = fluxm(:) - fn(:) = 0.0_r8 - fn_in(i,k,:) = 0.0_r8 - fm(:) = 0.0_r8 - fluxn(:)=0.0_r8 - fluxm(:)= 0.0_r8 - do m = 1, numberOfModes !Number of coexisting modes to be used for activation - kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) - if (use_hetfrz_classnuc) then - fn_in(i,k,kcomp) = fn_tmp(m) - else - fn(kcomp) = fn_tmp(m) - end if - fm(kcomp) = fm_tmp(m) - fluxn(kcomp) = fluxn_tmp(m) - fluxm(kcomp) = fluxm_tmp(m) - enddo -#endif - - fluxntot = 0.0_r8 - - ! rce-comment 1 - ! flux of activated mass into layer k (in kg/m2/s) - ! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) - ! source of activated mass (in kg/kg/s) = flux divergence - ! = actmassflux/(cs(i,k)*dz(i,k)) - ! so need factor of csbot_cscen = csbot(k)/cs(i,k) - ! dum=1./(dz(i,k)) - dum=csbot_cscen(k)/(dz(i,k)) - - ! rce-comment 2 - ! code for k=pver was changed to use the following conceptual model - ! in k=pver, there can be no cloud-base activation unless one considers - ! a scenario such as the layer being partially cloudy, - ! with clear air at bottom and cloudy air at top - ! assume this scenario, and that the clear/cloudy portions mix with - ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) - ! in the absence of other sources/sinks, qact (the activated particle - ! mixratio) attains a steady state value given by - ! qact_ss = fcloud*fact*qtot - ! where fcloud is cloud fraction, fact is activation fraction, - ! qtot=qact+qint, qint is interstitial particle mixratio - ! the activation rate (from mixing within the layer) can now be - ! written as - ! d(qact)/dt = (qact_ss - qact)/taumix_internal - ! = qtot*(fcloud*fact*wtke/dz) - qact*(wtke/dz) - ! note that (fcloud*fact*wtke/dz) is equal to the nact/mact - ! also, d(qact)/dt can be negative. in the code below - ! it is forced to be >= 0 - ! - ! steve -- - ! you will likely want to change this. i did not really understand - ! what was previously being done in k=pver - ! in the cam3_5_3 code, wtke(i,pver) appears to be equal to the - ! droplet deposition velocity which is quite small - ! in the cam3_5_37 version, wtke is done differently and is much - ! larger in k=pver, so the activation is stronger there - ! - if (k == pver) then - taumix_internal_pver_inv = flux_fullact(k)/dz(i,k) - end if - - do m = 1, ntot_amode - mm = mam_idx(m,0) - fluxn(m) = fluxn(m)*dumc - fluxm(m) = fluxm(m)*dumc - nact(k,m) = nact(k,m) + fluxn(m)*dum - mact(k,m) = mact(k,m) + fluxm(m)*dum - if (k < pver) then - ! note that kp1 is used here - fluxntot = fluxntot & - + fluxn(m)*raercol(kp1,mm,nsav)*cs(i,k) - else - tmpa = raercol(kp1,mm,nsav)*fluxn(m) & - + raercol_cw(kp1,mm,nsav)*(fluxn(m) & - - taumix_internal_pver_inv*dz(i,k)) - fluxntot = fluxntot + max(0.0_r8, tmpa)*cs(i,k) - end if - end do - srcn(k) = srcn(k) + fluxntot/(cs(i,k)*dz(i,k)) - nsource(i,k) = nsource(i,k) + fluxntot/(cs(i,k)*dz(i,k)) -#ifdef EXTRATESTS - if(fluxntot/(cs(i,k)*dz(i,k)) > 0.0_r8 )then - print*,"activated/available(from below)",i,k,m,fluxntot/(cs(i,k)*dz(i,k)) - endif -#endif - endif ! (cldn(i,k) - cldn(i,kp1) > 0.01 .or. k == pver) - - else ! i.e: cldn(i,k) < 0.01_r8 - - ! no liquid cloud - - nsource(i,k) = nsource(i,k) - qcld(k)*dtinv - qcld(k) = 0.0_r8 - - if (cldn(i,k) < 0.01_r8) then - ! no ice cloud either - - ! convert activated aerosol to interstitial in decaying cloud - - do m = 1, ntot_amode - mm = mam_idx(m,0) - raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol - raercol_cw(k,mm,nsav) = 0._r8 - - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) -#ifdef EXTRATESTS - if(i.eq.iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then - print*,"no cloud", k, raercol(k,mm,nsav) , raercol_cw(k,mm,nsav) - endif -#endif - raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol - raercol_cw(k,mm,nsav) = 0._r8 - end do - end do - end if - end if - - end do ! old_cloud_main_k_loop - - ! switch nsav, nnew so that nnew is the updated aerosol - ntemp = nsav - nsav = nnew - nnew = ntemp - - ! load new droplets in layers above, below clouds - - dtmin = dtmicro - ekk(top_lev-1) = 0.0_r8 - ekk(pver) = 0.0_r8 - do k = top_lev, pver-1 - ! rce-comment -- ekd(k) is eddy-diffusivity at k/k+1 interface - ! want ekk(k) = ekd(k) * (density at k/k+1 interface) - ! so use pint(i,k+1) as pint is 1:pverp - ! ekk(k)=ekd(k)*2.*pint(i,k)/(rair*(temp(i,k)+temp(i,k+1))) - ! ekk(k)=ekd(k)*2.*pint(i,k+1)/(rair*(temp(i,k)+temp(i,k+1))) - ekk(k) = ekd(k)*csbot(k) - end do - - do k = top_lev, pver - km1 = max0(k-1, top_lev) - ekkp(k) = zn(k)*ekk(k)*zs(k) - ekkm(k) = zn(k)*ekk(k-1)*zs(km1) - tinv = ekkp(k) + ekkm(k) - - ! rce-comment -- tinv is the sum of all first-order-loss-rates - ! for the layer. for most layers, the activation loss rate - ! (for interstitial particles) is accounted for by the loss by - ! turb-transfer to the layer above. - ! k=pver is special, and the loss rate for activation within - ! the layer must be added to tinv. if not, the time step - ! can be too big, and explmix can produce negative values. - ! the negative values are reset to zero, resulting in an - ! artificial source. - if (k == pver) tinv = tinv + taumix_internal_pver_inv - - if (tinv .gt. 1.e-6_r8) then - dtt = 1._r8/tinv - dtmin = min(dtmin, dtt) - end if - end do - - dtmix = 0.9_r8*dtmin - nsubmix = dtmicro/dtmix + 1 - if (nsubmix > 100) then - nsubmix_bnd = 100 - else - nsubmix_bnd = nsubmix - end if - count_submix(nsubmix_bnd) = count_submix(nsubmix_bnd) + 1 - dtmix = dtmicro/nsubmix - - do k = top_lev, pver - kp1 = min(k+1, pver) - km1 = max(k-1, top_lev) - ! maximum overlap assumption - if (cldn(i,kp1) > 1.e-10_r8) then - overlapp(k) = min(cldn(i,k)/cldn(i,kp1), 1._r8) - else - overlapp(k) = 1._r8 - end if - if (cldn(i,km1) > 1.e-10_r8) then - overlapm(k) = min(cldn(i,k)/cldn(i,km1), 1._r8) - else - overlapm(k) = 1._r8 - end if - end do - - - ! rce-comment - ! the activation source(k) = mact(k,m)*raercol(kp1,lmass) - ! should not exceed the rate of transfer of unactivated particles - ! from kp1 to k which = ekkp(k)*raercol(kp1,lmass) - ! however it might if things are not "just right" in subr activate - ! the following is a safety measure to avoid negatives in explmix - do k = top_lev, pver-1 - do m = 1, ntot_amode - nact(k,m) = min( nact(k,m), ekkp(k) ) - mact(k,m) = min( mact(k,m), ekkp(k) ) - end do - end do - -!Don't need the mixing per mode in OSLO_AERO ==> only per tracer -!Note that nsav/nnew is switched above, so operate on nnew here -!nnew is the updated aerosol -#ifdef OSLO_AERO - raercol_tracer(:,:,:) = 0.0_r8 - raercol_cw_tracer(:,:,:) = 0.0_r8 - mact_tracer(:,:) = 0.0_r8 - mfullact_tracer(:,:) = 0.0_r8 + ! Add dropmixnuc tendencies for all modal aerosol species + + call phys_getopts(history_amwg_out = history_amwg, & + history_aerosol_out = history_aerosol, & + prog_modal_aero_out=prog_modal_aero) + + prog_modal_aero = .TRUE. + n_aerosol_tracers = getNumberOfAerosolTracers() + call fillAerosolTracerList(aerosolTracerList) + call fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) + do ii=1,n_aerosol_tracers + print*, "aerosolTracerList", ii, aerosolTracerList(ii), inverseAerosolTracerList(aerosolTracerList(ii)) + end do + + lq(:)=.FALSE. !Initialize + + !Set up tendencies for tracers (output) do m=1,ntot_amode do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.FALSE.) !which tracer are we talking about - lptr2 = inverseAerosolTracerList(lptr) !which index is this in the list of aerosol-tracers - mm = mam_idx(m,l) - raercol_tracer(:,lptr2,nnew) = raercol_tracer(:,lptr2,nnew) & - + raercol(:,mm,nnew) - - raercol_cw_tracer(:,lptr2,nnew) = raercol_cw_tracer(:,lptr2,nnew)& - + raercol_cw(:,mm,nnew) - - mact_tracer(:,lptr2) = mact_tracer(:,lptr2) + mact(:,m)*raercol(:,mm,nnew) - mfullact_tracer(:,lptr2) = mfullact_tracer(:,lptr2) + raercol(:,mm,nnew) - -#ifdef EXTRATESTS - if(lptr.eq.lDebug .and. i.eq.iDebug)then - do k=pver,top_lev,-1 - print*, "assigning to tracer space",lptr, raercol(k,mm,nnew) & - , raercol_tracer(k,lptr2,nnew) & - , raercol_cw(k,mm,nnew) & - , raercol_cw_tracer(k,lptr2,nnew) + lptr = getTracerIndex(m,l,.false.) + + if(.NOT. lq(lptr))then + !add dropmixnuc tendencies + mm=mam_idx(m,l) + fieldname(mm)=trim(cnst_name(lptr))//"_mixnuc1" + fieldname_cw(mm)=trim(getCloudTracerName(lptr))//"_mixnuc1" + + long_name = trim(fieldname(mm)) // ' dropmixnuc column tendency' + call addfld(trim(fieldname(mm)), horiz_only ,'A', "kg/m2/s",long_name) + + long_name = trim(fieldname_cw(mm)) // ' dropmixnuc column tendency' + call addfld(trim(fieldname_cw(mm)), horiz_only, 'A', "kg/m2/s",long_name) + + if (history_aerosol) then + call add_default(trim(fieldname(mm)), 1, ' ') + call add_default(trim(fieldname_cw(mm)),1,' ') + endif + + !Do tendencies of this tracer + lq(lptr)=.TRUE. + endif + enddo + enddo + do m=1,ntot_amode + modeString=" " + write(modeString,"(I2)"),m + if(m .lt. 10) modeString="0"//adjustl(modeString) + varName = "NMR"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', 'm ', 'number median radius mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + + varName = "NCONC"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', '#/m3 ', 'number concentration mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + + varName = "VCONC"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', 'm3/m3 ','volume concentration mode '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + + varName = "SIGMA"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A', '-','Std. dev. mode '//modeString) + + if(history_aerosol)call add_default(varName, 1, ' ') + varName = "HYGRO"//trim(modeString) + call addfld(varName, (/ 'lev' /),'A','-','Hygroscopicity '//modeString) + if(history_aerosol)call add_default(varName, 1, ' ') + end do + call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%') + call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%') + call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%') + call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.15%') + call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%') + call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%') + call addfld('CCN7',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%') + + if(history_aerosol)then + do l = 1, psat + call add_default(ccn_name(l), 1, ' ') + enddo + end if + + call addfld('WTKE', (/ 'lev' /), 'A', 'm/s', 'Standard deviation of updraft velocity') + call addfld('NDROPMIX', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number mixing') + call addfld('NDROPSRC', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number source') + call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics') + call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number') + + end subroutine ndrop_init + + !=============================================================================== + + subroutine dropmixnuc( & + state, ptend, dtmicro, pbuf, wsub, & ! Input + cldn, cldo, cldliqf, & + hasAerosol, & + CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, & + cam, f_acm, f_bcm, f_aqm, f_so4_condm, & + f_soam, & + numberConcentration, volumeConcentration, & + hygroscopicity, lnsigma, & + tendnd, & ! Output + fn_in) + + ! vertical diffusion and nucleation of cloud droplets + ! assume cloud presence controlled by cloud fraction + ! doesn't distinguish between warm, cold clouds + + ! arguments + type(physics_state), target, intent(in) :: state + type(physics_ptend), intent(out) :: ptend + real(r8), intent(in) :: dtmicro ! time step for microphysics (s) + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: wsub(pcols,pver) ! subgrid vertical velocity + real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction + real(r8), intent(in) :: cldo(pcols,pver) ! cloud fraction on previous time step + real(r8), intent(in) :: cldliqf(pcols,pver) ! liquid cloud fraction (liquid / (liquid + ice)) + logical , intent(in) :: hasAerosol(pcols, pver, nmodes) + real(r8), intent(in) :: CProcessModes(pcols,pver) + real(r8), intent(in) :: cam(pcols,pver,nbmodes) + real(r8), intent(in) :: f_c(pcols,pver) + real(r8), intent(in) :: f_aq(pcols,pver) + real(r8), intent(in) :: f_bc(pcols,pver) + real(r8), intent(in) :: f_so4_cond(pcols,pver) + real(r8), intent(in) :: f_soa(pcols,pver) + real(r8), intent(in) :: f_acm(pcols,pver, nbmodes) + real(r8), intent(in) :: f_bcm(pcols,pver, nbmodes) + real(r8), intent(in) :: f_aqm(pcols, pver, nbmodes) + real(r8), intent(in) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction + real(r8), intent(in) :: f_soam(pcols,pver,nbmodes) + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration + real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) ![-] hygroscopicity + real(r8), intent(in) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma + real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) + + ! Local variables + integer :: lchnk ! chunk identifier + integer :: ncol ! number of columns + real(r8), pointer :: ncldwtr(:,:) ! droplet number concentration (#/kg) + real(r8), pointer :: temp(:,:) ! temperature (K) + real(r8), pointer :: omega(:,:) ! vertical velocity (Pa/s) + real(r8), pointer :: pmid(:,:) ! mid-level pressure (Pa) + real(r8), pointer :: pint(:,:) ! pressure at layer interfaces (Pa) + real(r8), pointer :: pdel(:,:) ! pressure thickess of layer (Pa) + real(r8), pointer :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) + real(r8), pointer :: zm(:,:) ! geopotential height of level (m) + + real(r8), pointer :: kvh(:,:) ! vertical diffusivity (m2/s) + + type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios + type(ptr2d_t), allocatable :: qqcw(:) + real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios + real(r8) :: qqcwtend(pver) ! tendency of cloudborne aerosol mass, number mixing ratios + + real(r8), parameter :: zkmin = 0.01_r8, zkmax = 100._r8 + real(r8), parameter :: wmixmin = 0.1_r8 ! minimum turbulence vertical velocity (m/s) + real(r8) :: sq2pi + + integer :: i, k, l, m, mm, n + integer :: km1, kp1 + integer :: nnew, nsav, ntemp + integer :: lptr + integer :: nsubmix, nsubmix_bnd + integer, save :: count_submix(100) + integer :: phase ! phase of aerosol + + real(r8) :: arg + real(r8) :: dtinv + real(r8) :: dtmin, tinv, dtt + real(r8) :: lcldn(pcols,pver) + real(r8) :: lcldo(pcols,pver) + + real(r8) :: zs(pver) ! inverse of distance between levels (m) + real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) + real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries + real(r8) :: srcn(pver) ! droplet source rate (/s) + real(r8) :: cs(pcols,pver) ! air density (kg/m3) + real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) + real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) + real(r8) :: dz(pcols,pver) ! geometric thickness of layers (m) + + real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) + real(r8) :: wtke_cen(pcols,pver) ! turbulent vertical velocity at center of layer k (m/s) + real(r8) :: wbar, wmix, wmin, wmax + + real(r8) :: zn(pver) ! g/pdel (m2/g) for layer + real(r8) :: flxconv ! convergence of flux into lowest layer + + real(r8) :: wdiab ! diabatic vertical velocity + real(r8) :: ekd(pver) ! diffusivity for droplets (m2/s) + real(r8) :: ekk(0:pver) ! density*diffusivity for droplets (kg/m3 m2/s) + real(r8) :: ekkp(pver) ! zn*zs*density*diffusivity + real(r8) :: ekkm(pver) ! zn*zs*density*diffusivity + + real(r8) :: dum, dumc + real(r8) :: tmpa + real(r8) :: dact + real(r8) :: fluxntot ! (#/cm2/s) + real(r8) :: dtmix + real(r8) :: alogarg + real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap + + real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) + real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) + real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) + real(r8) :: cldo_tmp, cldn_tmp + real(r8) :: tau_cld_regenerate + real(r8) :: zeroaer(pver) + real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) + + real(r8), allocatable :: nact(:,:) ! fractional aero. number activation rate (/s) + real(r8), allocatable :: mact(:,:) ! fractional aero. mass activation rate (/s) + + real(r8), allocatable :: raercol(:,:,:) ! single column of aerosol mass, number mixing ratios + real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase + + !to avoid excessive calls to boundary layer scheme + real(r8), allocatable :: raercol_tracer(:,:,:) + real(r8), allocatable :: raercol_cw_tracer(:,:,:) + real(r8), allocatable :: mact_tracer(:,:) + real(r8), allocatable :: mfullact_tracer(:,:) + + real(r8) :: na(pcols), va(pcols), hy(pcols) + real(r8), allocatable :: naermod(:) ! (1/m3) + real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode + real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) + + real(r8) :: source(pver) + + real(r8), allocatable :: fn(:) ! activation fraction for aerosol number + real(r8), intent(out) :: fn_in(pcols,pver,0:nmodes) + real(r8), allocatable :: fm(:) ! activation fraction for aerosol mass + + real(r8), allocatable :: fluxn(:) ! number activation fraction flux (cm/s) + real(r8), allocatable :: fluxm(:) ! mass activation fraction flux (cm/s) + real(r8) :: flux_fullact(pver) ! 100% activation fraction flux (cm/s) + ! note: activation fraction fluxes are defined as + ! fluxn = [flux of activated aero. number into cloud (#/cm2/s)] + ! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] + + real(r8), allocatable :: coltend(:,:) ! column tendency for diagnostic output + real(r8), allocatable :: coltend_cw(:,:) ! column tendency + real(r8) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat + + !for gas species turbulent mixing + real(r8), pointer :: rgas(:, :, :) + real(r8), allocatable :: rgascol(:, :, :) + real(r8), allocatable :: coltendgas(:) + real(r8) :: zerogas(pver) + character*200 :: fieldnamegas + + real(r8) :: numberMedianRadius(pcols,pver,nmodes) + real(r8) :: sigma(pcols,pver,nmodes) ![-] sigma + real(r8) :: constituentFraction + real(r8) :: volumeCore(pcols,pver,nmodes) + real(r8) :: volumeCoat(pcols,pver,nmodes) + integer :: tracerIndex + integer :: cloudTracerIndex + integer :: kcomp + integer :: speciesMap(nmodes) + real(r8), allocatable :: fn_tmp(:), fm_tmp(:) + real(r8), allocatable :: fluxn_tmp(:), fluxm_tmp(:) + real(r8) :: componentFraction + real(r8) :: componentFractionOK(pver,nmodes,pcnst) + real(r8) :: sumFraction + logical :: alert + real(r8), dimension(pver, pcnst) :: massBalance + real(r8), dimension(pver, pcnst) :: newMass + real(r8), dimension(pver,pcnst) :: newCloud, oldCloud, newAerosol, oldAerosol, deltaCloud + integer :: kCrit, lptr2 + logical :: stopMe + integer :: iDebug=1, lDebug=15 + real(r8) :: mixRatioToMass + real(r8),dimension(pcnst) :: debugSumFraction + real(r8), allocatable :: lnsigman(:) + character(len=2) :: modeString + character(len=20) :: varname + integer :: numberOfModes + !------------------------------------------------------------------------------- + + sq2pi = sqrt(2._r8*pi) + + lchnk = state%lchnk + ncol = state%ncol + + ncldwtr => state%q(:,:,numliq_idx) + temp => state%t + omega => state%omega + pmid => state%pmid + pint => state%pint + pdel => state%pdel + rpdel => state%rpdel + zm => state%zm + + call pbuf_get_field(pbuf, kvh_idx, kvh) + + ! Create the liquid weighted cloud fractions that were passsed in + ! before. This doesn't seem like the best variable, since the cloud could + ! have liquid condensate, but the part of it that is changing could be the + ! ice portion; however, this is what was done before. + lcldo(:ncol,:) = cldo(:ncol,:) * cldliqf(:ncol,:) + lcldn(:ncol,:) = cldn(:ncol,:) * cldliqf(:ncol,:) + + arg = 1.0_r8 + if (abs(0.8427_r8 - erf(arg))/0.8427_r8 > 0.001_r8) then + write(iulog,*) 'erf(1.0) = ',ERF(arg) + call endrun('dropmixnuc: Error function error') + endif + arg = 0.0_r8 + if (erf(arg) /= 0.0_r8) then + write(iulog,*) 'erf(0.0) = ',erf(arg) + write(iulog,*) 'dropmixnuc: Error function error' + call endrun('dropmixnuc: Error function error') + endif + + dtinv = 1._r8/dtmicro + + allocate( & + nact(pver,ntot_amode), & + mact(pver,ntot_amode), & + raer(ncnst_tot), & + qqcw(ncnst_tot), & + raercol(pver,ncnst_tot,2), & + raercol_cw(pver,ncnst_tot,2), & + coltend(pcols,ncnst_tot), & + coltend_cw(pcols,ncnst_tot), & + naermod(ntot_amode), & + hygro(ntot_amode), & + lnsigman(ntot_amode), & !variable std. deviation (CAM-Oslo) + raercol_tracer(pver,n_aerosol_tracers,2), & + raercol_cw_tracer(pver,n_aerosol_tracers,2), & + mact_tracer(pver,n_aerosol_tracers), & + mfullact_tracer(pver,n_aerosol_tracers), & + vaerosol(ntot_amode), & + fn(ntot_amode), & + fm(ntot_amode), & + fluxn(ntot_amode), & + fluxm(ntot_amode) ) + + ! Init pointers to mode number and specie mass mixing ratios in + ! intersitial and cloud borne phases. + ! Need a list of all aerosol species ==> store in raer (mm) + ! or qqcw for cloud-borne aerosols (?) + do m=1,nmodes !All aerosol modes + + !NOTE: SEVERAL POINTERS POINT TO SAME FIELD, E.G. CONDENSATE WHICH IS IN SEVERAL MODES + do l = 1, nspec_amode(m) + tracerIndex = getTracerIndex(m,l,.false.) !Index in q + cloudTracerIndex = getCloudTracerIndex(m,l) !Index in phys-buffer + mm = mam_idx(m,l) !Index in raer/qqcw + raer(mm)%fld => state%q(:,:,tracerIndex) !NOTE: These are total fields (for example condensate) + call pbuf_get_field(pbuf, CloudTracerIndex, qqcw(mm)%fld) !NOTE: These are total fields (for example condensate) + enddo + enddo + allocate( & + fn_tmp(ntot_amode), & + fm_tmp(ntot_amode), & + fluxn_tmp(ntot_amode), & + fluxm_tmp(ntot_amode) ) + + wtke = 0._r8 + + if (prog_modal_aero) then + ! aerosol tendencies + call physics_ptend_init(ptend, state%psetcols, 'ndrop', lq=lq) + else + ! no aerosol tendencies + call physics_ptend_init(ptend, state%psetcols, 'ndrop') + end if + + !Improve this later by using only cloud points ? + do k = top_lev, pver + do i=1,ncol + cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) + end do + end do + + !Output this + call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) + do n=1,nmodes + sigma(:ncol,:,n) = DEXP(lnSigma(:ncol,:,n)) + modeString=" " + write(modeString,"(I2)"),n + if(n .lt. 10) modeString="0"//adjustl(modeString) + varName = "NMR"//trim(modeString) + call outfld(varName, numberMedianRadius(:,:,n), pcols, lchnk) + varName = "NCONC"//trim(modeString) + call outfld(varName, numberConcentration(:,:,n),pcols, lchnk) + varName = "VCONC"//trim(modeString) + call outfld(varName, volumeConcentration(:,:,n), pcols,lchnk) + varName = "SIGMA"//trim(modeString) + call outfld(varName, sigma(:,:,n), pcols,lchnk) + varName = "HYGRO"//trim(modeString) + call outfld(varName, hygroscopicity(:,:,n), pcols,lchnk) + end do + + alert = .FALSE. + do k=top_lev,pver + mm = k - top_lev + 1 + do m=1,nmodes + if(.NOT. alert .and. & + ANY(numberConcentration(:ncol,k,m) .lt. 0.0_r8 ))then + alert = .TRUE. + lptr = k + print*,"STRANGE numberconc", m, minval(numberConcentration(:,:,:))*1.e-6_r8, "#/cm3", k, mm + endif + enddo + enddo + if (alert)then + print*,"strange stuff here " + call endrun() + endif + + ! overall_main_i_loop + do i = 1, ncol + + coltend(i,:)=0.0_r8 + coltend_cw(i,:) = 0.0_r8 + + do k = top_lev, pver-1 + zs(k) = 1._r8/(zm(i,k) - zm(i,k+1)) + end do + zs(pver) = zs(pver-1) + + ! load number nucleated into qcld on cloud boundaries + do k = top_lev, pver + + qcld(k) = ncldwtr(i,k) + qncld(k) = 0._r8 + srcn(k) = 0._r8 + cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) + dz(i,k) = 1._r8/(cs(i,k)*gravit*rpdel(i,k)) ! layer thickness in m + + do m = 1, ntot_amode + nact(k,m) = 0._r8 + mact(k,m) = 0._r8 + end do + + zn(k) = gravit*rpdel(i,k) + + if (k < pver) then + ekd(k) = kvh(i,k+1) + ekd(k) = max(ekd(k), zkmin) + ekd(k) = min(ekd(k), zkmax) + csbot(k) = 2.0_r8*pint(i,k+1)/(rair*(temp(i,k) + temp(i,k+1))) + csbot_cscen(k) = csbot(k)/cs(i,k) + else + ekd(k) = 0._r8 + csbot(k) = cs(i,k) + csbot_cscen(k) = 1.0_r8 + end if + + ! rce-comment - define wtke at layer centers for new-cloud activation + ! and at layer boundaries for old-cloud activation + wtke_cen(i,k) = wsub(i,k) + wtke(i,k) = wsub(i,k) + wtke_cen(i,k) = max(wtke_cen(i,k), wmixmin) + wtke(i,k) = max(wtke(i,k), wmixmin) + nsource(i,k) = 0._r8 + + end do ! k + + nsav = 1 + nnew = 2 + + !get constituent fraction + componentFractionOK(:,:,:) = 0.0_r8 + do k=top_lev, pver + do m = 1,ntot_amode + if(m .le. nbmodes)then + do l = 1, nspec_amode(m) + !calculate fraction of component "l" in mode "m" based on concentrations in clear air + componentFractionOK(k,m,getTracerIndex(m,l,.false.)) & + = getConstituentFraction(CProcessModes(i,k), & + f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k), & + Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), & + f_so4_condm(i,k,m), f_soam(i,k,m), getTracerIndex(m,l,.false.) ) + end do + else + do l = 1, nspec_amode(m) + componentFractionOK(k,m,getTracerIndex(m,l,.false.)) = 1.0_r8 + end do + endif + end do + + !Loop over all tracers ==> check that sums to one + !for all tracers which exist in the oslo-modes + do l=1,pcnst + sumFraction = 0.0_r8 + do m=1,ntot_amode + sumFraction = sumFraction + componentFractionOK(k,m,l) + end do + if(sumFraction .gt. 1.e-2_r8)then !Just scale what comes out if componentFraction is larger than 1% + do m=1,ntot_amode + componentFractionOK(k,m,l) = & + componentFractionOK(k,m,l)/sumFraction + end do + else !negative or zero fraction for this species + !distribute equal fraction to all receiver modes + sumFraction = 0.0_r8 + do m=1,ntot_amode + do lptr=1,getNumberOfTracersInMode(m) + if(getTracerIndex(m,lptr,.FALSE.) .eq. l ) then + sumFraction = sumFraction + 1.0_r8 + endif + end do ! tracers in mode + end do ! mode + do m=1,ntot_amode + componentFractionOK(k,m,l)=1.0_r8/max(1.e-30_r8, sumFraction) + end do !modes + endif + end do !tracers + end do !levels + !debug sum fraction for "i" done + + debugSumFraction(:) = 0.0_r8 !sum of component lDebug in level k + do m = 1, nmodes ! Number of modes + !Get number concentration of this mode + mm =mam_idx(m,0) + do k= top_lev,pver + raercol(k,mm,nsav) = numberConcentration(i,k,m)/cs(i,k) !#/kg air + !In oslo model, number concentrations are diagnostics, so + !Approximate number concentration in each mode by total + !cloud number concentration scaled by how much is available of + !each mode + raercol_cw(k,mm,nsav) = ncldwtr(i,k)*numberConcentration(i,k,m)& + /max(1.e-30_r8, sum(numberConcentration(i,k,1:nmodes))) + enddo + + !These are the mass mixing ratios + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) !index of tracer (all unique) + raercol(:,mm,nsav) = 0.0_r8 + raercol_cw(:,mm,nsav) = 0.0_r8 + !Several of the fields (raer(mm)%fld point to the same + !field in q. To avoid double counting, we take into + !account the component fraction in the mode + do k=top_lev,pver + if(m .gt. nbmodes) then + componentFraction = 1.0_r8 + else + componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) + endif + !Assign to the components used here i.e. distribute condensate/coagulate to modes + raercol_cw(k,mm,nsav) = qqcw(mm)%fld(i,k)*componentFraction + raercol(k,mm,nsav) = raer(mm)%fld(i,k)*componentFraction + enddo ! k (levels) + end do ! l (species) + end do ! m (modes) + + ! droplet nucleation/aerosol activation + + ! tau_cld_regenerate = time scale for regeneration of cloudy air + ! by (horizontal) exchange with clear air + tau_cld_regenerate = 3600.0_r8 * 3.0_r8 + + ! k-loop for growing/shrinking cloud calcs ............................. + ! grow_shrink_main_k_loop: & + do k = top_lev, pver + + ! This code was designed for liquid clouds, but the cloudbourne + ! aerosol can be either from liquid or ice clouds. For the ice clouds, + ! we do not do regeneration, but as cloud fraction decreases the + ! aerosols should be returned interstitial. The lack of a liquid cloud + ! should not mean that all of the aerosol is realease. Therefor a + ! section has been added for shrinking ice clouds and checks were added + ! to protect ice cloudbourne aerosols from being released when no + ! liquid cloud is present. + + ! shrinking ice cloud ...................................................... + cldo_tmp = cldo(i,k) * (1._r8 - cldliqf(i,k)) + cldn_tmp = cldn(i,k) * (1._r8 - cldliqf(i,k)) + + if (cldn_tmp < cldo_tmp) then + + ! convert activated aerosol to interstitial in decaying cloud + + dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * (1._r8 - cldliqf(i,k)) + do m = 1, ntot_amode + mm = mam_idx(m,0) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + end do + end do + end if + + ! shrinking liquid cloud ...................................................... + ! treat the reduction of cloud fraction from when cldn(i,k) < cldo(i,k) + ! and also dissipate the portion of the cloud that will be regenerated + cldo_tmp = lcldo(i,k) + cldn_tmp = lcldn(i,k) * exp( -dtmicro/tau_cld_regenerate ) + ! alternate formulation + ! cldn_tmp = cldn(i,k) * max( 0.0_r8, (1.0_r8-dtmicro/tau_cld_regenerate) ) + + ! fraction is also provided. + if (cldn_tmp < cldo_tmp) then + ! droplet loss in decaying cloud + nsource(i,k) = nsource(i,k) + qcld(k)*(cldn_tmp - cldo_tmp)/cldo_tmp*cldliqf(i,k)*dtinv + qcld(k) = qcld(k)*(1._r8 + (cldn_tmp - cldo_tmp)/cldo_tmp) + + ! convert activated aerosol to interstitial in decaying cloud + dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * cldliqf(i,k) + do m = 1, ntot_amode + mm = mam_idx(m,0) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + dact = raercol_cw(k,mm,nsav)*dumc + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + end do end do end if -#endif - end do !l - end do !m - do lptr2=1,n_aerosol_tracers - mact_tracer(:,lptr2) = mact_tracer(:,lptr2) & + ! growing liquid cloud ...................................................... + ! treat the increase of cloud fraction from when cldn(i,k) > cldo(i,k) + ! and also regenerate part of the cloud + cldo_tmp = cldn_tmp + cldn_tmp = lcldn(i,k) + + if (cldn_tmp-cldo_tmp > 0.01_r8) then + + ! rce-comment - use wtke at layer centers for new-cloud activation + wbar = wtke_cen(i,k) + wmix = 0._r8 + wmin = 0._r8 + wmax = 10._r8 + wdiab = 0._r8 + + ! load aerosol properties, assuming external mixtures + + naermod(:) = 0.0_r8 + vaerosol(:) = 0.0_r8 + hygro(:) = 0.0_r8 + lnsigman(:) = log(2.0_r8) + + m=0 + do kcomp = 1,nmodes + if(hasAerosol(i,k,kcomp) .eqv. .TRUE.)then + m = m + 1 + naermod(m) = numberConcentration(i,k,kcomp) + vaerosol(m) = volumeConcentration(i,k,kcomp) + hygro(m) = hygroscopicity(i,k,kcomp) + lnsigman(m) = lnsigma(i,k,kcomp) + speciesMap(m) = kcomp + end if + end do + numberOfModes = m + !Call the activation procedure + if(numberOfModes .gt. 0)then + if (use_hetfrz_classnuc) then + call activate_modal( & + wbar, wmix, wdiab, wmin, wmax, & + temp(i,k), cs(i,k), naermod, numberOfModes, & + vaerosol, hygro, fn_in(i,k,1:nmodes), fm, fluxn, & + fluxm, flux_fullact(k), lnsigman) + else + call activate_modal( & + wbar, wmix, wdiab, wmin, wmax, & + temp(i,k), cs(i,k), naermod, numberOfModes, & + vaerosol, hygro, fn, fm, fluxn, & + fluxm, flux_fullact(k), lnsigman) + end if + endif + + dumc = (cldn_tmp - cldo_tmp) + + if (use_hetfrz_classnuc) then + fn_tmp(:) = fn_in(i,k,1:nmodes) + else + fn_tmp(:) = fn(:) + end if + fm_tmp(:) = fm(:) + fluxn_tmp(:) = fluxn(:) + fluxm_tmp(:) = fluxm(:) + fn(:) = 0.0_r8 + fn_in(i,k,:) = 0.0_r8 + fm(:) = 0.0_r8 + fluxn(:)=0.0_r8 + fluxm(:)= 0.0_r8 + do m = 1, numberOfModes !Number of coexisting modes to be used for activation + kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) + if (use_hetfrz_classnuc) then + fn_in(i,k,kcomp) = fn_tmp(m) + else + fn(kcomp) = fn_tmp(m) + end if + fm(kcomp) = fm_tmp(m) + fluxn(kcomp) = fluxn_tmp(m) + fluxm(kcomp) = fluxm_tmp(m) + enddo + do m = 1, ntot_amode + mm = mam_idx(m,0) + if (use_hetfrz_classnuc) then + dact = dumc*fn_in(i,k,m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} + else + dact = dumc*fn(m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} + end if + qcld(k) = qcld(k) + dact + nsource(i,k) = nsource(i,k) + dact*dtinv + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + dum = dumc*fm(m) + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + if(m .gt. nbmodes)then + constituentFraction = 1.0_r8 + else + constituentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.) ) + endif + + dact = dum*raer(mm)%fld(i,k)*constituentFraction + raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol + raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact + enddo + enddo + endif ! cldn_tmp-cldo_tmp > 0.01_r8 + + enddo ! grow_shrink_main_k_loop + ! end of k-loop for growing/shrinking cloud calcs ...................... + + ! ...................................................................... + ! start of k-loop for calc of old cloud activation tendencies .......... + ! + ! rce-comment + ! changed this part of code to use current cloud fraction (cldn) exclusively + ! consider case of cldo(:)=0, cldn(k)=1, cldn(k+1)=0 + ! previous code (which used cldo below here) would have no cloud-base activation + ! into layer k. however, activated particles in k mix out to k+1, + ! so they are incorrectly depleted with no replacement + + ! old_cloud_main_k_loop + do k = top_lev, pver + kp1 = min0(k+1, pver) + taumix_internal_pver_inv = 0.0_r8 + + if (lcldn(i,k) > 0.01_r8) then + + wdiab = 0._r8 + wmix = 0._r8 ! single updraft + wbar = wtke(i,k) ! single updraft + if (k == pver) wbar = wtke_cen(i,k) ! single updraft + wmax = 10._r8 + wmin = 0._r8 + + if (lcldn(i,k) - lcldn(i,kp1) > 0.01_r8 .or. k == pver) then + + ! cloud base + + ! ekd(k) = wtke(i,k)*dz(i,k)/sq2pi + ! rce-comments + ! first, should probably have 1/zs(k) here rather than dz(i,k) because + ! the turbulent flux is proportional to ekd(k)*zs(k), + ! while the dz(i,k) is used to get flux divergences + ! and mixing ratio tendency/change + ! second and more importantly, using a single updraft velocity here + ! means having monodisperse turbulent updraft and downdrafts. + ! The sq2pi factor assumes a normal draft spectrum. + ! The fluxn/fluxm from activate must be consistent with the + ! fluxes calculated in explmix. + ekd(k) = wbar/zs(k) + + alogarg = max(1.e-20_r8, 1._r8/lcldn(i,k) - 1._r8) + wmin = wbar + wmix*0.25_r8*sq2pi*log(alogarg) + phase = 1 ! interstitial + naermod(:) = 0.0_r8 + vaerosol(:) = 0.0_r8 + hygro(:) = 0.0_r8 + lnsigman(:) = log(2.0_r8) + + m=0 + do kcomp = 1,nmodes + if(hasAerosol(i,kp1,kcomp) .eqv. .TRUE.)then + m = m + 1 + naermod(m) = numberConcentration(i,kp1,kcomp) + vaerosol(m) = volumeConcentration(i,kp1,kcomp) + hygro(m) = hygroscopicity(i,kp1,kcomp) + lnsigman(m) = lnsigma(i,kp1,kcomp) + speciesMap(m) = kcomp + end if + end do + numberOfModes = m + if(numberOfModes .gt. 0)then + if (use_hetfrz_classnuc) then + call activate_modal( & + wbar, wmix, wdiab, wmin, wmax, & + temp(i,k), cs(i,k), naermod, numberOfModes , & + vaerosol, hygro, fn_in(i,k,:), fm, fluxn, & + fluxm, flux_fullact(k) & + ,lnsigman & + ) + else + call activate_modal( & + wbar, wmix, wdiab, wmin, wmax, & + temp(i,k), cs(i,k), naermod, numberOfModes , & + vaerosol, hygro, fn, fm, fluxn, & + fluxm, flux_fullact(k) & + ,lnsigman & + ) + end if + endif + + !Difference in cloud fraction this layer and above! + !we are here because there are more clouds above, and some + !aerosols go into that layer! ==> calculate additional cloud fraction + if (k < pver) then + dumc = lcldn(i,k) - lcldn(i,kp1) + else + dumc = lcldn(i,k) + endif + + if (use_hetfrz_classnuc) then + fn_tmp(:) = fn_in(i,k,1:nmodes) + else + fn_tmp(:) = fn(:) + end if + fm_tmp(:) = fm(:) + fluxn_tmp(:) = fluxn(:) + fluxm_tmp(:) = fluxm(:) + fn(:) = 0.0_r8 + fn_in(i,k,:) = 0.0_r8 + fm(:) = 0.0_r8 + fluxn(:)=0.0_r8 + fluxm(:)= 0.0_r8 + do m = 1, numberOfModes !Number of coexisting modes to be used for activation + kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) + if (use_hetfrz_classnuc) then + fn_in(i,k,kcomp) = fn_tmp(m) + else + fn(kcomp) = fn_tmp(m) + end if + fm(kcomp) = fm_tmp(m) + fluxn(kcomp) = fluxn_tmp(m) + fluxm(kcomp) = fluxm_tmp(m) + enddo + + fluxntot = 0.0_r8 + + ! rce-comment 1 + ! flux of activated mass into layer k (in kg/m2/s) + ! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) + ! source of activated mass (in kg/kg/s) = flux divergence + ! = actmassflux/(cs(i,k)*dz(i,k)) + ! so need factor of csbot_cscen = csbot(k)/cs(i,k) + ! dum=1./(dz(i,k)) + dum=csbot_cscen(k)/(dz(i,k)) + + ! rce-comment 2 + ! code for k=pver was changed to use the following conceptual model + ! in k=pver, there can be no cloud-base activation unless one considers + ! a scenario such as the layer being partially cloudy, + ! with clear air at bottom and cloudy air at top + ! assume this scenario, and that the clear/cloudy portions mix with + ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) + ! in the absence of other sources/sinks, qact (the activated particle + ! mixratio) attains a steady state value given by + ! qact_ss = fcloud*fact*qtot + ! where fcloud is cloud fraction, fact is activation fraction, + ! qtot=qact+qint, qint is interstitial particle mixratio + ! the activation rate (from mixing within the layer) can now be + ! written as + ! d(qact)/dt = (qact_ss - qact)/taumix_internal + ! = qtot*(fcloud*fact*wtke/dz) - qact*(wtke/dz) + ! note that (fcloud*fact*wtke/dz) is equal to the nact/mact + ! also, d(qact)/dt can be negative. in the code below + ! it is forced to be >= 0 + ! + ! steve -- + ! you will likely want to change this. i did not really understand + ! what was previously being done in k=pver + ! in the cam3_5_3 code, wtke(i,pver) appears to be equal to the + ! droplet deposition velocity which is quite small + ! in the cam3_5_37 version, wtke is done differently and is much + ! larger in k=pver, so the activation is stronger there + ! + if (k == pver) then + taumix_internal_pver_inv = flux_fullact(k)/dz(i,k) + end if + + do m = 1, ntot_amode + mm = mam_idx(m,0) + fluxn(m) = fluxn(m)*dumc + fluxm(m) = fluxm(m)*dumc + nact(k,m) = nact(k,m) + fluxn(m)*dum + mact(k,m) = mact(k,m) + fluxm(m)*dum + if (k < pver) then + ! note that kp1 is used here + fluxntot = fluxntot & + + fluxn(m)*raercol(kp1,mm,nsav)*cs(i,k) + else + tmpa = raercol(kp1,mm,nsav)*fluxn(m) & + + raercol_cw(kp1,mm,nsav)*(fluxn(m) & + - taumix_internal_pver_inv*dz(i,k)) + fluxntot = fluxntot + max(0.0_r8, tmpa)*cs(i,k) + end if + end do + srcn(k) = srcn(k) + fluxntot/(cs(i,k)*dz(i,k)) + nsource(i,k) = nsource(i,k) + fluxntot/(cs(i,k)*dz(i,k)) + endif ! (cldn(i,k) - cldn(i,kp1) > 0.01 .or. k == pver) + + else ! i.e: cldn(i,k) < 0.01_r8 + + ! no liquid cloud + + nsource(i,k) = nsource(i,k) - qcld(k)*dtinv + qcld(k) = 0.0_r8 + + if (cldn(i,k) < 0.01_r8) then + ! no ice cloud either + + ! convert activated aerosol to interstitial in decaying cloud + + do m = 1, ntot_amode + mm = mam_idx(m,0) + raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol + raercol_cw(k,mm,nsav) = 0._r8 + + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol + raercol_cw(k,mm,nsav) = 0._r8 + end do + end do + end if + end if + + end do ! old_cloud_main_k_loop + + ! switch nsav, nnew so that nnew is the updated aerosol + ntemp = nsav + nsav = nnew + nnew = ntemp + + ! load new droplets in layers above, below clouds + + dtmin = dtmicro + ekk(top_lev-1) = 0.0_r8 + ekk(pver) = 0.0_r8 + do k = top_lev, pver-1 + ! rce-comment -- ekd(k) is eddy-diffusivity at k/k+1 interface + ! want ekk(k) = ekd(k) * (density at k/k+1 interface) + ! so use pint(i,k+1) as pint is 1:pverp + ! ekk(k)=ekd(k)*2.*pint(i,k)/(rair*(temp(i,k)+temp(i,k+1))) + ! ekk(k)=ekd(k)*2.*pint(i,k+1)/(rair*(temp(i,k)+temp(i,k+1))) + ekk(k) = ekd(k)*csbot(k) + end do + + do k = top_lev, pver + km1 = max0(k-1, top_lev) + ekkp(k) = zn(k)*ekk(k)*zs(k) + ekkm(k) = zn(k)*ekk(k-1)*zs(km1) + tinv = ekkp(k) + ekkm(k) + + ! rce-comment -- tinv is the sum of all first-order-loss-rates + ! for the layer. for most layers, the activation loss rate + ! (for interstitial particles) is accounted for by the loss by + ! turb-transfer to the layer above. + ! k=pver is special, and the loss rate for activation within + ! the layer must be added to tinv. if not, the time step + ! can be too big, and explmix can produce negative values. + ! the negative values are reset to zero, resulting in an + ! artificial source. + if (k == pver) tinv = tinv + taumix_internal_pver_inv + + if (tinv .gt. 1.e-6_r8) then + dtt = 1._r8/tinv + dtmin = min(dtmin, dtt) + end if + end do + + dtmix = 0.9_r8*dtmin + nsubmix = dtmicro/dtmix + 1 + if (nsubmix > 100) then + nsubmix_bnd = 100 + else + nsubmix_bnd = nsubmix + end if + count_submix(nsubmix_bnd) = count_submix(nsubmix_bnd) + 1 + dtmix = dtmicro/nsubmix + + do k = top_lev, pver + kp1 = min(k+1, pver) + km1 = max(k-1, top_lev) + ! maximum overlap assumption + if (cldn(i,kp1) > 1.e-10_r8) then + overlapp(k) = min(cldn(i,k)/cldn(i,kp1), 1._r8) + else + overlapp(k) = 1._r8 + end if + if (cldn(i,km1) > 1.e-10_r8) then + overlapm(k) = min(cldn(i,k)/cldn(i,km1), 1._r8) + else + overlapm(k) = 1._r8 + end if + end do + + + ! rce-comment + ! the activation source(k) = mact(k,m)*raercol(kp1,lmass) + ! should not exceed the rate of transfer of unactivated particles + ! from kp1 to k which = ekkp(k)*raercol(kp1,lmass) + ! however it might if things are not "just right" in subr activate + ! the following is a safety measure to avoid negatives in explmix + do k = top_lev, pver-1 + do m = 1, ntot_amode + nact(k,m) = min( nact(k,m), ekkp(k) ) + mact(k,m) = min( mact(k,m), ekkp(k) ) + end do + end do + + !Don't need the mixing per mode in OSLO_AERO ==> only per tracer + !Note that nsav/nnew is switched above, so operate on nnew here + !nnew is the updated aerosol + raercol_tracer(:,:,:) = 0.0_r8 + raercol_cw_tracer(:,:,:) = 0.0_r8 + mact_tracer(:,:) = 0.0_r8 + mfullact_tracer(:,:) = 0.0_r8 + do m=1,ntot_amode + do l=1,nspec_amode(m) + lptr = getTracerIndex(m,l,.FALSE.) !which tracer are we talking about + lptr2 = inverseAerosolTracerList(lptr) !which index is this in the list of aerosol-tracers + mm = mam_idx(m,l) + raercol_tracer(:,lptr2,nnew) = raercol_tracer(:,lptr2,nnew) & + + raercol(:,mm,nnew) + + raercol_cw_tracer(:,lptr2,nnew) = raercol_cw_tracer(:,lptr2,nnew)& + + raercol_cw(:,mm,nnew) + + mact_tracer(:,lptr2) = mact_tracer(:,lptr2) + mact(:,m)*raercol(:,mm,nnew) + mfullact_tracer(:,lptr2) = mfullact_tracer(:,lptr2) + raercol(:,mm,nnew) + + end do !l + end do !m + + do lptr2=1,n_aerosol_tracers + mact_tracer(:,lptr2) = mact_tracer(:,lptr2) & /(mfullact_tracer(:,lptr2) + smallNumber) - end do -#endif OSLO_AERO - - ! old_cloud_nsubmix_loop - do n = 1, nsubmix - qncld(:) = qcld(:) - ! switch nsav, nnew so that nsav is the updated aerosol - ntemp = nsav - nsav = nnew - nnew = ntemp - srcn(:) = 0.0_r8 - - !First mix cloud droplet number concentration - do m = 1, ntot_amode - mm = mam_idx(m,0) - - ! update droplet source - ! rce-comment- activation source in layer k involves particles from k+1 - ! srcn(:)=srcn(:)+nact(:,m)*(raercol(:,mm,nsav)) - srcn(top_lev:pver-1) = srcn(top_lev:pver-1) + nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - - ! rce-comment- new formulation for k=pver - ! srcn( pver )=srcn( pver )+nact( pver ,m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - srcn(pver) = srcn(pver) + max(0.0_r8,tmpa) - end do - - !mixing of cloud droplets - call explmix( & - qcld, srcn, ekkp, ekkm, overlapp, & - overlapm, qncld, zero, zero, pver, & - dtmix, .false.) - -#ifdef OSLO_AERO - !Mix number concentrations consistently!! - do m = 1, ntot_amode - mm = mam_idx(m,0) - ! rce-comment - activation source in layer k involves particles from k+1 - ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) - source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - ! rce-comment - new formulation for k=pver - ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - source(pver) = max(0.0_r8, tmpa) - flxconv = 0._r8 - - call explmix( & - raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & - dtmix, .false.) + end do - call explmix( & - raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw(:,mm,nsav)) - end do -#endif - -#ifndef OSLO_AERO - ! rce-comment - ! the interstitial particle mixratio is different in clear/cloudy portions - ! of a layer, and generally higher in the clear portion. (we have/had - ! a method for diagnosing the the clear/cloudy mixratios.) the activation - ! source terms involve clear air (from below) moving into cloudy air (above). - ! in theory, the clear-portion mixratio should be used when calculating - ! source terms - do m = 1, ntot_amode - mm = mam_idx(m,0) - ! rce-comment - activation source in layer k involves particles from k+1 - ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) - source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - ! rce-comment - new formulation for k=pver - ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - source(pver) = max(0.0_r8, tmpa) - flxconv = 0._r8 - - call explmix( & - raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & + ! old_cloud_nsubmix_loop + do n = 1, nsubmix + qncld(:) = qcld(:) + ! switch nsav, nnew so that nsav is the updated aerosol + ntemp = nsav + nsav = nnew + nnew = ntemp + srcn(:) = 0.0_r8 + + !First mix cloud droplet number concentration + do m = 1, ntot_amode + mm = mam_idx(m,0) + + ! update droplet source + ! rce-comment- activation source in layer k involves particles from k+1 + ! srcn(:)=srcn(:)+nact(:,m)*(raercol(:,mm,nsav)) + srcn(top_lev:pver-1) = srcn(top_lev:pver-1) + nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + + ! rce-comment- new formulation for k=pver + ! srcn( pver )=srcn( pver )+nact( pver ,m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*nact(pver,m) & + + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) + srcn(pver) = srcn(pver) + max(0.0_r8,tmpa) + end do + + !mixing of cloud droplets + call explmix( & + qcld, srcn, ekkp, ekkm, overlapp, & + overlapm, qncld, zero, zero, pver, & dtmix, .false.) - call explmix( & - raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw(:,mm,nsav)) - - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - ! rce-comment - activation source in layer k involves particles from k+1 - ! source(:)= mact(:,m)*(raercol(:,mm,nsav)) - source(top_lev:pver-1) = mact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - ! rce-comment- new formulation for k=pver - ! source( pver )= mact( pver ,m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*mact(pver,m) & - + raercol_cw(pver,mm,nsav)*(mact(pver,m) - taumix_internal_pver_inv) - source(pver) = max(0.0_r8, tmpa) - flxconv = 0._r8 - - call explmix( & + !Mix number concentrations consistently!! + do m = 1, ntot_amode + mm = mam_idx(m,0) + ! rce-comment - activation source in layer k involves particles from k+1 + ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) + source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) + ! rce-comment - new formulation for k=pver + ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) + tmpa = raercol(pver,mm,nsav)*nact(pver,m) & + + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) + source(pver) = max(0.0_r8, tmpa) + flxconv = 0._r8 + + call explmix( & raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & dtmix, .false.) - call explmix( & + call explmix( & raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & dtmix, .true., raercol_cw(:,mm,nsav)) + end do - end do - end do -#endif - if (called_from_spcam) then - ! - ! turbulent mixing for gas species . - ! - do m=1, pcnst - if (cnst_species_class(m) == cnst_spec_class_gas) then - flxconv = 0.0_r8 - zerogas(:) = 0.0_r8 - call explmix(rgascol(1,m,nnew),zerogas,ekkp,ekkm,overlapp,overlapm, & - rgascol(1,m,nsav),zero, flxconv, pver,dtmix,& - .true., zerogas) - end if - end do - endif - -#ifdef OSLO_AERO - do lptr2=1,n_aerosol_tracers - source(top_lev:pver-1) = mact_tracer(top_lev:pver-1,lptr2) & - *(raercol_tracer(top_lev+1:pver,lptr2,nsav)) - - tmpa = raercol_tracer(pver,lptr2,nsav)*mact_tracer(pver,lptr2) & - + raercol_cw_tracer(pver,lptr2,nsav)*(mact_tracer(pver,lptr2) - taumix_internal_pver_inv) - - source(pver) = max(0.0_r8, tmpa) - flxconv = 0.0_r8 - - call explmix( & - raercol_cw_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw_tracer(:,lptr2,nsav), zero, zero, pver, & - dtmix, .false.) + do lptr2=1,n_aerosol_tracers + source(top_lev:pver-1) = mact_tracer(top_lev:pver-1,lptr2) & + *(raercol_tracer(top_lev+1:pver,lptr2,nsav)) - call explmix( & - raercol_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_tracer(:,lptr2,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw_tracer(:,lptr2,nsav)) - -#ifdef EXTRATESTS - lptr = aerosolTracerList(lptr2) - if(i.eq.iDebug .and. lptr.eq.lDebug)then - print*, "bugeds for ",trim(cnst_name(lptr)), n, nsubmix - do k=pver,1,-1 - print*, "source (aerosol/cloud) ",k, raercol_cw_tracer(k,lptr2,nnew),raercol_cw_tracer(k,lptr2,nsav) & - , raercol_tracer(k,lptr2,nnew),raercol_tracer(k,lptr2,nsav),source(k) - end do - if(m .le. nbmodes)then - print*, " ", mm, lptr, componentFractionOK(k,m,getTracerIndex(m,l,.false.)) - endif - endif -#endif - end do !Number of aerosol tracers - end do ! old_cloud_nsubmix_loop - - !Set back to the original framework - !Could probably continue in tracer-space from here - !but return back to mixture for easier use of std. NCAR code - tendencyCounted(:)=.FALSE. - do m = 1, ntot_amode - do l=1,nspec_amode(m) - mm=mam_idx(m,l) - lptr = getTracerIndex(m,l,.FALSE.) - lptr2 = inverseAerosolTracerList(lptr) - !All the tracer-space contains sum of all - !modes ==> put in first available component - !and zero in others. - if(.not.tendencyCounted(lptr))then - raercol(:,mm,nnew) = raercol_tracer(:,lptr2,nnew) - raercol_cw(:,mm,nnew) = raercol_cw_tracer(:,lptr2,nnew) - tendencyCounted(lptr) = .TRUE. - else - raercol(:,mm,nnew) = 0.0_r8 - raercol_cw(:,mm,nnew) = 0.0_r8 - end if - end do - end do -#endif - ! evaporate particles again if no cloud - - do k = top_lev, pver - if (cldn(i,k) == 0._r8) then - ! no ice or liquid cloud - qcld(k)=0._r8 - - ! convert activated aerosol to interstitial in decaying cloud - do m = 1, ntot_amode - mm = mam_idx(m,0) - raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) - raercol_cw(k,mm,nnew) = 0._r8 - - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) - raercol_cw(k,mm,nnew) = 0._r8 - end do - end do - end if - end do - - ! droplet number - - ndropcol(i) = 0._r8 - - !Initialize tendnd to zero in all layers since values are set in only top_lev,pver - !Without this the layers above top_lev would be un-initialized - tendnd(i,:) = 0.0_r8 - - do k = top_lev, pver - ndropmix(i,k) = (qcld(k) - ncldwtr(i,k))*dtinv - nsource(i,k) - tendnd(i,k) = (max(qcld(k), 1.e-6_r8) - ncldwtr(i,k))*dtinv - !print*, "tendnd",i,k, "new /old/tend", qcld(k), ncldwtr(i,k), tendnd(i,k) - ndropcol(i) = ndropcol(i) + ncldwtr(i,k)*pdel(i,k) - end do - ndropcol(i) = ndropcol(i)/gravit - -#ifdef EXTRATESTS - print*, "tendnd (#/kg/sec)", minval(tendnd(i,:)), maxval(tendnd(i,:)) -#endif - - if (prog_modal_aero) then - -#ifdef OSLO_AERO - -#ifdef MASS_BALANCE_CHECK - !test for correct transfer between in-cloud / no-cloud.. - newCloud(:,:) = 0.0_r8 - oldCloud(:,:) = 0.0_r8 - newAerosol(:,:) = 0.0_r8 - oldAerosol(:,:) = 0.0_r8 - deltaCloud(:,:) = 0.0_r8 - !Check mass balances #2 (all new cloud droplet species are taken from aerosols or from layer below - do k=pver,1,-1 - mixRatioToMass = cs(i,k)*dz(i,k) - !First sum up cloud tracer in this layer - tendencyCounted(:)=.FALSE. - do m=1,ntot_amode - do l=1,nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) !lptr occurs several times - newCloud(k, lptr) = newCloud(k, lptr) + raercol_cw(k, mm, nnew)*mixRatioToMass - newAerosol(k, lptr) = newAerosol(k, lptr) + raercol(k,mm,nnew)*mixRatioToMass - if(.NOT. tendencyCounted(lptr))then - oldAerosol(k, lptr) = raer(mm)%fld(i,k)*mixRatioToMass - oldCloud(k, lptr) = qqcw(mm)%fld(i,k)*mixRatioToMass - tendencyCounted(lptr)=.TRUE. - endif - enddo - enddo - enddo! k - - k = pver - !Check imbalance in bottom layer - - !Any change in cloud species is either from aerosol concentration or from change in layer below - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.false.) - - !This is the mass which must go to layer above! - deltaCloud(k,lptr) = (oldAerosol(k,lptr) - newAerosol(k,lptr)) &!used to create cloud species - -(newCloud(k,lptr) - oldCloud(k,lptr)) !created cloud species - enddo - enddo - - !if "deltaCloud" is positive in layer below it means that some aerosol species were sent up - - !Move upwards - do k=pver-1,1,-1 - kp1 = k + 1 - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.false.) - deltaCloud(k,lptr) = (oldAerosol(k,lptr)-newAerosol(k,lptr)) & !used to create cloud species - - (newCloud(k,lptr) - oldCloud(k,lptr)) & !created cloud species - - 0.0_r8 ! deltaCloud(kp1,lptr) !species received from below - enddo - enddo - enddo !layers - - stopMe = .FALSE. - tendencyCounted(:) = .FALSE. - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr= getTracerIndex(m,l,.false.) - if(abs(sum(deltaCloud(:,lptr))) > 1.e-8_r8 .and. (.NOT. tendencyCounted(lptr)))then - stopMe = .TRUE. - lptr2 = lptr - print*, "wrong mass budget",i,lptr,cnst_name(lptr), sum(deltaCloud(:,lptr)) - endif - tendencyCounted(lptr) = .TRUE. - enddo - enddo - if(stopMe)then - print*,"error in species : ", cnst_name(lptr2) - do k=pver,1,-1 - print*, "budgets new/old ",k, newCloud(k,lptr2),oldCloud(k,lptr2),newaerosol(k,lptr2),oldAerosol(k,lptr2), deltaCloud(k,lptr2) - enddo - call endrun ("wrong mass budget in column") - endif -#endif -#endif - raertend = 0._r8 - qqcwtend = 0._r8 - - -#ifndef OSLO_AERO - do m = 1, ntot_amode - do l = 0, nspec_amode(m) - - mm = mam_idx(m,l) - lptr = mam_cnst_idx(m,l) - - raertend(top_lev:pver) = (raercol(top_lev:pver,mm,nnew) - raer(mm)%fld(i,top_lev:pver))*dtinv - qqcwtend(top_lev:pver) = (raercol_cw(top_lev:pver,mm,nnew) - qqcw(mm)%fld(i,top_lev:pver))*dtinv - - coltend(i,mm) = sum( pdel(i,:)*raertend )/gravit - coltend_cw(i,mm) = sum( pdel(i,:)*qqcwtend )/gravit - - ptend%q(i,:,lptr) = 0.0_r8 - ptend%q(i,top_lev:pver,lptr) = raertend(top_lev:pver) ! set tendencies for interstitial aerosol - qqcw(mm)%fld(i,:) = 0.0_r8 - qqcw(mm)%fld(i,top_lev:pver) = raercol_cw(top_lev:pver,mm,nnew) ! update cloud-borne aerosol - end do - end do -#else - !OSLO AEROSOLS ... - - coltend_cw(i,:)=0.0_r8 - coltend(i,:) = 0.0_r8 - - !Need to initialize first because process modes arrive several times - tendencyCounted(:) = .FALSE. - do m=1,ntot_amode - do l = 1,getNumberOfTracersInMode(m) - lptr = getTracerIndex(m,l,.false.) - mm = mam_idx(m,l) - - !column tendencies for output - if(.NOT. tendencyCounted(lptr))then - coltend_cw(i,lptr) = coltend_cw(i,lptr) & - + sum( pdel(i,top_lev:pver)*(raercol_cw(top_lev:pver,mm,nnew) & !New, splitted, - - qqcw(mm)%fld(i,top_lev:pver) ) )/gravit*dtinv !Old, total - tendencyCounted(lptr) = .TRUE. - else !Already subtracted total old value, just add new - coltend_cw(i,lptr) = coltend_cw(i,lptr) & - + sum(pdel(i,top_lev:pver)*raercol_cw(top_lev:pver,mm,nnew))/gravit*dtinv !total already subtracted - end if - - ptend%q(i,:,lptr) = 0.0_r8 !Initialize tendencies - qqcw(mm)%fld(i,:) = 0.0_r8 !Throw out old concentrations before summing new ones - end do ! Tracers - end do ! Modes - - !First, sum up all the tracer mass concentrations - do m = 1, ntot_amode - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) !tracer indices for aerosol mass mixing ratios in raer-arrays - lptr = getTracerIndex(m,l,.false.) !index in q-array (1-pcnst) - - !This is a bit tricky since in our scheme the tracers can arrive several times - !the same tracer can exist in several modes, e.g. condensate!! - !Here we sum this into "qqcw" and "ptend" so that they contain TOTAL of those tracers - - !raercol and raercol_cw do not have totals, they have process-tracers splitted onto modes - - !Tendency at this point is the sum (original value subtracted below) - ptend%q(i,top_lev:pver,lptr) = ptend%q(i,top_lev:pver,lptr) + raercol(top_lev:pver,mm,nnew) - !for cloud water concentrations, we don't get tendency , only new concentration - qqcw(mm)%fld(i,top_lev:pver) = qqcw(mm)%fld(i,top_lev:pver) + raercol_cw(top_lev:pver,mm,nnew) - - end do - end do - - !Need this check due to some tracers (e.g. condensate) several times - tendencyCounted(:) = .FALSE. - - ! Recalculating cloud-borne aerosol number mixing ratios - do m=1,ntot_amode + tmpa = raercol_tracer(pver,lptr2,nsav)*mact_tracer(pver,lptr2) & + + raercol_cw_tracer(pver,lptr2,nsav)*(mact_tracer(pver,lptr2) - taumix_internal_pver_inv) + + source(pver) = max(0.0_r8, tmpa) + flxconv = 0.0_r8 + + call explmix( & + raercol_cw_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw_tracer(:,lptr2,nsav), zero, zero, pver, & + dtmix, .false.) + + call explmix( & + raercol_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_tracer(:,lptr2,nsav), zero, flxconv, pver, & + dtmix, .true., raercol_cw_tracer(:,lptr2,nsav)) + + end do !Number of aerosol tracers + end do ! old_cloud_nsubmix_loop + + !Set back to the original framework + !Could probably continue in tracer-space from here + !but return back to mixture for easier use of std. NCAR code + tendencyCounted(:)=.FALSE. + do m = 1, ntot_amode + do l=1,nspec_amode(m) + mm=mam_idx(m,l) + lptr = getTracerIndex(m,l,.FALSE.) + lptr2 = inverseAerosolTracerList(lptr) + !All the tracer-space contains sum of all + !modes ==> put in first available component + !and zero in others. + if(.not.tendencyCounted(lptr))then + raercol(:,mm,nnew) = raercol_tracer(:,lptr2,nnew) + raercol_cw(:,mm,nnew) = raercol_cw_tracer(:,lptr2,nnew) + tendencyCounted(lptr) = .TRUE. + else + raercol(:,mm,nnew) = 0.0_r8 + raercol_cw(:,mm,nnew) = 0.0_r8 + end if + end do + end do - !Now that all new aerosol masses are summed up, we subtract the original concentrations to obtain the tendencies - do l= 1,nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) - if(.NOT. tendencyCounted(lptr)) then - ptend%q(i,top_lev:pver,lptr) = (ptend%q(i,top_lev:pver,lptr) - raer(mm)%fld(i,top_lev:pver))*dtinv - coltend(i,lptr) = sum(pdel(i,top_lev:pver)*ptend%q(i,top_lev:pver,lptr))/gravit !Save column tendency - tendencyCounted(lptr) = .TRUE. - endif - end do !species - end do !modes -#endif - -#ifdef MASS_BALANCE_CHECK - !Check mass balances (all removed should be in tendencies) - massBalance(:,:) = 0.0_r8 - newMass(:,:) = 0.0_r8 - do m=1,ntot_amode - do l=1,nspec_amode(m) - mm = mam_idx(m,l) !unique index, for example sulfate condendsate in "x mode" or sulf cond in "y mode" - lptr = getTracerIndex(m,l,.false.) - !add up all new values for this tracer - newMass(top_lev:pver,lptr) = newMass(top_lev:pver,lptr) + raercol(top_lev:pver, mm,nnew) - enddo - enddo - tendencyCounted(:)=.FALSE. - do m=1,ntot_amode - do l=1,nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) - if(.NOT. tendencyCounted(lptr))then - massBalance(top_lev:pver, lptr) = newMass(top_lev:pver,lptr) & - - raer(mm)%fld(i,top_lev:pver) & !previous value - - ptend%q(i,top_lev:pver,lptr)/dtinv !added during time step - tendencyCounted(lptr) = .TRUE. - endif - enddo - enddo - tendencyCounted(:) = .FALSE. - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.false.) - !Check for large deviation in mass balance for this tracer - if(.NOT. tendencyCounted(lptr) .and. & - (maxval(massBalance(:,lptr)) > 1.e-30_r8 .or. minval(massBalance(:,lptr)) < -1.0e-30_r8))then - tendencyCounted(lptr) = .TRUE. - print*, "massBalance error", i, lptr, maxVal(massBalance(:,lptr)), minVal(massBalance(:,lptr)) - if(maxVal(massBalance(:,lptr)) > 1.e-30_r8)then - kCrit = maxLoc(massBalance(:,lptr),1) - else - kCrit = minLoc(massBalance(:,lptr),1) - endif - print*, "massBalance error loc", massBalance(kCrit, lptr), newMass(kCrit,lptr), raer(mm)%fld(i,kCrit) - !If mass balance error is larger than 1.e-10 times new or original value ==> stop - if(abs(massBalance(kCrit,lptr)) .gt. 1.e-10_r8*raer(mm)%fld(i,kCrit) & - .and. abs(massBalance(kCrit,lptr)).gt.1.e-10_r8*newMass(kCrit,lptr) )then - stop - endif - endif - enddo - enddo -#endif - - - end if !prog_modal_aero - - if (called_from_spcam) then - ! - ! Gas tendency - ! - do m=1, pcnst - if (cnst_species_class(m) == cnst_spec_class_gas) then - ptend%lq(m) = .true. - ptend%q(i, :, m) = (rgascol(:,m,nnew)-rgas(i,:,m)) * dtinv - end if - end do - endif - - end do ! overall_main_i_loop - -#ifdef EXTRATESTS - !check reasonable values for ncldwtr! - do k=top_lev,pver - if(maxval(ncldwtr(:ncol,k)) .gt. 1.e20_r8)then - print*, "stopping (after dropmixnuc) wrong ncldwtr", maxloc(ncldwtr(:ncol,k)) - do i=1,ncol - print*, "ncldwtr",i,k,ncldwtr(i,k) - enddo - call endrun("wrong ncldwtr (end of dropmixnuc)") - end if - end do !loop on layers -#endif - - ! end of main loop over i/longitude .................................... - - call outfld('NDROPCOL', ndropcol, pcols, lchnk) - call outfld('NDROPSRC', nsource, pcols, lchnk) - call outfld('NDROPMIX', ndropmix, pcols, lchnk) - call outfld('WTKE ', wtke, pcols, lchnk) - -#ifndef OSLO_AERO - !fxm: Make this work with the oslo aerosols also! - call ccncalc(state, pbuf, cs, ccn) -#else - if (history_aerosol) then - call ccncalc_oslo(state & - , pbuf & - , cs & -!+tht - , hasAerosol & -!-tht - , numberConcentration & - , volumeConcentration & - , hygroscopicity & - , lnSigma & - , ccn ) - end if -#endif - if(history_aerosol) then - do l = 1, psat - call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) - enddo - end if -#ifndef OSLO_AERO - ! do column tendencies - if (prog_modal_aero) then - do m = 1, ntot_amode - do l = 0, nspec_amode(m) - mm = mam_idx(m,l) - call outfld(fieldname(mm), coltend(:,mm), pcols, lchnk) - call outfld(fieldname_cw(mm), coltend_cw(:,mm), pcols, lchnk) - end do - end do - end if -#endif - - if(called_from_spcam) then - ! - ! output column-integrated Gas tendency (this should be zero) - ! - do m=1, pcnst - if (cnst_species_class(m) == cnst_spec_class_gas) then - do i=1, ncol - coltendgas(i) = sum( pdel(i,:)*ptend%q(i,:,m) )/gravit - end do - fieldnamegas = trim(cnst_name(m)) // '_mixnuc1sp' - call outfld( trim(fieldnamegas), coltendgas, pcols, lchnk) - end if - end do - deallocate(rgascol, coltendgas) - end if - -#ifdef OSLO_AERO - tendencyCounted(:)=.FALSE. - do m = 1, ntot_amode - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) - if(.NOT. tendencyCounted(lptr))then - call outfld(fieldname(mm), coltend(:,lptr), pcols,lchnk) - call outfld(fieldname_cw(mm), coltend_cw(:,lptr), pcols,lchnk) - tendencyCounted(lptr)=.TRUE. - endif - end do - end do -#endif - - deallocate( & - nact, & - mact, & - raer, & - qqcw, & - raercol, & - raercol_cw, & - coltend, & - coltend_cw, & - naermod, & - hygro, & -#ifdef OSLO_AERO - lnsigman, & !Variable std. dev (CAM-Oslo) -#endif - vaerosol, & - fn, & - fm, & - fluxn, & - fluxm ) - -#ifdef OSLO_AERO - deallocate (fluxm_tmp) - deallocate (fluxn_tmp) - deallocate (fm_tmp) - deallocate (fn_tmp) + ! evaporate particles again if no cloud + + do k = top_lev, pver + if (cldn(i,k) == 0._r8) then + ! no ice or liquid cloud + qcld(k)=0._r8 + + ! convert activated aerosol to interstitial in decaying cloud + do m = 1, ntot_amode + mm = mam_idx(m,0) + raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) + raercol_cw(k,mm,nnew) = 0._r8 + + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) + raercol_cw(k,mm,nnew) = 0._r8 + end do + end do + end if + end do + + ! droplet number + ndropcol(i) = 0._r8 + + !Initialize tendnd to zero in all layers since values are set in only top_lev,pver + !Without this the layers above top_lev would be un-initialized + tendnd(i,:) = 0.0_r8 + + do k = top_lev, pver + ndropmix(i,k) = (qcld(k) - ncldwtr(i,k))*dtinv - nsource(i,k) + tendnd(i,k) = (max(qcld(k), 1.e-6_r8) - ncldwtr(i,k))*dtinv + ndropcol(i) = ndropcol(i) + ncldwtr(i,k)*pdel(i,k) + end do + ndropcol(i) = ndropcol(i)/gravit + + if (prog_modal_aero) then + + raertend = 0._r8 + qqcwtend = 0._r8 + + coltend_cw(i,:)=0.0_r8 + coltend(i,:) = 0.0_r8 + + !Need to initialize first because process modes arrive several times + tendencyCounted(:) = .FALSE. + do m=1,ntot_amode + do l = 1,getNumberOfTracersInMode(m) + lptr = getTracerIndex(m,l,.false.) + mm = mam_idx(m,l) + + !column tendencies for output + if(.NOT. tendencyCounted(lptr))then + coltend_cw(i,lptr) = coltend_cw(i,lptr) & + + sum( pdel(i,top_lev:pver)*(raercol_cw(top_lev:pver,mm,nnew) & !New, splitted, + - qqcw(mm)%fld(i,top_lev:pver) ) )/gravit*dtinv !Old, total + tendencyCounted(lptr) = .TRUE. + else !Already subtracted total old value, just add new + coltend_cw(i,lptr) = coltend_cw(i,lptr) & + + sum(pdel(i,top_lev:pver)*raercol_cw(top_lev:pver,mm,nnew))/gravit*dtinv !total already subtracted + end if + + ptend%q(i,:,lptr) = 0.0_r8 !Initialize tendencies + qqcw(mm)%fld(i,:) = 0.0_r8 !Throw out old concentrations before summing new ones + end do ! Tracers + end do ! Modes + + !First, sum up all the tracer mass concentrations + do m = 1, ntot_amode + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) !tracer indices for aerosol mass mixing ratios in raer-arrays + lptr = getTracerIndex(m,l,.false.) !index in q-array (1-pcnst) + + !This is a bit tricky since in our scheme the tracers can arrive several times + !the same tracer can exist in several modes, e.g. condensate!! + !Here we sum this into "qqcw" and "ptend" so that they contain TOTAL of those tracers + + !raercol and raercol_cw do not have totals, they have process-tracers splitted onto modes + + !Tendency at this point is the sum (original value subtracted below) + ptend%q(i,top_lev:pver,lptr) = ptend%q(i,top_lev:pver,lptr) + raercol(top_lev:pver,mm,nnew) + !for cloud water concentrations, we don't get tendency , only new concentration + qqcw(mm)%fld(i,top_lev:pver) = qqcw(mm)%fld(i,top_lev:pver) + raercol_cw(top_lev:pver,mm,nnew) + + end do + end do + + !Need this check due to some tracers (e.g. condensate) several times + tendencyCounted(:) = .FALSE. + + ! Recalculating cloud-borne aerosol number mixing ratios + do m=1,ntot_amode + + !Now that all new aerosol masses are summed up, we subtract the original concentrations to obtain the tendencies + do l= 1,nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) + if(.NOT. tendencyCounted(lptr)) then + ptend%q(i,top_lev:pver,lptr) = (ptend%q(i,top_lev:pver,lptr) - raer(mm)%fld(i,top_lev:pver))*dtinv + coltend(i,lptr) = sum(pdel(i,top_lev:pver)*ptend%q(i,top_lev:pver,lptr))/gravit !Save column tendency + tendencyCounted(lptr) = .TRUE. + endif + end do !species + end do !modes + + end if !prog_modal_aero + + end do ! overall_main_i_loop + + ! end of main loop over i/longitude .................................... + + call outfld('NDROPCOL', ndropcol, pcols, lchnk) + call outfld('NDROPSRC', nsource, pcols, lchnk) + call outfld('NDROPMIX', ndropmix, pcols, lchnk) + call outfld('WTKE ', wtke, pcols, lchnk) + + if (history_aerosol) then + call ccncalc_oslo(state, pbuf, cs, hasAerosol, numberConcentration, volumeConcentration, & + hygroscopicity, lnSigma, ccn) + do l = 1, psat + call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) + enddo + end if + + tendencyCounted(:)=.FALSE. + do m = 1, ntot_amode + do l = 1, nspec_amode(m) + mm = mam_idx(m,l) + lptr = getTracerIndex(m,l,.false.) + if(.NOT. tendencyCounted(lptr))then + call outfld(fieldname(mm), coltend(:,lptr), pcols,lchnk) + call outfld(fieldname_cw(mm), coltend_cw(:,lptr), pcols,lchnk) + tendencyCounted(lptr)=.TRUE. + endif + end do + end do + + deallocate(nact) + deallocate(mact) + deallocate(raer) + deallocate(qqcw) + deallocate(raercol) + deallocate(raercol_cw) + deallocate(coltend) + deallocate(coltend_cw) + deallocate(naermod) + deallocate(hygro) + deallocate(lnsigman) !Variable std. dev (CAM-Oslo) + deallocate(vaerosol) + deallocate(fn) + deallocate(fm) + deallocate(fluxn) + deallocate(fluxm) + deallocate(fluxm_tmp) + deallocate(fluxn_tmp) + deallocate(fm_tmp) + deallocate(fn_tmp) deallocate(raercol_tracer) deallocate(raercol_cw_tracer) deallocate(mact_tracer) deallocate(mfullact_tracer) -#endif + end subroutine dropmixnuc + + !=============================================================================== + + subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & + qold, surfrate, flxconv, pver, dt, is_unact, qactold ) + + ! explicit integration of droplet/aerosol mixing + ! with source due to activation/nucleation + + + integer, intent(in) :: pver ! number of levels + real(r8), intent(out) :: q(pver) ! mixing ratio to be updated + real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step + real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) + real(r8), intent(in) :: ekkp(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! below layer k (k,k+1 interface) + real(r8), intent(in) :: ekkm(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! above layer k (k,k+1 interface) + real(r8), intent(in) :: overlapp(pver) ! cloud overlap below + real(r8), intent(in) :: overlapm(pver) ! cloud overlap above + real(r8), intent(in) :: surfrate ! surface exchange rate (/s) + real(r8), intent(in) :: flxconv ! convergence of flux from surface + real(r8), intent(in) :: dt ! time step (s) + logical, intent(in) :: is_unact ! true if this is an unactivated species + real(r8), intent(in),optional :: qactold(pver) + ! mixing ratio of ACTIVATED species from previous step + ! *** this should only be present + ! if the current species is unactivated number/sfc/mass + + integer k,kp1,km1 + + if ( is_unact ) then + ! the qactold*(1-overlap) terms are resuspension of activated material + do k=top_lev,pver + kp1=min(k+1,pver) + km1=max(k-1,top_lev) + q(k) = qold(k) + dt*( - src(k) + ekkp(k)*(qold(kp1) - qold(k) + & + qactold(kp1)*(1.0_r8-overlapp(k))) & + + ekkm(k)*(qold(km1) - qold(k) + & + qactold(km1)*(1.0_r8-overlapm(k))) ) + ! force to non-negative + ! if(q(k)<-1.e-30)then + ! write(iulog,*)'q=',q(k),' in explmix' + q(k)=max(q(k),0._r8) + ! endif + end do -end subroutine dropmixnuc + ! diffusion loss at base of lowest layer + q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt + ! force to non-negative + ! if(q(pver)<-1.e-30)then + ! write(iulog,*)'q=',q(pver),' in explmix' + q(pver)=max(q(pver),0._r8) + ! endif + else + do k=top_lev,pver + kp1=min(k+1,pver) + km1=max(k-1,top_lev) + q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & + ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) + ! force to non-negative + ! if(q(k)<-1.e-30)then + ! write(iulog,*)'q=',q(k),' in explmix' + q(k)=max(q(k),0._r8) + ! endif + end do + ! diffusion loss at base of lowest layer + q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt + ! force to non-negative + ! if(q(pver)<-1.e-30)then + ! write(iulog,*)'q=',q(pver),' in explmix' + q(pver)=max(q(pver),0._r8) + + end if + + end subroutine explmix + + !=============================================================================== + + subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & + na, nmode, volume, hygro, & + fn, fm, fluxn, fluxm, flux_fullact, lnsigman ) + + ! calculates number, surface, and mass fraction of aerosols activated as CCN + ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud + ! assumes an internal mixture within each of up to nmode multiple aerosol modes + ! a gaussiam spectrum of updrafts can be treated. + + ! mks units + + ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. + ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + + + ! input + + real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) + real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) + real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) + real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) + real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) + real(r8), intent(in) :: tair ! air temperature (K) + real(r8), intent(in) :: rhoair ! air density (kg/m3) + real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) + integer, intent(in) :: nmode ! number of aerosol modes + real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) + real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode + real(r8), intent(in), optional :: lnsigman(:) + + ! output + + real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated + real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated + real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) + real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) + real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) + + ! used for consistency check -- this should match (ekd(k)*zs(k)) + ! also, fluxm/flux_fullact gives fraction of aerosol mass flux!that is activated + + ! local + integer, parameter:: nx=200 + integer iquasisect_option, isectional + real(r8) integ,integf + real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) + real(r8) xmin(nmode),xmax(nmode) ! ln(r) at section interfaces + real(r8) volmin(nmode),volmax(nmode) ! volume at interfaces + real(r8) tmass ! total aerosol mass concentration (g/cm3) + real(r8) sign(nmode) ! geometric standard deviation of size distribution + real(r8) rm ! number mode radius of aerosol at max supersat (cm) + real(r8) pres ! pressure (Pa) + real(r8) path ! mean free path (m) + real(r8) diff ! diffusivity (m2/s) + real(r8) conduct ! thermal conductivity (Joule/m/sec/deg) + real(r8) diff0,conduct0 + real(r8) es ! saturation vapor pressure + real(r8) qs ! water vapor saturation mixing ratio + real(r8) dqsdt ! change in qs with temperature + real(r8) dqsdp ! change in qs with pressure + real(r8) g ! thermodynamic function (m2/s) + real(r8) zeta(nmode), eta(nmode) + real(r8) lnsmax ! ln(smax) + real(r8) alpha + real(r8) gamma + real(r8) beta + real(r8) sqrtg + real(r8) :: amcube(nmode) ! cube of dry mode radius (m) + real(r8) :: lnsm(nmode) ! ln(smcrit) + real(r8) smc(nmode) ! critical supersaturation for number mode radius + real(r8) sumflx_fullact + real(r8) sumflxn(nmode) + real(r8) sumflxm(nmode) + real(r8) sumfn(nmode) + real(r8) sumfm(nmode) + real(r8) fnold(nmode) ! number fraction activated + real(r8) fmold(nmode) ! mass fraction activated + real(r8) exp45logsig_var(nmode) !variable std. dev (CAM-Oslo) + real(r8), target :: f1_var(nmode), f2_var(nmode) + real(r8) wold,gold + real(r8) alogam + real(r8) rlo,rhi,xint1,xint2,xint3,xint4 + real(r8) wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb + real(r8) dfmin,dfmax,fnew,fold,fnmin,fnbar,fsbar,fmbar + real(r8) alw,sqrtalw + real(r8) smax + real(r8) x,arg + real(r8) xmincoeff,xcut,volcut,surfcut + real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf + real(r8) etafactor1,etafactor2(nmode),etafactor2max + real(r8) grow + character(len=*), parameter :: subname='activate_modal' + integer m,n + ! numerical integration parameters + real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 + + real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) + + integer ndist(nx) ! accumulates frequency distribution of integration bins required + data ndist/nx*0/ + save ndist + + fn(:)=0._r8 + fm(:)=0._r8 + fluxn(:)=0._r8 + fluxm(:)=0._r8 + flux_fullact=0._r8 + + if(nmode.eq.1.and.na(1).lt.1.e-20_r8)return + + if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return + + pres=rair*rhoair*tair + diff0=0.211e-4_r8*(p0/pres)*(tair/t0)**1.94_r8 + conduct0=(5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg + call qsat(tair, pres, es, qs) + dqsdt=latvap/(rh2o*tair*tair)*qs + alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) + gamma=(1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) + etafactor2max=1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. + + grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) & + + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) + sqrtg = sqrt(grow) + beta = 2._r8*pi*rhoh2o*grow*gamma + + do m=1,nmode + + if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then + ! number mode radius (m) + ! write(iulog,*)'alogsig,volc,na=',alogsig(m),volc(m),na(m) + if(present(lnsigman))then + exp45logsig_var(m) = exp(4.5_r8*lnsigman(m)*lnsigman(m)) + amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig_var(m)*na(m))) ! only if variable size dist + f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) + f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) + else + call endrun("Problem with variable std. dev") + endif + ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 + ! should depend on mean radius of mode to account for gas kinetic effects + ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 + ! for approriate size to use for effective diffusivity. + etafactor2(m)=1._r8/(na(m)*beta*sqrtg) + if(hygro(m).gt.1.e-10_r8)then + smc(m)=2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist + else + smc(m)=100._r8 + endif + ! write(iulog,*)'sm,hygro,amcube=',smcrit(m),hygro(m),amcube(m) + else + smc(m)=1._r8 + etafactor2(m)=etafactor2max ! this should make eta big if na is very small. + endif + lnsm(m)=log(smc(m)) ! only if variable size dist + ! write(iulog,'(a,i4,4g12.2)')'m,na,amcube,hygro,sm,lnsm=', & + ! m,na(m),amcube(m),hygro(m),sm(m),lnsm(m) + enddo + + if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts + + wmax=min(wmaxf,wbar+sds*sigw) + wmin=max(wminf,-wdiab) + wmin=max(wmin,wbar-sds*sigw) + w=wmin + dwmax=eps*sigw + dw=dwmax + dfmax=0.2_r8 + dfmin=0.1_r8 + if (wmax <= w) return + do m=1,nmode + sumflxn(m)=0._r8 + sumfn(m)=0._r8 + fnold(m)=0._r8 + sumflxm(m)=0._r8 + sumfm(m)=0._r8 + fmold(m)=0._r8 + enddo + sumflx_fullact=0._r8 + + fold=0._r8 + wold=0._r8 + gold=0._r8 + + dwmin = min( dwmax, 0.01_r8 ) + do n = 1, nx + +100 wnuc=w+wdiab + ! write(iulog,*)'wnuc=',wnuc + alw=alpha*wnuc + sqrtalw=sqrt(alw) + etafactor1=alw*sqrtalw + + do m=1,nmode + eta(m)=etafactor1*etafactor2(m) + zeta(m)=twothird*sqrtalw*aten/sqrtg + enddo + + call maxsat(zeta,eta,nmode,smc,smax & + ,f1_var, f2_var & + ) -!=============================================================================== + lnsmax=log(smax) -subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & - qold, surfrate, flxconv, pver, dt, is_unact, qactold ) - - ! explicit integration of droplet/aerosol mixing - ! with source due to activation/nucleation - - - integer, intent(in) :: pver ! number of levels - real(r8), intent(out) :: q(pver) ! mixing ratio to be updated - real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step - real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) - real(r8), intent(in) :: ekkp(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! below layer k (k,k+1 interface) - real(r8), intent(in) :: ekkm(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! above layer k (k,k+1 interface) - real(r8), intent(in) :: overlapp(pver) ! cloud overlap below - real(r8), intent(in) :: overlapm(pver) ! cloud overlap above - real(r8), intent(in) :: surfrate ! surface exchange rate (/s) - real(r8), intent(in) :: flxconv ! convergence of flux from surface - real(r8), intent(in) :: dt ! time step (s) - logical, intent(in) :: is_unact ! true if this is an unactivated species - real(r8), intent(in),optional :: qactold(pver) - ! mixing ratio of ACTIVATED species from previous step - ! *** this should only be present - ! if the current species is unactivated number/sfc/mass - - integer k,kp1,km1 - - if ( is_unact ) then - ! the qactold*(1-overlap) terms are resuspension of activated material - do k=top_lev,pver - kp1=min(k+1,pver) - km1=max(k-1,top_lev) - q(k) = qold(k) + dt*( - src(k) + ekkp(k)*(qold(kp1) - qold(k) + & - qactold(kp1)*(1.0_r8-overlapp(k))) & - + ekkm(k)*(qold(km1) - qold(k) + & - qactold(km1)*(1.0_r8-overlapm(k))) ) - ! force to non-negative - ! if(q(k)<-1.e-30)then - ! write(iulog,*)'q=',q(k),' in explmix' - q(k)=max(q(k),0._r8) - ! endif - end do - - ! diffusion loss at base of lowest layer - q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt - ! force to non-negative - ! if(q(pver)<-1.e-30)then - ! write(iulog,*)'q=',q(pver),' in explmix' - q(pver)=max(q(pver),0._r8) - ! endif - else - do k=top_lev,pver - kp1=min(k+1,pver) - km1=max(k-1,top_lev) - q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & - ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) - ! force to non-negative - ! if(q(k)<-1.e-30)then - ! write(iulog,*)'q=',q(k),' in explmix' - q(k)=max(q(k),0._r8) - ! endif - end do - ! diffusion loss at base of lowest layer - q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt - ! force to non-negative - ! if(q(pver)<-1.e-30)then - ! write(iulog,*)'q=',q(pver),' in explmix' - q(pver)=max(q(pver),0._r8) - - end if - -end subroutine explmix + x=twothird*(lnsm(nmode)-lnsmax)/(sq2*lnsigman(nmode)) + fnew=0.5_r8*(1._r8-erf(x)) -!=============================================================================== -subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - na, nmode, volume, hygro, & - fn, fm, fluxn, fluxm, flux_fullact, lnsigman ) - - ! calculates number, surface, and mass fraction of aerosols activated as CCN - ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud - ! assumes an internal mixture within each of up to nmode multiple aerosol modes - ! a gaussiam spectrum of updrafts can be treated. - - ! mks units - - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - - ! input - - real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) - real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) - real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) - real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) - real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) - real(r8), intent(in) :: tair ! air temperature (K) - real(r8), intent(in) :: rhoair ! air density (kg/m3) - real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) - integer, intent(in) :: nmode ! number of aerosol modes - real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) - real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode - real(r8), intent(in), optional :: lnsigman(:) - - ! output - - real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated - real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated - real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) - ! rce-comment - ! used for consistency check -- this should match (ekd(k)*zs(k)) - ! also, fluxm/flux_fullact gives fraction of aerosol mass flux - ! that is activated - - ! local - - integer, parameter:: nx=200 - integer iquasisect_option, isectional - real(r8) integ,integf - real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) - real(r8) xmin(nmode),xmax(nmode) ! ln(r) at section interfaces - real(r8) volmin(nmode),volmax(nmode) ! volume at interfaces - real(r8) tmass ! total aerosol mass concentration (g/cm3) - real(r8) sign(nmode) ! geometric standard deviation of size distribution - real(r8) rm ! number mode radius of aerosol at max supersat (cm) - real(r8) pres ! pressure (Pa) - real(r8) path ! mean free path (m) - real(r8) diff ! diffusivity (m2/s) - real(r8) conduct ! thermal conductivity (Joule/m/sec/deg) - real(r8) diff0,conduct0 - real(r8) es ! saturation vapor pressure - real(r8) qs ! water vapor saturation mixing ratio - real(r8) dqsdt ! change in qs with temperature - real(r8) dqsdp ! change in qs with pressure - real(r8) g ! thermodynamic function (m2/s) - real(r8) zeta(nmode), eta(nmode) - real(r8) lnsmax ! ln(smax) - real(r8) alpha - real(r8) gamma - real(r8) beta - real(r8) sqrtg - real(r8) :: amcube(nmode) ! cube of dry mode radius (m) - !++alfgr (ununsed) real(r8) :: smcrit(nmode) ! critical supersatuation for activation - real(r8) :: lnsm(nmode) ! ln(smcrit) - real(r8) smc(nmode) ! critical supersaturation for number mode radius - real(r8) sumflx_fullact - real(r8) sumflxn(nmode) - real(r8) sumflxm(nmode) - real(r8) sumfn(nmode) - real(r8) sumfm(nmode) - real(r8) fnold(nmode) ! number fraction activated - real(r8) fmold(nmode) ! mass fraction activated - real(r8) exp45logsig_var(nmode) !variable std. dev (CAM-Oslo) - real(r8), target :: f1_var(nmode), f2_var(nmode) - real(r8) wold,gold - real(r8) alogam - real(r8) rlo,rhi,xint1,xint2,xint3,xint4 - real(r8) wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb - real(r8) dfmin,dfmax,fnew,fold,fnmin,fnbar,fsbar,fmbar - real(r8) alw,sqrtalw - real(r8) smax - real(r8) x,arg - real(r8) xmincoeff,xcut,volcut,surfcut - real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf - real(r8) etafactor1,etafactor2(nmode),etafactor2max - real(r8) grow - character(len=*), parameter :: subname='activate_modal' - integer m,n - ! numerical integration parameters - real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 - - real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) - - integer ndist(nx) ! accumulates frequency distribution of integration bins required - data ndist/nx*0/ - save ndist - - fn(:)=0._r8 - fm(:)=0._r8 - fluxn(:)=0._r8 - fluxm(:)=0._r8 - flux_fullact=0._r8 - - if(nmode.eq.1.and.na(1).lt.1.e-20_r8)return - - if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return - - pres=rair*rhoair*tair - diff0=0.211e-4_r8*(p0/pres)*(tair/t0)**1.94_r8 - conduct0=(5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg - call qsat(tair, pres, es, qs) - dqsdt=latvap/(rh2o*tair*tair)*qs - alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) - gamma=(1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) - etafactor2max=1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. - - grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) & - + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) - sqrtg = sqrt(grow) - beta = 2._r8*pi*rhoh2o*grow*gamma - - do m=1,nmode - - if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then - ! number mode radius (m) - ! write(iulog,*)'alogsig,volc,na=',alogsig(m),volc(m),na(m) -#ifdef OSLO_AERO - if(present(lnsigman))then - exp45logsig_var(m) = exp(4.5_r8*lnsigman(m)*lnsigman(m)) - amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig_var(m)*na(m))) ! only if variable size dist - f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) - f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) - else - call endrun("Problem with variable std. dev") - endif -#else - !Std cam - amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig(m)*na(m))) ! only if variable size dist -#endif - ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 - ! should depend on mean radius of mode to account for gas kinetic effects - ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 - ! for approriate size to use for effective diffusivity. - etafactor2(m)=1._r8/(na(m)*beta*sqrtg) - if(hygro(m).gt.1.e-10_r8)then - smc(m)=2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist - else - smc(m)=100._r8 - endif - ! write(iulog,*)'sm,hygro,amcube=',smcrit(m),hygro(m),amcube(m) - else - smc(m)=1._r8 - etafactor2(m)=etafactor2max ! this should make eta big if na is very small. - endif - lnsm(m)=log(smc(m)) ! only if variable size dist - ! write(iulog,'(a,i4,4g12.2)')'m,na,amcube,hygro,sm,lnsm=', & - ! m,na(m),amcube(m),hygro(m),sm(m),lnsm(m) - enddo - - if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts - - wmax=min(wmaxf,wbar+sds*sigw) - wmin=max(wminf,-wdiab) - wmin=max(wmin,wbar-sds*sigw) - w=wmin - dwmax=eps*sigw - dw=dwmax - dfmax=0.2_r8 - dfmin=0.1_r8 - if (wmax <= w) return - do m=1,nmode - sumflxn(m)=0._r8 - sumfn(m)=0._r8 - fnold(m)=0._r8 - sumflxm(m)=0._r8 - sumfm(m)=0._r8 - fmold(m)=0._r8 - enddo - sumflx_fullact=0._r8 - - fold=0._r8 - wold=0._r8 - gold=0._r8 - - dwmin = min( dwmax, 0.01_r8 ) - do n = 1, nx - -100 wnuc=w+wdiab - ! write(iulog,*)'wnuc=',wnuc - alw=alpha*wnuc - sqrtalw=sqrt(alw) - etafactor1=alw*sqrtalw - - do m=1,nmode - eta(m)=etafactor1*etafactor2(m) - zeta(m)=twothird*sqrtalw*aten/sqrtg - enddo - - call maxsat(zeta,eta,nmode,smc,smax & -#ifdef OSLO_AERO - ,f1_var, f2_var & -#endif - ) - ! write(iulog,*)'w,smax=',w,smax - - lnsmax=log(smax) - -#ifdef OSLO_AERO - x=twothird*(lnsm(nmode)-lnsmax)/(sq2*lnsigman(nmode)) -#else - x=twothird*(lnsm(nmode)-lnsmax)/(sq2*alogsig(nmode)) -#endif - fnew=0.5_r8*(1._r8-erf(x)) - - - dwnew = dw - if(fnew-fold.gt.dfmax.and.n.gt.1)then - ! reduce updraft increment for greater accuracy in integration - if (dw .gt. 1.01_r8*dwmin) then - dw=0.7_r8*dw - dw=max(dw,dwmin) - w=wold+dw - go to 100 - else - dwnew = dwmin - endif - endif - - if(fnew-fold.lt.dfmin)then - ! increase updraft increment to accelerate integration - dwnew=min(1.5_r8*dw,dwmax) - endif - fold=fnew - - z=(w-wbar)/(sigw*sq2) - g=exp(-z*z) - fnmin=1._r8 - xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - - do m=1,nmode - ! modal -#ifdef OSLO_AERO - x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) -#else - x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) -#endif - fn(m)=0.5_r8*(1._r8-erf(x)) - fnmin=min(fn(m),fnmin) - ! integration is second order accurate - ! assumes linear variation of f*g with w - fnbar=(fn(m)*g+fnold(m)*gold) -#ifdef OSLO_AERO - arg=x-1.5_r8*sq2*lnsigman(m) -#else - arg=x-1.5_r8*sq2*alogsig(m) -#endif - fm(m)=0.5_r8*(1._r8-erf(arg)) - fmbar=(fm(m)*g+fmold(m)*gold) - wb=(w+wold) - if(w.gt.0._r8)then - sumflxn(m)=sumflxn(m)+sixth*(wb*fnbar & - +(fn(m)*g*w+fnold(m)*gold*wold))*dw - sumflxm(m)=sumflxm(m)+sixth*(wb*fmbar & - +(fm(m)*g*w+fmold(m)*gold*wold))*dw - endif - sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw - ! write(iulog,'(a,9g10.2)')'lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw=',lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw - fnold(m)=fn(m) - sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw - fmold(m)=fm(m) - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact & - + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw - ! sumg=sumg+0.5_r8*(g+gold)*dw - gold=g - wold=w - dw=dwnew - if (n > 1 .and. (w > wmax .or. fnmin > fmax)) exit - w=w+dw - if (n == nx) then - write(iulog,*)'do loop is too short in activate' - write(iulog,*)'wmin=',wmin,' w=',w,' wmax=',wmax,' dw=',dw - write(iulog,*)'wbar=',wbar,' sigw=',sigw,' wdiab=',wdiab - write(iulog,*)'wnuc=',wnuc - write(iulog,*)'na=',(na(m),m=1,nmode) - write(iulog,*)'fn=',(fn(m),m=1,nmode) - ! dump all subr parameters to allow testing with standalone code - ! (build a driver that will read input and call activate) - write(iulog,*)'wbar,sigw,wdiab,tair,rhoair,nmode=' - write(iulog,*) wbar,sigw,wdiab,tair,rhoair,nmode - write(iulog,*)'na=',na - write(iulog,*)'volume=', (volume(m),m=1,nmode) - write(iulog,*)'hydro=' - write(iulog,*) hygro - call endrun(subname) - end if - - enddo - - ndist(n)=ndist(n)+1 - if(w.lt.wmaxf)then - - ! contribution from all updrafts stronger than wmax - ! assuming constant f (close to fmax) - wnuc=w+wdiab - - z1=(w-wbar)/(sigw*sq2) - z2=(wmaxf-wbar)/(sigw*sq2) - g=exp(-z1*z1) - integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) - ! consider only upward flow into cloud base when estimating flux - wf1=max(w,zero) - zf1=(wf1-wbar)/(sigw*sq2) - gf1=exp(-zf1*zf1) - wf2=max(wmaxf,zero) - zf2=(wf2-wbar)/(sigw*sq2) - gf2=exp(-zf2*zf2) - gf=(gf1-gf2) - integf=wbar*sigw*0.5_r8*sq2*sqpi*(erf(zf2)-erf(zf1))+sigw*sigw*gf - - do m=1,nmode - sumflxn(m)=sumflxn(m)+integf*fn(m) - sumfn(m)=sumfn(m)+fn(m)*integ - sumflxm(m)=sumflxm(m)+integf*fm(m) - sumfm(m)=sumfm(m)+fm(m)*integ - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact + integf - ! sumg=sumg+integ - endif - - - do m=1,nmode - fn(m)=sumfn(m)/(sq2*sqpi*sigw) - ! fn(m)=sumfn(m)/(sumg) - if(fn(m).gt.1.01_r8)then - write(iulog,*)'fn=',fn(m),' > 1 in activate' - write(iulog,*)'w,m,na,amcube=',w,m,na(m),amcube(m) - write(iulog,*)'integ,sumfn,sigw=',integ,sumfn(m),sigw - call endrun('activate') - endif - fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) - fm(m)=sumfm(m)/(sq2*sqpi*sigw) - ! fm(m)=sumfm(m)/(sumg) - if(fm(m).gt.1.01_r8)then - write(iulog,*)'fm=',fm(m),' > 1 in activate' - endif - fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) - enddo - ! same form as fluxm - flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) - - else - - ! single updraft - wnuc=wbar+wdiab - - if(wnuc.gt.0._r8)then - - w=wbar - alw=alpha*wnuc - sqrtalw=sqrt(alw) - etafactor1=alw*sqrtalw - - do m=1,nmode - eta(m)=etafactor1*etafactor2(m) - zeta(m)=twothird*sqrtalw*aten/sqrtg -#ifdef OSLO_AERO - if(present(lnsigman))then - f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) - f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) - else - call endrun("Problem with variable std. dev single updraft") + dwnew = dw + if(fnew-fold.gt.dfmax.and.n.gt.1)then + ! reduce updraft increment for greater accuracy in integration + if (dw .gt. 1.01_r8*dwmin) then + dw=0.7_r8*dw + dw=max(dw,dwmin) + w=wold+dw + go to 100 + else + dwnew = dwmin endif -#endif - enddo - - call maxsat(zeta,eta,nmode,smc,smax & -#ifdef OSLO_AERO - ,f1_var, f2_var & -#endif - ) - - lnsmax=log(smax) - xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - - - do m=1,nmode -#ifdef OSLO_AERO - x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) -#else - x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) -#endif - fn(m)=0.5_r8*(1._r8-erf(x)) -#ifdef OSLO_AERO - arg=x-1.5_r8*sq2*lnsigman(m) -#else - arg=x-1.5_r8*sq2*alogsig(m) -#endif - fm(m)=0.5_r8*(1._r8-erf(arg)) - if(wbar.gt.0._r8)then - fluxn(m)=fn(m)*w - fluxm(m)=fm(m)*w - endif - enddo - flux_fullact = w - endif - - endif - -end subroutine activate_modal - -!=============================================================================== + endif + + if(fnew-fold.lt.dfmin)then + ! increase updraft increment to accelerate integration + dwnew=min(1.5_r8*dw,dwmax) + endif + fold=fnew + + z=(w-wbar)/(sigw*sq2) + g=exp(-z*z) + fnmin=1._r8 + xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 + + do m=1,nmode + ! modal + x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) + fn(m)=0.5_r8*(1._r8-erf(x)) + fnmin=min(fn(m),fnmin) + ! integration is second order accurate + ! assumes linear variation of f*g with w + fnbar=(fn(m)*g+fnold(m)*gold) + arg=x-1.5_r8*sq2*lnsigman(m) + fm(m)=0.5_r8*(1._r8-erf(arg)) + fmbar=(fm(m)*g+fmold(m)*gold) + wb=(w+wold) + if(w.gt.0._r8)then + sumflxn(m)=sumflxn(m)+sixth*(wb*fnbar & + +(fn(m)*g*w+fnold(m)*gold*wold))*dw + sumflxm(m)=sumflxm(m)+sixth*(wb*fmbar & + +(fm(m)*g*w+fmold(m)*gold*wold))*dw + endif + sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw + ! write(iulog,'(a,9g10.2)')'lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw=',lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw + fnold(m)=fn(m) + sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw + fmold(m)=fm(m) + enddo + ! same form as sumflxm but replace the fm with 1.0 + sumflx_fullact = sumflx_fullact & + + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw + ! sumg=sumg+0.5_r8*(g+gold)*dw + gold=g + wold=w + dw=dwnew + if (n > 1 .and. (w > wmax .or. fnmin > fmax)) exit + w=w+dw + if (n == nx) then + write(iulog,*)'do loop is too short in activate' + write(iulog,*)'wmin=',wmin,' w=',w,' wmax=',wmax,' dw=',dw + write(iulog,*)'wbar=',wbar,' sigw=',sigw,' wdiab=',wdiab + write(iulog,*)'wnuc=',wnuc + write(iulog,*)'na=',(na(m),m=1,nmode) + write(iulog,*)'fn=',(fn(m),m=1,nmode) + ! dump all subr parameters to allow testing with standalone code + ! (build a driver that will read input and call activate) + write(iulog,*)'wbar,sigw,wdiab,tair,rhoair,nmode=' + write(iulog,*) wbar,sigw,wdiab,tair,rhoair,nmode + write(iulog,*)'na=',na + write(iulog,*)'volume=', (volume(m),m=1,nmode) + write(iulog,*)'hydro=' + write(iulog,*) hygro + call endrun(subname) + end if -subroutine maxsat(zeta,eta,nmode,smc,smax, f1_in, f2_in) - - ! calculates maximum supersaturation for multiple - ! competing aerosol modes. - - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - integer, intent(in) :: nmode ! number of modes - real(r8), intent(in) :: smc(nmode) ! critical supersaturation for number mode radius - real(r8), intent(in) :: zeta(nmode) - real(r8), intent(in) :: eta(nmode) - real(r8), intent(in), optional, target :: f1_in(:) - real(r8), intent(in), optional, target :: f2_in(:) - - real(r8), intent(out) :: smax ! maximum supersaturation - integer :: m ! mode index - real(r8) :: sum, g1, g2, g1sqrt, g2sqrt - real(r8), pointer :: f1_used(:), f2_used(:) - -#ifdef OSLO_AERO - f1_used => f1_in - f2_used => f2_in -#else - f1_used => f1 - f2_used => f2 -#endif - - - do m=1,nmode - if(zeta(m).gt.1.e5_r8*eta(m).or.smc(m)*smc(m).gt.1.e5_r8*eta(m))then - ! weak forcing. essentially none activated - smax=1.e-20_r8 - else - ! significant activation of this mode. calc activation all modes. - exit - endif - ! No significant activation in any mode. Do nothing. - if (m == nmode) return - - enddo - - sum=0.0_r8 - do m=1,nmode - if(eta(m).gt.1.e-20_r8)then - g1=zeta(m)/eta(m) - g1sqrt=sqrt(g1) - g1=g1sqrt*g1 - g2=smc(m)/sqrt(eta(m)+3._r8*zeta(m)) - g2sqrt=sqrt(g2) - g2=g2sqrt*g2 - sum=sum+(f1_used(m)*g1+f2_used(m)*g2)/(smc(m)*smc(m)) - else - sum=1.e20_r8 - endif - enddo - - smax=1._r8/sqrt(sum) - -end subroutine maxsat + enddo + + ndist(n)=ndist(n)+1 + if(w.lt.wmaxf)then + + ! contribution from all updrafts stronger than wmax + ! assuming constant f (close to fmax) + wnuc=w+wdiab + + z1=(w-wbar)/(sigw*sq2) + z2=(wmaxf-wbar)/(sigw*sq2) + g=exp(-z1*z1) + integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) + ! consider only upward flow into cloud base when estimating flux + wf1=max(w,zero) + zf1=(wf1-wbar)/(sigw*sq2) + gf1=exp(-zf1*zf1) + wf2=max(wmaxf,zero) + zf2=(wf2-wbar)/(sigw*sq2) + gf2=exp(-zf2*zf2) + gf=(gf1-gf2) + integf=wbar*sigw*0.5_r8*sq2*sqpi*(erf(zf2)-erf(zf1))+sigw*sigw*gf + + do m=1,nmode + sumflxn(m)=sumflxn(m)+integf*fn(m) + sumfn(m)=sumfn(m)+fn(m)*integ + sumflxm(m)=sumflxm(m)+integf*fm(m) + sumfm(m)=sumfm(m)+fm(m)*integ + enddo + ! same form as sumflxm but replace the fm with 1.0 + sumflx_fullact = sumflx_fullact + integf + ! sumg=sumg+integ + endif + + + do m=1,nmode + fn(m)=sumfn(m)/(sq2*sqpi*sigw) + ! fn(m)=sumfn(m)/(sumg) + if(fn(m).gt.1.01_r8)then + write(iulog,*)'fn=',fn(m),' > 1 in activate' + write(iulog,*)'w,m,na,amcube=',w,m,na(m),amcube(m) + write(iulog,*)'integ,sumfn,sigw=',integ,sumfn(m),sigw + call endrun('activate') + endif + fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) + fm(m)=sumfm(m)/(sq2*sqpi*sigw) + ! fm(m)=sumfm(m)/(sumg) + if(fm(m).gt.1.01_r8)then + write(iulog,*)'fm=',fm(m),' > 1 in activate' + endif + fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) + enddo + ! same form as fluxm + flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) + + else + + ! single updraft + wnuc=wbar+wdiab + + if(wnuc.gt.0._r8)then + + w=wbar + alw=alpha*wnuc + sqrtalw=sqrt(alw) + etafactor1=alw*sqrtalw + + do m=1,nmode + eta(m)=etafactor1*etafactor2(m) + zeta(m)=twothird*sqrtalw*aten/sqrtg + if(present(lnsigman))then + f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) + f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) + else + call endrun("Problem with variable std. dev single updraft") + endif + enddo -!=============================================================================== + call maxsat(zeta,eta,nmode,smc,smax & + ,f1_var, f2_var & + ) -#ifndef OSLO_AERO -subroutine ccncalc(state, pbuf, cs, ccn) - - ! calculates number concentration of aerosols activated as CCN at - ! supersaturation supersat. - ! assumes an internal mixture of a multiple externally-mixed aerosol modes - ! cgs units - - ! Ghan et al., Atmos. Res., 1993, 198-221. - - ! arguments - - type(physics_state), target, intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - - real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) - real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) - - ! local - - integer :: lchnk ! chunk index - integer :: ncol ! number of columns - real(r8), pointer :: tair(:,:) ! air temperature (K) - - real(r8) naerosol(pcols) ! interstit+activated aerosol number conc (/m3) - real(r8) vaerosol(pcols) ! interstit+activated aerosol volume conc (m3/m3) - - real(r8) amcube(pcols) - real(r8) super(psat) ! supersaturation - real(r8), allocatable :: amcubecoef(:) - real(r8), allocatable :: argfactor(:) - real(r8) :: surften ! surface tension of water w/respect to air (N/m) - real(r8) surften_coef - real(r8) a(pcols) ! surface tension parameter - real(r8) hygro(pcols) ! aerosol hygroscopicity - real(r8) sm(pcols) ! critical supersaturation at mode radius - real(r8) arg(pcols) - ! mathematical constants - real(r8) twothird,sq2 - integer l,m,n,i,k - real(r8) log,cc - real(r8) smcoefcoef,smcoef(pcols) - integer phase ! phase of aerosol - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - tair => state%t - - allocate( & - amcubecoef(ntot_amode), & - argfactor(ntot_amode) ) - - super(:)=supersat(:)*0.01_r8 - sq2=sqrt(2._r8) - twothird=2._r8/3._r8 - surften=0.076_r8 - surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) - smcoefcoef=2._r8/sqrt(27._r8) - - do m=1,ntot_amode - amcubecoef(m)=3._r8/(4._r8*pi*exp45logsig(m)) - argfactor(m)=twothird/(sq2*alogsig(m)) - end do - - ccn = 0._r8 - do k=top_lev,pver - - do i=1,ncol - a(i)=surften_coef/tair(i,k) - smcoef(i)=smcoefcoef*a(i)*sqrt(a(i)) - end do - - do m=1,ntot_amode - - phase=3 ! interstitial+cloudborne - - call loadaer( & - state, pbuf, 1, ncol, k, & - m, cs, phase, naerosol, vaerosol, & - hygro) - - where(naerosol(:ncol)>1.e-3_r8) - amcube(:ncol)=amcubecoef(m)*vaerosol(:ncol)/naerosol(:ncol) - sm(:ncol)=smcoef(:ncol)/sqrt(hygro(:ncol)*amcube(:ncol)) ! critical supersaturation - elsewhere - sm(:ncol)=1._r8 ! value shouldn't matter much since naerosol is small - endwhere - do l=1,psat - do i=1,ncol - arg(i)=argfactor(m)*log(sm(i)/super(l)) - ccn(i,k,l)=ccn(i,k,l)+naerosol(i)*0.5_r8*(1._r8-erf(arg(i))) - enddo - enddo - enddo - enddo - ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 - - deallocate( & - amcubecoef, & - argfactor ) - -end subroutine ccncalc - -#else - -subroutine ccncalc_oslo(state & - , pbuf & - , cs & -!+tht - , hasAerosol & -!-tht - , numberConcentration & - , volumeConcentration & - , hygroscopicity & - , lnSigma & - , ccn ) - - ! calculates number concentration of aerosols activated as CCN at - ! supersaturation supersat. - ! assumes an internal mixture of a multiple externally-mixed aerosol modes - ! cgs units - - ! This was used in the BACCHUS-project where it was agreed that - ! CCN would not include cloud-borne aerosols. It is possible to - ! calculate cloud-borne aerosols, but it is complicated, and it was - ! not needed when this code was made. - - ! arguments - - type(physics_state), target, intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) - real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) -!+tht - logical, intent(in) :: hasAerosol(pcols, pver, nmodes) -!-tht -!akc6 real(r8), intent(in) :: numberConcentration(pcols,pver, nmodes) ! interstit+activated aerosol number conc (/m3) - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ! interstit+activated aerosol number conc (/m3) -!akc6- - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ! interstit+activated aerosol volume conc (m3/m3) - real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) - real(r8), intent(in) :: lnSigma(pcols,pver,nmodes) - - ! local - integer :: lchnk ! chunk index - integer :: ncol ! number of columns - real(r8), pointer :: tair(:,:) ! air temperature (K) - - - real(r8) super(psat) ! supersaturation - real(r8) surften_coef !Coefficient in ARGI / ARGII - real(r8) amcube !number median radius qubed - real(r8) a ! surface tension parameter - real(r8) sm ! critical supersaturation at mode radius - real(r8) arg ! factor in eqn 15 ARGII - real(r8) argfactor !Coefficient in ARGI/ARGII - ! mathematical constants - real(r8), parameter:: twothird=2.0_r8/3.0_r8 - real(r8), parameter:: sq2=sqrt(2.0_r8) - real(r8), parameter :: surften=0.076_r8 !surface tension of water (J/m2) - real(r8) exp45logsig_var - integer lsat,m,i,k - real(r8) smcoefcoef,smcoef - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - tair => state%t - - super(:)=supersat(:)*0.01_r8 - - !This is curvature effect (A) in ARGI - !eqn 5 in ARG1 (missing division by temperature, see below) - surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) - - !This is part of eqn 9 in ARGII - !where A smcoefcoef is 2/3^(3/2) - smcoefcoef=2._r8/sqrt(27._r8) - - ccn(:,:,:) = 0._r8 - - do m=1,nmodes - do k=top_lev,pver + lnsmax=log(smax) + xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - do i=1,ncol - if (hasAerosol(i,k,m)) then - !Curvature-parameter "A" in ARGI (eqn 5) - a = surften_coef/tair(i,k) - !standard factor for transforming size distr - !volume ==> number (google psd.pdf by zender) - exp45logsig_var = & - exp(4.5_r8*lnsigma(i,k,m)*lnsigma(i,k,m)) + do m=1,nmode + x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) + fn(m)=0.5_r8*(1._r8-erf(x)) + arg=x-1.5_r8*sq2*lnsigman(m) + fm(m)=0.5_r8*(1._r8-erf(arg)) + if(wbar.gt.0._r8)then + fluxn(m)=fn(m)*w + fluxm(m)=fm(m)*w + endif + enddo + flux_fullact = w + endif + + endif + + end subroutine activate_modal + + !=============================================================================== + + subroutine maxsat(zeta,eta,nmode,smc,smax, f1_in, f2_in) + + ! calculates maximum supersaturation for multiple + ! competing aerosol modes. + + ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. + ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + + integer, intent(in) :: nmode ! number of modes + real(r8), intent(in) :: smc(nmode) ! critical supersaturation for number mode radius + real(r8), intent(in) :: zeta(nmode) + real(r8), intent(in) :: eta(nmode) + real(r8), intent(in), optional, target :: f1_in(:) + real(r8), intent(in), optional, target :: f2_in(:) + + real(r8), intent(out) :: smax ! maximum supersaturation + integer :: m ! mode index + real(r8) :: sum, g1, g2, g1sqrt, g2sqrt + real(r8), pointer :: f1_used(:), f2_used(:) + + f1_used => f1_in + f2_used => f2_in + + do m=1,nmode + if(zeta(m).gt.1.e5_r8*eta(m).or.smc(m)*smc(m).gt.1.e5_r8*eta(m))then + ! weak forcing. essentially none activated + smax=1.e-20_r8 + else + ! significant activation of this mode. calc activation all modes. + exit + endif + ! No significant activation in any mode. Do nothing. + if (m == nmode) return + + enddo + + sum=0.0_r8 + do m=1,nmode + if(eta(m).gt.1.e-20_r8)then + g1=zeta(m)/eta(m) + g1sqrt=sqrt(g1) + g1=g1sqrt*g1 + g2=smc(m)/sqrt(eta(m)+3._r8*zeta(m)) + g2sqrt=sqrt(g2) + g2=g2sqrt*g2 + sum=sum+(f1_used(m)*g1+f2_used(m)*g2)/(smc(m)*smc(m)) + else + sum=1.e20_r8 + endif + enddo + + smax=1._r8/sqrt(sum) + + end subroutine maxsat + + !=============================================================================== + + subroutine ccncalc_oslo(state & + , pbuf & + , cs & + , hasAerosol & + , numberConcentration & + , volumeConcentration & + , hygroscopicity & + , lnSigma & + , ccn ) + + ! calculates number concentration of aerosols activated as CCN at + ! supersaturation supersat. + ! assumes an internal mixture of a multiple externally-mixed aerosol modes + ! cgs units + + ! This was used in the BACCHUS-project where it was agreed that + ! CCN would not include cloud-borne aerosols. It is possible to + ! calculate cloud-borne aerosols, but it is complicated, and it was + ! not needed when this code was made. + + ! arguments + + type(physics_state), target, intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) + real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) + !+tht + logical, intent(in) :: hasAerosol(pcols, pver, nmodes) + !-tht + !akc6 real(r8), intent(in) :: numberConcentration(pcols,pver, nmodes) ! interstit+activated aerosol number conc (/m3) + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ! interstit+activated aerosol number conc (/m3) + !akc6- + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ! interstit+activated aerosol volume conc (m3/m3) + real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) + real(r8), intent(in) :: lnSigma(pcols,pver,nmodes) + + ! local + integer :: lchnk ! chunk index + integer :: ncol ! number of columns + real(r8), pointer :: tair(:,:) ! air temperature (K) + + + real(r8) super(psat) ! supersaturation + real(r8) surften_coef !Coefficient in ARGI / ARGII + real(r8) amcube !number median radius qubed + real(r8) a ! surface tension parameter + real(r8) sm ! critical supersaturation at mode radius + real(r8) arg ! factor in eqn 15 ARGII + real(r8) argfactor !Coefficient in ARGI/ARGII + ! mathematical constants + real(r8), parameter:: twothird=2.0_r8/3.0_r8 + real(r8), parameter:: sq2=sqrt(2.0_r8) + real(r8), parameter :: surften=0.076_r8 !surface tension of water (J/m2) + real(r8) exp45logsig_var + integer lsat,m,i,k + real(r8) smcoefcoef,smcoef + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + tair => state%t + + super(:)=supersat(:)*0.01_r8 + + !This is curvature effect (A) in ARGI + !eqn 5 in ARG1 (missing division by temperature, see below) + surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) + + !This is part of eqn 9 in ARGII + !where A smcoefcoef is 2/3^(3/2) + smcoefcoef=2._r8/sqrt(27._r8) + + ccn(:,:,:) = 0._r8 + + do m=1,nmodes + do k=top_lev,pver - !Numbe rmedian radius (power of three) - !By definition of lognormal distribution - amcube =(3._r8*volumeConcentration(i,k,m) & - /(4._r8*pi*exp45logsig_var*numberConcentration(i,k,m))) ! only if variable size dist + do i=1,ncol + if (hasAerosol(i,k,m)) then + !Curvature-parameter "A" in ARGI (eqn 5) + a = surften_coef/tair(i,k) + !standard factor for transforming size distr + !volume ==> number (google psd.pdf by zender) + exp45logsig_var = & + exp(4.5_r8*lnsigma(i,k,m)*lnsigma(i,k,m)) - !This is part of eqn 9 in ARGII - !where A smcoefcoef is 2/3^(3/2) - smcoef = smcoefcoef * a * sqrt(a) + !Numbe rmedian radius (power of three) + !By definition of lognormal distribution + amcube =(3._r8*volumeConcentration(i,k,m) & + /(4._r8*pi*exp45logsig_var*numberConcentration(i,k,m))) ! only if variable size dist - !This is finally solving eqn 9 - !(solve for critical supersat of mode) - sm=smcoef & - / sqrt(hygroscopicity(i,k,m)*amcube) ! critical supersaturation - !Solve eqn 13 in ARGII - do lsat = 1,psat - - !eqn 15 in ARGII - argfactor=twothird/(sq2*lnSigma(i,k,m)) + !This is part of eqn 9 in ARGII + !where A smcoefcoef is 2/3^(3/2) + smcoef = smcoefcoef * a * sqrt(a) - !eqn 15 in ARGII - arg=argfactor*log(sm/super(lsat)) + !This is finally solving eqn 9 + !(solve for critical supersat of mode) + sm=smcoef & + / sqrt(hygroscopicity(i,k,m)*amcube) ! critical supersaturation - !eqn 13 i ARGII - ccn(i,k,lsat)=ccn(i,k,lsat) & - +numberConcentration(i,k,m)& - *0.5_r8*(1._r8-erf(arg)) + !Solve eqn 13 in ARGII + do lsat = 1,psat - end do - end if - end do - end do - end do + !eqn 15 in ARGII + argfactor=twothird/(sq2*lnSigma(i,k,m)) - ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 + !eqn 15 in ARGII + arg=argfactor*log(sm/super(lsat)) -end subroutine ccncalc_oslo -#endif + !eqn 13 i ARGII + ccn(i,k,lsat)=ccn(i,k,lsat) & + +numberConcentration(i,k,m)& + *0.5_r8*(1._r8-erf(arg)) -!=============================================================================== + end do + end if + end do + end do + end do -subroutine loadaer( & - state, pbuf, istart, istop, k, & - m, cs, phase, naerosol, & - vaerosol, hygro) - - ! return aerosol number, volume concentrations, and bulk hygroscopicity - - ! input arguments - type(physics_state), target, intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - integer, intent(in) :: istart ! start column index (1 <= istart <= istop <= pcols) - integer, intent(in) :: istop ! stop column index - integer, intent(in) :: m ! mode index - integer, intent(in) :: k ! level index - real(r8), intent(in) :: cs(:,:) ! air density (kg/m3) - integer, intent(in) :: phase ! phase of aerosol: 1 for interstitial, 2 for cloud-borne, 3 for sum - - ! output arguments - real(r8), intent(out) :: naerosol(:) ! number conc (1/m3) - real(r8), intent(out) :: vaerosol(:) ! volume conc (m3/m3) - real(r8), intent(out) :: hygro(:) ! bulk hygroscopicity of mode - - ! internal - integer :: lchnk ! chunk identifier - - real(r8), pointer :: raer(:,:) ! interstitial aerosol mass, number mixing ratios - real(r8), pointer :: qqcw(:,:) ! cloud-borne aerosol mass, number mixing ratios - real(r8) :: specdens, spechygro - - real(r8) :: vol(pcols) ! aerosol volume mixing ratio - integer :: i, l - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - - do i = istart, istop - vaerosol(i) = 0._r8 - hygro(i) = 0._r8 - end do - - do l = 1, nspec_amode(m) - - call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, raer) - call rad_cnst_get_aer_mmr(0, m, l, 'c', state, pbuf, qqcw) - call rad_cnst_get_aer_props(0, m, l, density_aer=specdens, hygro_aer=spechygro) - - if (phase == 3) then - do i = istart, istop - vol(i) = max(raer(i,k) + qqcw(i,k), 0._r8)/specdens - end do - else if (phase == 2) then - do i = istart, istop - vol(i) = max(qqcw(i,k), 0._r8)/specdens - end do - else if (phase == 1) then - do i = istart, istop - vol(i) = max(raer(i,k), 0._r8)/specdens - end do - else - write(iulog,*)'phase=',phase,' in loadaer' - call endrun('phase error in loadaer') - end if - - do i = istart, istop - vaerosol(i) = vaerosol(i) + vol(i) - hygro(i) = hygro(i) + vol(i)*spechygro - end do - - end do - - do i = istart, istop - if (vaerosol(i) > 1.0e-30_r8) then ! +++xl add 8/2/2007 - hygro(i) = hygro(i)/(vaerosol(i)) - vaerosol(i) = vaerosol(i)*cs(i,k) - else - hygro(i) = 0.0_r8 - vaerosol(i) = 0.0_r8 - end if - end do - - ! aerosol number - call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, raer) - call rad_cnst_get_mode_num(0, m, 'c', state, pbuf, qqcw) - if (phase == 3) then - do i = istart, istop - naerosol(i) = (raer(i,k) + qqcw(i,k))*cs(i,k) - end do - else if (phase == 2) then - do i = istart, istop - naerosol(i) = qqcw(i,k)*cs(i,k) - end do - else - do i = istart, istop - naerosol(i) = raer(i,k)*cs(i,k) - end do - end if - ! adjust number so that dgnumlo < dgnum < dgnumhi - do i = istart, istop - naerosol(i) = max(naerosol(i), vaerosol(i)*voltonumbhi_amode(m)) - naerosol(i) = min(naerosol(i), vaerosol(i)*voltonumblo_amode(m)) - end do - -end subroutine loadaer + ccn(:ncol,:,:) = ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 -!=============================================================================== + end subroutine ccncalc_oslo end module ndrop - - - - From 0a901473dc70d93564afe35f0a617449ffd8d6de Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 16 Aug 2023 19:05:01 +0200 Subject: [PATCH 07/71] removed routines that are not needed --- src/chemistry/oslo_aero/ndrop.F90.fpe | 3097 ----------------------- src/physics/cam_oslo/aeroopt_mod.F90 | 2 +- src/physics/cam_oslo/coltst4intcons.F90 | 302 --- src/physics/cam_oslo/ptaero_table.F90 | 280 -- src/physics/cam_oslo/table_manager.F90 | 95 - 5 files changed, 1 insertion(+), 3775 deletions(-) delete mode 100644 src/chemistry/oslo_aero/ndrop.F90.fpe delete mode 100644 src/physics/cam_oslo/coltst4intcons.F90 delete mode 100644 src/physics/cam_oslo/ptaero_table.F90 delete mode 100644 src/physics/cam_oslo/table_manager.F90 diff --git a/src/chemistry/oslo_aero/ndrop.F90.fpe b/src/chemistry/oslo_aero/ndrop.F90.fpe deleted file mode 100644 index bd90190fc4..0000000000 --- a/src/chemistry/oslo_aero/ndrop.F90.fpe +++ /dev/null @@ -1,3097 +0,0 @@ -module ndrop - -!--------------------------------------------------------------------------------- -! Purpose: -! CAM Interface for droplet activation by modal aerosols -! -! ***N.B.*** This module is currently hardcoded to recognize only the modes that -! affect the climate calculation. This is implemented by using list -! index 0 in all the calls to rad_constituent interfaces. -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8 => shr_kind_r8 -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver, pverp -use physconst, only: pi, rhoh2o, mwh2o, r_universal, rh2o, & - gravit, latvap, cpair, epsilo, rair -use constituents, only: pcnst, cnst_get_ind, cnst_name, cnst_spec_class_gas, cnst_species_class -use physics_types, only: physics_state, physics_ptend, physics_ptend_init -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field - -use wv_saturation, only: qsat -use phys_control, only: phys_getopts -use ref_pres, only: top_lev => trop_cloud_top_lev -use shr_spfn_mod, only: erf => shr_spfn_erf -use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_mode_num, rad_cnst_get_aer_mmr, & - rad_cnst_get_aer_props, rad_cnst_get_mode_props, & - rad_cnst_get_mam_mmr_idx, rad_cnst_get_mode_num_idx -use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld -use cam_abortutils, only: endrun -use cam_logfile, only: iulog -!++ MH_2015/09/09 -use phys_control, only: use_hetfrz_classnuc -!-- MH_2015/09/09 - -#ifdef OSLO_AERO -!++oslo -use aerosoldef -use parmix_progncdnc -use oslo_utils, only: calculateNumberMedianRadius -!--oslo -#endif - - -implicit none -private -save - -public ndrop_init, dropmixnuc, activate_modal, loadaer - -#ifndef OSLO_AERO -real(r8), allocatable :: alogsig(:) ! natl log of geometric standard dev of aerosol -real(r8), allocatable :: exp45logsig(:) -real(r8), allocatable, target :: f1(:) ! abdul-razzak functions of width -real(r8), allocatable, target :: f2(:) ! abdul-razzak functions of width -#endif - -real(r8) :: t0 ! reference temperature -real(r8) :: aten -real(r8) :: surften ! surface tension of water w/respect to air (N/m) -real(r8) :: alog2, alog3, alogaten -real(r8) :: third, twothird, sixth, zero -real(r8) :: sq2, sqpi - -! CCN diagnostic fields -integer, parameter :: psat=6 ! number of supersaturations to calc ccn concentration -real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration - (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) -character(len=8) :: ccn_name(psat)= & - (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6'/) - -! indices in state and pbuf structures -integer :: numliq_idx = -1 -integer :: kvh_idx = -1 - -! description of modal aerosols -integer :: ntot_amode ! number of aerosol modes -integer, allocatable :: nspec_amode(:) ! number of chemical species in each aerosol mode -real(r8), allocatable :: sigmag_amode(:)! geometric standard deviation for each aerosol mode -real(r8), allocatable :: dgnumlo_amode(:) -real(r8), allocatable :: dgnumhi_amode(:) -real(r8), allocatable :: voltonumblo_amode(:) -real(r8), allocatable :: voltonumbhi_amode(:) - -logical :: history_aerosol ! Output the MAM aerosol tendencies -character(len=fieldname_len), allocatable :: fieldname(:) ! names for drop nuc tendency output fields -character(len=fieldname_len), allocatable :: fieldname_cw(:) ! names for drop nuc tendency output fields - -! local indexing for MAM -integer, allocatable :: mam_idx(:,:) ! table for local indexing of modal aero number and mmr -integer :: ncnst_tot ! total number of mode number conc + mode species - -! Indices for MAM species in the ptend%q array. Needed for prognostic aerosol case. -integer, allocatable :: mam_cnst_idx(:,:) - -#ifdef OSLO_AERO -logical :: tendencyCounted(pcnst) = .false. ! set flags true for constituents with non-zero tendencies -integer :: n_aerosol_tracers -integer :: aerosolTracerList(pcnst) !List where indexes 1...n_aerosol_tracers are the indexes in pcnst - !..something like (/ l_so4_a1, l_bc_a, .../)etc -integer :: inverseAerosolTracerList(pcnst) !List where you can back the place in aerosolTracerList if you know the - !tracer index. So in the example above inverseAerosolTracerList(l_so4_a1) = 1 -#endif - -! ptr2d_t is used to create arrays of pointers to 2D fields -type ptr2d_t - real(r8), pointer :: fld(:,:) -end type ptr2d_t - -! modal aerosols -logical :: prog_modal_aero ! true when modal aerosols are prognostic -logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies - ! in the ptend object - -!=============================================================================== -contains -!=============================================================================== - -subroutine ndrop_init - - integer :: ii, l, lptr, m, mm - integer :: nspec_max ! max number of species in a mode - character(len=32) :: tmpname - character(len=32) :: tmpname_cw - character(len=128) :: long_name - character(len=8) :: unit - logical :: history_amwg ! output the variables used by the AMWG diag package -#ifdef OSLO_AERO - character(len=10) :: modeString - character(len=20) :: varname -#endif - - !------------------------------------------------------------------------------- - - ! get indices into state%q and pbuf structures - call cnst_get_ind('NUMLIQ', numliq_idx) - - kvh_idx = pbuf_get_index('kvh') - - zero = 0._r8 - third = 1._r8/3._r8 - twothird = 2._r8*third - sixth = 1._r8/6._r8 - sq2 = sqrt(2._r8) - sqpi = sqrt(pi) - - t0 = 273._r8 - surften = 0.076_r8 - aten = 2._r8*mwh2o*surften/(r_universal*t0*rhoh2o) - alogaten = log(aten) - alog2 = log(2._r8) - alog3 = log(3._r8) - - ! get info about the modal aerosols - ! get ntot_amode -#ifdef OSLO_AERO - ntot_amode = nmodes !from opttab -#else - call rad_cnst_get_info(0, nmodes=ntot_amode) -#endif - allocate( & - nspec_amode(ntot_amode), & - sigmag_amode(ntot_amode), & - dgnumlo_amode(ntot_amode), & - dgnumhi_amode(ntot_amode), & -#ifndef OSLO_AERO - alogsig(ntot_amode), & - exp45logsig(ntot_amode), & - f1(ntot_amode), & - f2(ntot_amode), & -#endif - voltonumblo_amode(ntot_amode), & - voltonumbhi_amode(ntot_amode) ) - -#ifdef OSLO_AERO - do m = 1,ntot_amode - nspec_amode(m) = getNumberOfTracersInMode(m) - enddo -#else - do m = 1, ntot_amode - ! use only if width of size distribution is prescribed - - ! get mode info - call rad_cnst_get_info(0, m, nspec=nspec_amode(m)) - - ! get mode properties - call rad_cnst_get_mode_props(0, m, sigmag=sigmag_amode(m), & - dgnumhi=dgnumhi_amode(m), dgnumlo=dgnumlo_amode(m)) - - alogsig(m) = log(sigmag_amode(m)) - exp45logsig(m) = exp(4.5_r8*alogsig(m)*alogsig(m)) - f1(m) = 0.5_r8*exp(2.5_r8*alogsig(m)*alogsig(m)) - f2(m) = 1._r8 + 0.25_r8*alogsig(m) - - voltonumblo_amode(m) = 1._r8 / ( (pi/6._r8)* & - (dgnumlo_amode(m)**3._r8)*exp(4.5_r8*alogsig(m)**2._r8) ) - voltonumbhi_amode(m) = 1._r8 / ( (pi/6._r8)* & - (dgnumhi_amode(m)**3._r8)*exp(4.5_r8*alogsig(m)**2._r8) ) - end do -#endif - ! Init the table for local indexing of mam number conc and mmr. - ! This table uses species index 0 for the number conc. - - ! Find max number of species in all the modes, and the total - ! number of mode number concentrations + mode species - nspec_max = nspec_amode(1) - ncnst_tot = nspec_amode(1) + 1 - do m = 2, ntot_amode - nspec_max = max(nspec_max, nspec_amode(m)) - ncnst_tot = ncnst_tot + nspec_amode(m) + 1 - end do - - allocate( & - mam_idx(ntot_amode,0:nspec_max), & - mam_cnst_idx(ntot_amode,0:nspec_max), & - fieldname(ncnst_tot), & - fieldname_cw(ncnst_tot) ) - - ! Local indexing compresses the mode and number/mass indicies into one index. - ! This indexing is used by the pointer arrays used to reference state and pbuf - ! fields. - ii = 0 - do m = 1, ntot_amode - do l = 0, nspec_amode(m) - ii = ii + 1 - mam_idx(m,l) = ii - end do - end do - - ! Add dropmixnuc tendencies for all modal aerosol species - - call phys_getopts(history_amwg_out = history_amwg, & - history_aerosol_out = history_aerosol, & - prog_modal_aero_out=prog_modal_aero) - -#ifdef OSLO_AERO - prog_modal_aero = .TRUE. - n_aerosol_tracers = getNumberOfAerosolTracers() - call fillAerosolTracerList(aerosolTracerList) - call fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) - do ii=1,n_aerosol_tracers - print*, "aerosolTracerList", ii, aerosolTracerList(ii), inverseAerosolTracerList(aerosolTracerList(ii)) - end do -#endif - -#ifdef OSLO_AERO - lq(:)=.FALSE. !Initialize - - !Set up tendencies for tracers (output) - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.false.) - - if(.NOT. lq(lptr))then - !add dropmixnuc tendencies - mm=mam_idx(m,l) - fieldname(mm)=trim(cnst_name(lptr))//"_mixnuc1" - fieldname_cw(mm)=trim(getCloudTracerName(lptr))//"_mixnuc1" - - long_name = trim(fieldname(mm)) // ' dropmixnuc column tendency' - call addfld(trim(fieldname(mm)), horiz_only ,'A', "kg/m2/s",long_name) - - long_name = trim(fieldname_cw(mm)) // ' dropmixnuc column tendency' - call addfld(trim(fieldname_cw(mm)), horiz_only, 'A', "kg/m2/s",long_name) - - if (history_aerosol) then - call add_default(trim(fieldname(mm)), 1, ' ') - call add_default(trim(fieldname_cw(mm)),1,' ') - endif - - !Do tendencies of this tracer - lq(lptr)=.TRUE. - endif - enddo - enddo - do m=1,ntot_amode - modeString=" " - write(modeString,"(I2)"),m - if(m .lt. 10) modeString="0"//adjustl(modeString) - varName = "NMR"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', 'm ', 'number median radius mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - varName = "NCONC"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', '#/m3 ', 'number concentration mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - varName = "VCONC"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', 'm3/m3 ','volume concentration mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - varName = "SIGMA"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', '-','Std. dev. mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - varName = "HYGRO"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A','-','Hygroscopicity '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - end do -#else - do m = 1, ntot_amode - do l = 0, nspec_amode(m) ! loop over number + chem constituents - - mm = mam_idx(m,l) - - unit = 'kg/m2/s' - if (l == 0) then ! number - unit = '#/m2/s' - end if - - if (l == 0) then ! number - call rad_cnst_get_info(0, m, num_name=tmpname, num_name_cw=tmpname_cw) - else - call rad_cnst_get_info(0, m, l, spec_name=tmpname, spec_name_cw=tmpname_cw) - end if - - fieldname(mm) = trim(tmpname) // '_mixnuc1' - fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' - - if (prog_modal_aero) then - - ! To set tendencies in the ptend object need to get the constituent indices - ! for the prognostic species - if (l == 0) then ! number - call rad_cnst_get_mode_num_idx(m, lptr) - else - call rad_cnst_get_mam_mmr_idx(m, l, lptr) - end if - mam_cnst_idx(m,l) = lptr - lq(lptr) = .true. - - ! Add tendency fields to the history only when prognostic MAM is enabled. - long_name = trim(tmpname) // ' dropmixnuc mixnuc column tendency' - call addfld(fieldname(mm), horiz_only, 'A', unit, long_name) - - long_name = trim(tmpname_cw) // ' dropmixnuc mixnuc column tendency' - call addfld(fieldname_cw(mm), horiz_only, 'A', unit, long_name) - - if (history_aerosol) then - call add_default(fieldname(mm), 1, ' ') - call add_default(fieldname_cw(mm), 1, ' ') - end if - - - - end if - - end do - end do - -#endif - - call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%') - call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%') - call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%') - call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%') - call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%') - call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%') - -#ifdef OSLO_AERO - if(history_aerosol)then - do l = 1, psat - call add_default(ccn_name(l), 1, ' ') - enddo - end if -#endif - - call addfld('WTKE', (/ 'lev' /), 'A', 'm/s', 'Standard deviation of updraft velocity') - call addfld('NDROPMIX', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number mixing') - call addfld('NDROPSRC', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number source') - call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics') - call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number') - -#ifndef OSLO_AERO - - ! set the add_default fields - if (history_amwg) then - call add_default('CCN3', 1, ' ') - endif - - if (history_aerosol .and. prog_modal_aero) then - do m = 1, ntot_amode - do l = 0, nspec_amode(m) ! loop over number + chem constituents - mm = mam_idx(m,l) - if (l == 0) then ! number - call rad_cnst_get_info(0, m, num_name=tmpname, num_name_cw=tmpname_cw) - else - call rad_cnst_get_info(0, m, l, spec_name=tmpname, spec_name_cw=tmpname_cw) - end if - fieldname(mm) = trim(tmpname) // '_mixnuc1' - fieldname_cw(mm) = trim(tmpname_cw) // '_mixnuc1' - end do - end do - endif - -#endif - -end subroutine ndrop_init - -!=============================================================================== - -subroutine dropmixnuc( & - state, ptend, dtmicro, pbuf, wsub, & ! Input - cldn, cldo, cldliqf, & - !++ MH_2015/09/07 - hasAerosol, & - CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, & - cam, f_acm, f_bcm, f_aqm, f_so4_condm, & - f_soam, & - numberConcentration, volumeConcentration, & - hygroscopicity, lnsigma, & - !-- MH_2015/09/07 - tendnd, & ! Output - !++ MH_2015/04/10 - fn_in, & - from_spcam ) - !-- MH_2015/04/10 - - ! vertical diffusion and nucleation of cloud droplets - ! assume cloud presence controlled by cloud fraction - ! doesn't distinguish between warm, cold clouds - - ! arguments - type(physics_state), target, intent(in) :: state - type(physics_ptend), intent(out) :: ptend - real(r8), intent(in) :: dtmicro ! time step for microphysics (s) - - type(physics_buffer_desc), pointer :: pbuf(:) - - ! arguments - real(r8), intent(in) :: wsub(pcols,pver) ! subgrid vertical velocity - real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction - real(r8), intent(in) :: cldo(pcols,pver) ! cloud fraction on previous time step - real(r8), intent(in) :: cldliqf(pcols,pver) ! liquid cloud fraction (liquid / (liquid + ice)) - logical, intent(in),optional :: from_spcam ! value insignificant - if variable present, is called from spcam - -!++ MH_2015/09/07 - logical, intent(in) :: hasAerosol(pcols, pver, nmodes) - real(r8), intent(in) :: CProcessModes(pcols,pver) - real(r8), intent(in) :: cam(pcols,pver,nbmodes) - real(r8), intent(in) :: f_c(pcols,pver) - real(r8), intent(in) :: f_aq(pcols,pver) - real(r8), intent(in) :: f_bc(pcols,pver) - real(r8), intent(in) :: f_so4_cond(pcols,pver) - real(r8), intent(in) :: f_soa(pcols,pver) - real(r8), intent(in) :: f_acm(pcols,pver, nbmodes) - real(r8), intent(in) :: f_bcm(pcols,pver, nbmodes) - real(r8), intent(in) :: f_aqm(pcols, pver, nbmodes) - real(r8), intent(in) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction - real(r8), intent(in) :: f_soam(pcols,pver,nbmodes) - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration - real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) ![-] hygroscopicity - real(r8), intent(in) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma -!-- MH_2015/09/07 - - ! output arguments - real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) - - !--------------------Local storage------------------------------------- - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of columns - - real(r8), pointer :: ncldwtr(:,:) ! droplet number concentration (#/kg) - real(r8), pointer :: temp(:,:) ! temperature (K) - real(r8), pointer :: omega(:,:) ! vertical velocity (Pa/s) - real(r8), pointer :: pmid(:,:) ! mid-level pressure (Pa) - real(r8), pointer :: pint(:,:) ! pressure at layer interfaces (Pa) - real(r8), pointer :: pdel(:,:) ! pressure thickess of layer (Pa) - real(r8), pointer :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) - real(r8), pointer :: zm(:,:) ! geopotential height of level (m) - - real(r8), pointer :: kvh(:,:) ! vertical diffusivity (m2/s) - - type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios - type(ptr2d_t), allocatable :: qqcw(:) - real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios - real(r8) :: qqcwtend(pver) ! tendency of cloudborne aerosol mass, number mixing ratios - - - real(r8), parameter :: zkmin = 0.01_r8, zkmax = 100._r8 - real(r8), parameter :: wmixmin = 0.1_r8 ! minimum turbulence vertical velocity (m/s) - real(r8) :: sq2pi - - integer :: i, k, l, m, mm, n - integer :: km1, kp1 - integer :: nnew, nsav, ntemp - integer :: lptr - integer :: nsubmix, nsubmix_bnd - integer, save :: count_submix(100) - integer :: phase ! phase of aerosol - - real(r8) :: arg - real(r8) :: dtinv - real(r8) :: dtmin, tinv, dtt - real(r8) :: lcldn(pcols,pver) - real(r8) :: lcldo(pcols,pver) - - real(r8) :: zs(pver) ! inverse of distance between levels (m) - real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) - real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries - real(r8) :: srcn(pver) ! droplet source rate (/s) - real(r8) :: cs(pcols,pver) ! air density (kg/m3) - real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) - real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) - real(r8) :: dz(pcols,pver) ! geometric thickness of layers (m) - - real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) - real(r8) :: wtke_cen(pcols,pver) ! turbulent vertical velocity at center of layer k (m/s) - real(r8) :: wbar, wmix, wmin, wmax - - real(r8) :: zn(pver) ! g/pdel (m2/g) for layer - real(r8) :: flxconv ! convergence of flux into lowest layer - - real(r8) :: wdiab ! diabatic vertical velocity - real(r8) :: ekd(pver) ! diffusivity for droplets (m2/s) - real(r8) :: ekk(0:pver) ! density*diffusivity for droplets (kg/m3 m2/s) - real(r8) :: ekkp(pver) ! zn*zs*density*diffusivity - real(r8) :: ekkm(pver) ! zn*zs*density*diffusivity - - real(r8) :: dum, dumc - real(r8) :: tmpa - real(r8) :: dact - real(r8) :: fluxntot ! (#/cm2/s) - real(r8) :: dtmix - real(r8) :: alogarg - real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap - - real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) - real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) - real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) - real(r8) :: cldo_tmp, cldn_tmp - real(r8) :: tau_cld_regenerate - real(r8) :: zeroaer(pver) - real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) - - - real(r8), allocatable :: nact(:,:) ! fractional aero. number activation rate (/s) - real(r8), allocatable :: mact(:,:) ! fractional aero. mass activation rate (/s) - - real(r8), allocatable :: raercol(:,:,:) ! single column of aerosol mass, number mixing ratios - real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase -#ifdef OSLO_AERO - !to avoid excessive calls to boundary layer scheme - real(r8), allocatable :: raercol_tracer(:,:,:) - real(r8), allocatable :: raercol_cw_tracer(:,:,:) - real(r8), allocatable :: mact_tracer(:,:) - real(r8), allocatable :: mfullact_tracer(:,:) -#endif - - real(r8) :: na(pcols), va(pcols), hy(pcols) - real(r8), allocatable :: naermod(:) ! (1/m3) - real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode - real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) - - real(r8) :: source(pver) - -!++ MH_2015/04/10 - real(r8), allocatable :: fn(:) ! activation fraction for aerosol number - real(r8), intent(out) :: fn_in(pcols,pver,0:nmodes) -!-- MH_2015/04/10 - real(r8), allocatable :: fm(:) ! activation fraction for aerosol mass - - real(r8), allocatable :: fluxn(:) ! number activation fraction flux (cm/s) - real(r8), allocatable :: fluxm(:) ! mass activation fraction flux (cm/s) - real(r8) :: flux_fullact(pver) ! 100% activation fraction flux (cm/s) - ! note: activation fraction fluxes are defined as - ! fluxn = [flux of activated aero. number into cloud (#/cm2/s)] - ! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] - - - real(r8), allocatable :: coltend(:,:) ! column tendency for diagnostic output - real(r8), allocatable :: coltend_cw(:,:) ! column tendency - real(r8) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat - - !for gas species turbulent mixing - real(r8), pointer :: rgas(:, :, :) - real(r8), allocatable :: rgascol(:, :, :) - real(r8), allocatable :: coltendgas(:) - real(r8) :: zerogas(pver) - character*200 fieldnamegas - - logical :: called_from_spcam - !------------------------------------------------------------------------------- -#ifdef OSLO_AERO - real(r8) :: numberMedianRadius(pcols,pver,nmodes) - real(r8) :: sigma(pcols,pver,nmodes) ![-] sigma - real(r8) :: constituentFraction - !++ MH_2015/04/10 - real(r8) :: volumeCore(pcols,pver,nmodes) - real(r8) :: volumeCoat(pcols,pver,nmodes) - !-- MH_2015/04/10 - integer :: tracerIndex - integer :: cloudTracerIndex - integer :: kcomp - integer :: speciesMap(nmodes) - !++ MH_2015/04/10 -! real(r8) :: fn_tmp(pcols,pver,nmodes) - real(r8), allocatable :: fn_tmp(:), fm_tmp(:) - !-- MH_2015/04/10 - real(r8), allocatable :: fluxn_tmp(:), fluxm_tmp(:) - real(r8) :: componentFraction - real(r8) :: componentFractionOK(pver,nmodes,pcnst) - real(r8) :: sumFraction - logical :: alert - real(r8), dimension(pver, pcnst) :: massBalance - real(r8), dimension(pver, pcnst) :: newMass - real(r8), dimension(pver,pcnst) :: newCloud, oldCloud, newAerosol, oldAerosol, deltaCloud - integer :: kCrit, lptr2 - logical :: stopMe - integer :: iDebug=1, lDebug=15 - real(r8) :: mixRatioToMass - real(r8),dimension(pcnst) :: debugSumFraction - real(r8), allocatable :: lnsigman(:) - character(len=2) :: modeString - character(len=20) :: varname -#endif - integer :: numberOfModes -!------------------------------------------------------------------------------- -#undef EXTRATESTS -#undef MASS_BALANCE_CHECK - - sq2pi = sqrt(2._r8*pi) - - lchnk = state%lchnk - ncol = state%ncol - - ncldwtr => state%q(:,:,numliq_idx) - temp => state%t - omega => state%omega - pmid => state%pmid - pint => state%pint - pdel => state%pdel - rpdel => state%rpdel - zm => state%zm - - call pbuf_get_field(pbuf, kvh_idx, kvh) - - ! Create the liquid weighted cloud fractions that were passsed in - ! before. This doesn't seem like the best variable, since the cloud could - ! have liquid condensate, but the part of it that is changing could be the - ! ice portion; however, this is what was done before. - lcldo(:ncol,:) = cldo(:ncol,:) * cldliqf(:ncol,:) - lcldn(:ncol,:) = cldn(:ncol,:) * cldliqf(:ncol,:) - - - arg = 1.0_r8 - if (abs(0.8427_r8 - erf(arg))/0.8427_r8 > 0.001_r8) then - write(iulog,*) 'erf(1.0) = ',ERF(arg) - call endrun('dropmixnuc: Error function error') - endif - arg = 0.0_r8 - if (erf(arg) /= 0.0_r8) then - write(iulog,*) 'erf(0.0) = ',erf(arg) - write(iulog,*) 'dropmixnuc: Error function error' - call endrun('dropmixnuc: Error function error') - endif - - dtinv = 1._r8/dtmicro - - allocate( & - nact(pver,ntot_amode), & - mact(pver,ntot_amode), & - raer(ncnst_tot), & - qqcw(ncnst_tot), & - raercol(pver,ncnst_tot,2), & - raercol_cw(pver,ncnst_tot,2), & - coltend(pcols,ncnst_tot), & - coltend_cw(pcols,ncnst_tot), & - naermod(ntot_amode), & - hygro(ntot_amode), & -#ifdef OSLO_AERO - lnsigman(ntot_amode), & !variable std. deviation (CAM-Oslo) - raercol_tracer(pver,n_aerosol_tracers,2), & - raercol_cw_tracer(pver,n_aerosol_tracers,2), & - mact_tracer(pver,n_aerosol_tracers), & - mfullact_tracer(pver,n_aerosol_tracers), & -#endif - vaerosol(ntot_amode), & - fn(ntot_amode), & - fm(ntot_amode), & - fluxn(ntot_amode), & - fluxm(ntot_amode) ) - - ! Init pointers to mode number and specie mass mixing ratios in - ! intersitial and cloud borne phases. -#ifdef OSLO_AERO - !Need a list of all aerosol species ==> store in raer (mm) - ! or qqcw for cloud-borne aerosols (?) - do m=1,nmodes !All aerosol modes - - !NOTE: SEVERAL POINTERS POINT TO SAME FIELD, E.G. CONDENSATE WHICH IS IN SEVERAL MODES - do l = 1, nspec_amode(m) - tracerIndex = getTracerIndex(m,l,.false.) !Index in q - cloudTracerIndex = getCloudTracerIndex(m,l) !Index in phys-buffer - mm = mam_idx(m,l) !Index in raer/qqcw - raer(mm)%fld => state%q(:,:,tracerIndex) !NOTE: These are total fields (for example condensate) - call pbuf_get_field(pbuf, CloudTracerIndex, qqcw(mm)%fld) !NOTE: These are total fields (for example condensate) -#ifdef EXTRATESTS -! if(tracerIndex .eq. ldebug)then -! do k=1,pver -! print*,"pointer check",k,m,l,mm,tracerIndex, raer(mm)%fld(idebug,k), state%q(idebug,k,tracerIndex) -! end do -! endf -#endif - enddo - enddo - allocate( & - fn_tmp(ntot_amode), & - fm_tmp(ntot_amode), & - fluxn_tmp(ntot_amode), & - fluxm_tmp(ntot_amode) ) -#else - do m = 1, ntot_amode - mm = mam_idx(m, 0) - call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, raer(mm)%fld) - call rad_cnst_get_mode_num(0, m, 'c', state, pbuf, qqcw(mm)%fld) ! cloud-borne aerosol - do l = 1, nspec_amode(m) - mm = mam_idx(m, l) - call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, raer(mm)%fld) - call rad_cnst_get_aer_mmr(0, m, l, 'c', state, pbuf, qqcw(mm)%fld) ! cloud-borne aerosol - end do - end do -#endif - - called_from_spcam = (present(from_spcam)) - - if (called_from_spcam) then - rgas => state%q - allocate(rgascol(pver, pcnst, 2)) - allocate(coltendgas(pcols)) - endif - wtke = 0._r8 - - if (prog_modal_aero) then - ! aerosol tendencies - call physics_ptend_init(ptend, state%psetcols, 'ndrop', lq=lq) - else - ! no aerosol tendencies - call physics_ptend_init(ptend, state%psetcols, 'ndrop') - end if - -#ifdef OSLO_AERO - !Improve this later by using only cloud points ? - do k = top_lev, pver - do i=1,ncol - cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) - end do - end do - - !Output this - call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) - do n=1,nmodes - sigma(:ncol,:,n) = DEXP(lnSigma(:ncol,:,n)) - modeString=" " - write(modeString,"(I2)"),n - if(n .lt. 10) modeString="0"//adjustl(modeString) - varName = "NMR"//trim(modeString) - call outfld(varName, numberMedianRadius(:,:,n), pcols, lchnk) - varName = "NCONC"//trim(modeString) - call outfld(varName, numberConcentration(:,:,n),pcols, lchnk) - varName = "VCONC"//trim(modeString) - call outfld(varName, volumeConcentration(:,:,n), pcols,lchnk) - varName = "SIGMA"//trim(modeString) - call outfld(varName, sigma(:,:,n), pcols,lchnk) - varName = "HYGRO"//trim(modeString) - call outfld(varName, hygroscopicity(:,:,n), pcols,lchnk) - end do - - alert = .FALSE. - do k=top_lev,pver - mm = k - top_lev + 1 - do m=1,nmodes - if(.NOT. alert .and. & -!tht is zero an allowed value for numberConcentration?? - ANY(numberConcentration(:ncol,k,m) .lt. 0.0_r8 ))then - alert = .TRUE. - lptr = k - print*,"STRANGE numberconc", m, minval(numberConcentration(:,:,:))*1.e-6_r8, "#/cm3", k, mm - endif - enddo - enddo - - - if(alert)then - print*,"strange stuff here " - stop - - !do m=1,nmodes - ! print*,"numberconc (after alert)", m, modedefs(1)%nnatk(m)*1.e-6_r8, "#/cm3" & - ! ,modedefs(1)%C(m)*1.0e9_r8, "ug/m3" - - ! if(modedefs(1)%nnatk(m) > 1.e-30_r8)then - ! print*, "final weight per particle ",m, modedefs(1)%C(m)/modedefs(1)%nnatk(m) - ! endif - !end do - !stop - endif - -#endif - - ! overall_main_i_loop - do i = 1, ncol - -#ifdef OSLO_AERO - coltend(i,:)=0.0_r8 - coltend_cw(i,:) = 0.0_r8 -#endif - - do k = top_lev, pver-1 - zs(k) = 1._r8/(zm(i,k) - zm(i,k+1)) - end do - zs(pver) = zs(pver-1) - - ! load number nucleated into qcld on cloud boundaries - - do k = top_lev, pver - - qcld(k) = ncldwtr(i,k) - qncld(k) = 0._r8 - srcn(k) = 0._r8 - cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) - dz(i,k) = 1._r8/(cs(i,k)*gravit*rpdel(i,k)) ! layer thickness in m - - do m = 1, ntot_amode - nact(k,m) = 0._r8 - mact(k,m) = 0._r8 - end do - - zn(k) = gravit*rpdel(i,k) - - if (k < pver) then - ekd(k) = kvh(i,k+1) - ekd(k) = max(ekd(k), zkmin) - ekd(k) = min(ekd(k), zkmax) - csbot(k) = 2.0_r8*pint(i,k+1)/(rair*(temp(i,k) + temp(i,k+1))) - csbot_cscen(k) = csbot(k)/cs(i,k) - else - ekd(k) = 0._r8 - csbot(k) = cs(i,k) - csbot_cscen(k) = 1.0_r8 - end if - - ! rce-comment - define wtke at layer centers for new-cloud activation - ! and at layer boundaries for old-cloud activation - !++ag - wtke_cen(i,k) = wsub(i,k) - wtke(i,k) = wsub(i,k) - !--ag - wtke_cen(i,k) = max(wtke_cen(i,k), wmixmin) - wtke(i,k) = max(wtke(i,k), wmixmin) - - nsource(i,k) = 0._r8 - - end do ! k - - nsav = 1 - nnew = 2 -#ifdef OSLO_AERO - - !get constituent fraction - componentFractionOK(:,:,:) = 0.0_r8 - do k=top_lev, pver - do m = 1,ntot_amode - if(m .le. nbmodes)then - do l = 1, nspec_amode(m) - !calculate fraction of component "l" in mode "m" based on concentrations in clear air - componentFractionOK(k,m,getTracerIndex(m,l,.false.)) & - = getConstituentFraction(CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) & - ,Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), f_so4_condm(i,k,m) , f_soam(i,k,m), getTracerIndex(m,l,.false.) ) - end do - else - do l = 1, nspec_amode(m) - componentFractionOK(k,m,getTracerIndex(m,l,.false.)) = 1.0_r8 - end do - endif - end do - - !Loop over all tracers ==> check that sums to one - !for all tracers which exist in the oslo-modes - do l=1,pcnst - sumFraction = 0.0_r8 - do m=1,ntot_amode - sumFraction = sumFraction + componentFractionOK(k,m,l) - end do - if(sumFraction .gt. 1.e-2_r8)then !Just scale what comes out if componentFraction is larger than 1% - do m=1,ntot_amode - componentFractionOK(k,m,l) = & - componentFractionOK(k,m,l)/sumFraction - end do - else !negative or zero fraction for this species - !distribute equal fraction to all receiver modes - sumFraction = 0.0_r8 - do m=1,ntot_amode - do lptr=1,getNumberOfTracersInMode(m) - if(getTracerIndex(m,lptr,.FALSE.) .eq. l ) then - sumFraction = sumFraction + 1.0_r8 - endif - end do ! tracers in mode - end do ! mode - do m=1,ntot_amode - componentFractionOK(k,m,l)=1.0_r8/max(1.e-30_r8, sumFraction) - end do !modes - endif - end do !tracers - end do !levels - !debug sum fraction for "i" done - - - - debugSumFraction(:) = 0.0_r8 !sum of component lDebug in level k - do m = 1, nmodes ! Number of modes - !Get number concentration of this mode - mm =mam_idx(m,0) - do k= top_lev,pver - raercol(k,mm,nsav) = numberConcentration(i,k,m)/cs(i,k) !#/kg air - !In oslo model, number concentrations are diagnostics, so - !Approximate number concentration in each mode by total - !cloud number concentration scaled by how much is available of - !each mode - raercol_cw(k,mm,nsav) = ncldwtr(i,k)*numberConcentration(i,k,m)& - /max(1.e-30_r8, sum(numberConcentration(i,k,1:nmodes))) - enddo - - !These are the mass mixing ratios - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) !index of tracer (all unique) - raercol(:,mm,nsav) = 0.0_r8 - raercol_cw(:,mm,nsav) = 0.0_r8 - !Several of the fields (raer(mm)%fld point to the same - !field in q. To avoid double counting, we take into - !account the component fraction in the mode - do k=top_lev,pver - if(m .gt. nbmodes) then - componentFraction = 1.0_r8 - else - componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) - endif -#ifdef EXTRATESTS - if(i .eq. iDebug .and. getTracerIndex(m,l,.false.) .eq. lDebug)then - !print*,"componentFraction", i,cnst_name(oslo_cnst_idx(m,l)),componentFraction - print*,"assigning cloud/aerosol", k,m,l,qqcw(mm)%fld(i,k), raer(mm)%fld(i,k) & - ,componentFraction - debugSumFraction(k) = debugSumFraction(k) + componentFraction - endif - if(componentFraction > 1.0_r8)then - print*, "wrong component fraction", componentFraction - stop - call endrun("wrong component fraction") - endif -#endif - !Assign to the components used here i.e. distribute condensate/coagulate to modes - raercol_cw(k,mm,nsav) = qqcw(mm)%fld(i,k)*componentFraction - raercol(k,mm,nsav) = raer(mm)%fld(i,k)*componentFraction - enddo ! k (levels) - end do ! l (species) - end do ! m (modes) -#ifdef EXTRATESTS - do k=top_lev,pver - if(i .eq. iDebug .and. (abs(debugSumFraction(k)-1.0_r8).gt.1.e-2_r8) .and. debugSumFraction(k).gt.1.e-6_r8)then - print*, "debugSumFraction", cnst_name(getTracerIndex(m,l,.false.)),i, k, debugSumFraction(k), abs(debugSumFraction(k)-1.0_r8) - componentFraction=0.0_r8 - do m=1,nbmodes - componentFraction = componentFraction + cam(i,k,m) - print*, "MODECONC", m, cam(i,k,m), numberConcentration(i,k,m) - end do - print*, "CS, sumCAM", CProcessModes(i,k), sum(cam(i,k,1:nbmodes)), componentFraction - print*, "q (cond)", state%q(i,k,lDebug)*cs(i,k)!mass in q - print*, "q (aq) " ,state%q(i,k,l_so4_a2)*cs(i,k) - print*, "bulk fractions", f_so4_cond(i,k),f_c(i,k), f_bc(i,k), f_aq(i,k) - !print*, "other levels", debugSumFraction(:) - do m=1,nmodes - do l=1,nspec_amode(m) - if(getTracerIndex(m,l,.false.) == ldebug)then - if(m .gt. nbmodes)then - componentFraction = 1.0_r8 - else - componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) - endif - print*, "nmode, l,k, ", m,l,k , lDebug, componentFraction, cam(i,k,m), f_aqm(i,k,m), f_acm(i,k,m), f_so4_condm(i,k,m) - print*, "fraction2 ", cam(i,k,m), cam(i,k,m)/CProcessModes(i,k)*100.0_r8, " %" - endif - enddo - enddo - call endrun("wrong debugsumfraction") - endif !idebug/ldebug - enddo -#endif - !END OSLO-STUFF, BELOW IS MAM 3 -#else - do m = 1, ntot_amode - mm = mam_idx(m,0) - raercol_cw(:,mm,nsav) = 0.0_r8 - raercol(:,mm,nsav) = 0.0_r8 - raercol_cw(top_lev:pver,mm,nsav) = qqcw(mm)%fld(i,top_lev:pver) - raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - raercol_cw(top_lev:pver,mm,nsav) = qqcw(mm)%fld(i,top_lev:pver) - raercol(top_lev:pver,mm,nsav) = raer(mm)%fld(i,top_lev:pver) - end do - end do -#endif - - - if (called_from_spcam) then - ! - ! In the MMF model, turbulent mixing for tracer species are turned off. - ! So the turbulent for gas species mixing are added here. - ! (Previously, it had the turbulent mixing for aerosol species) - ! - do m=1, pcnst - if (cnst_species_class(m) == cnst_spec_class_gas) rgascol(:,m,nsav) = rgas(i,:,m) - end do - - endif - - ! droplet nucleation/aerosol activation - - ! tau_cld_regenerate = time scale for regeneration of cloudy air - ! by (horizontal) exchange with clear air - tau_cld_regenerate = 3600.0_r8 * 3.0_r8 - - if (called_from_spcam) then - ! when this is called in the MMF part, no cloud regeneration and decay. - ! set the time scale be very long so that no cloud regeneration. - tau_cld_regenerate = 3600.0_r8 * 24.0_r8 * 365.0_r8 - endif - - - ! k-loop for growing/shrinking cloud calcs ............................. - ! grow_shrink_main_k_loop: & - do k = top_lev, pver - - ! This code was designed for liquid clouds, but the cloudbourne - ! aerosol can be either from liquid or ice clouds. For the ice clouds, - ! we do not do regeneration, but as cloud fraction decreases the - ! aerosols should be returned interstitial. The lack of a liquid cloud - ! should not mean that all of the aerosol is realease. Therefor a - ! section has been added for shrinking ice clouds and checks were added - ! to protect ice cloudbourne aerosols from being released when no - ! liquid cloud is present. - - ! shrinking ice cloud ...................................................... - cldo_tmp = cldo(i,k) * (1._r8 - cldliqf(i,k)) - cldn_tmp = cldn(i,k) * (1._r8 - cldliqf(i,k)) - - if (cldn_tmp < cldo_tmp) then - - ! convert activated aerosol to interstitial in decaying cloud - - dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * (1._r8 - cldliqf(i,k)) - do m = 1, ntot_amode - mm = mam_idx(m,0) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - end do - end do - end if - - ! shrinking liquid cloud ...................................................... - ! treat the reduction of cloud fraction from when cldn(i,k) < cldo(i,k) - ! and also dissipate the portion of the cloud that will be regenerated - cldo_tmp = lcldo(i,k) - cldn_tmp = lcldn(i,k) * exp( -dtmicro/tau_cld_regenerate ) - ! alternate formulation - ! cldn_tmp = cldn(i,k) * max( 0.0_r8, (1.0_r8-dtmicro/tau_cld_regenerate) ) - - ! fraction is also provided. - if (cldn_tmp < cldo_tmp) then - ! droplet loss in decaying cloud - !++ sungsup - nsource(i,k) = nsource(i,k) + qcld(k)*(cldn_tmp - cldo_tmp)/cldo_tmp*cldliqf(i,k)*dtinv - qcld(k) = qcld(k)*(1._r8 + (cldn_tmp - cldo_tmp)/cldo_tmp) - !-- sungsup - - ! convert activated aerosol to interstitial in decaying cloud - - dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * cldliqf(i,k) - do m = 1, ntot_amode - mm = mam_idx(m,0) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact -#ifdef EXTRATESTS - if(i.eq. iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then - print*,"decaying cloud", k, dact, cldn_tmp, cldo_tmp - endif -#endif - end do - end do - end if - - ! growing liquid cloud ...................................................... - ! treat the increase of cloud fraction from when cldn(i,k) > cldo(i,k) - ! and also regenerate part of the cloud - cldo_tmp = cldn_tmp - cldn_tmp = lcldn(i,k) - - if (cldn_tmp-cldo_tmp > 0.01_r8) then - - ! rce-comment - use wtke at layer centers for new-cloud activation - wbar = wtke_cen(i,k) - wmix = 0._r8 - wmin = 0._r8 - wmax = 10._r8 - wdiab = 0._r8 - - ! load aerosol properties, assuming external mixtures - -#ifdef OSLO_AERO - naermod(:) = 0.0_r8 - vaerosol(:) = 0.0_r8 - hygro(:) = 0.0_r8 - lnsigman(:) = log(2.0_r8) - - m=0 - do kcomp = 1,nmodes - if(hasAerosol(i,k,kcomp) .eqv. .TRUE.)then - m = m + 1 - naermod(m) = numberConcentration(i,k,kcomp) - vaerosol(m) = volumeConcentration(i,k,kcomp) - hygro(m) = hygroscopicity(i,k,kcomp) - lnsigman(m) = lnsigma(i,k,kcomp) - speciesMap(m) = kcomp - end if - end do - numberOfModes = m -#else - numberOfModes = ntot_amode - phase = 1 ! interstitial - do m = 1, ntot_amode - call loadaer( & - state, pbuf, i, i, k, & - m, cs, phase, na, va, & - hy) - naermod(m) = na(i) - vaerosol(m) = va(i) - hygro(m) = hy(i) - end do -#endif - !++ MH_2015/04/10 - !Call the activation procedure - if(numberOfModes .gt. 0)then - if (use_hetfrz_classnuc) then - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes, & - vaerosol, hygro, fn_in(i,k,1:nmodes), fm, fluxn, & - fluxm,flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - else - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes, & - vaerosol, hygro, fn, fm, fluxn, & - fluxm,flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - end if - !-- MH_2015/04/10 - endif - - dumc = (cldn_tmp - cldo_tmp) -#ifdef OSLO_AERO - if (use_hetfrz_classnuc) then - fn_tmp(:) = fn_in(i,k,1:nmodes) - else - fn_tmp(:) = fn(:) - end if - fm_tmp(:) = fm(:) - fluxn_tmp(:) = fluxn(:) - fluxm_tmp(:) = fluxm(:) - fn(:) = 0.0_r8 - fn_in(i,k,:) = 0.0_r8 - fm(:) = 0.0_r8 - fluxn(:)=0.0_r8 - fluxm(:)= 0.0_r8 - do m = 1, numberOfModes !Number of coexisting modes to be used for activation - kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) - if (use_hetfrz_classnuc) then - fn_in(i,k,kcomp) = fn_tmp(m) - else - fn(kcomp) = fn_tmp(m) - end if - fm(kcomp) = fm_tmp(m) - fluxn(kcomp) = fluxn_tmp(m) - fluxm(kcomp) = fluxm_tmp(m) - enddo -#endif - do m = 1, ntot_amode - mm = mam_idx(m,0) -#ifdef OSLO_AERO - if (use_hetfrz_classnuc) then - dact = dumc*fn_in(i,k,m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} - else - dact = dumc*fn(m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} - end if -#else - if (use_hetfrz_classnuc) then - dact = dumc*fn_in(i,k,m)*raer(mm)%fld(i,k) ! interstitial only - else - dact = dumc*fn(m)*raer(mm)%fld(i,k) ! interstitial only - end if -#endif - qcld(k) = qcld(k) + dact - nsource(i,k) = nsource(i,k) + dact*dtinv - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - dum = dumc*fm(m) - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) -#ifdef OSLO_AERO - if(m .gt. nbmodes)then - constituentFraction = 1.0_r8 - else - constituentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.) ) - endif - - dact = dum*raer(mm)%fld(i,k)*constituentFraction -#else - dact = dum*raer(mm)%fld(i,k) ! interstitial only -#endif - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact -#ifdef EXTRATESTS - if(i.eq.iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then - print*,"growing cloud (new/old)", k, raercol_cw(k,mm,nsav), raercol_cw(k,mm,nsav)-dact & - ,raercol(k,mm,nsav),raercol(k,mm,nsav)+dact,dact - endif -#endif - enddo - enddo - endif ! cldn_tmp-cldo_tmp > 0.01_r8 - - enddo ! grow_shrink_main_k_loop - ! end of k-loop for growing/shrinking cloud calcs ...................... - - ! ...................................................................... - ! start of k-loop for calc of old cloud activation tendencies .......... - ! - ! rce-comment - ! changed this part of code to use current cloud fraction (cldn) exclusively - ! consider case of cldo(:)=0, cldn(k)=1, cldn(k+1)=0 - ! previous code (which used cldo below here) would have no cloud-base activation - ! into layer k. however, activated particles in k mix out to k+1, - ! so they are incorrectly depleted with no replacement - - ! old_cloud_main_k_loop - do k = top_lev, pver - kp1 = min0(k+1, pver) - taumix_internal_pver_inv = 0.0_r8 - - if (lcldn(i,k) > 0.01_r8) then - - wdiab = 0._r8 - wmix = 0._r8 ! single updraft - wbar = wtke(i,k) ! single updraft - if (k == pver) wbar = wtke_cen(i,k) ! single updraft - wmax = 10._r8 - wmin = 0._r8 - - if (lcldn(i,k) - lcldn(i,kp1) > 0.01_r8 .or. k == pver) then - - ! cloud base - - ! ekd(k) = wtke(i,k)*dz(i,k)/sq2pi - ! rce-comments - ! first, should probably have 1/zs(k) here rather than dz(i,k) because - ! the turbulent flux is proportional to ekd(k)*zs(k), - ! while the dz(i,k) is used to get flux divergences - ! and mixing ratio tendency/change - ! second and more importantly, using a single updraft velocity here - ! means having monodisperse turbulent updraft and downdrafts. - ! The sq2pi factor assumes a normal draft spectrum. - ! The fluxn/fluxm from activate must be consistent with the - ! fluxes calculated in explmix. - ekd(k) = wbar/zs(k) - - alogarg = max(1.e-20_r8, 1._r8/lcldn(i,k) - 1._r8) - wmin = wbar + wmix*0.25_r8*sq2pi*log(alogarg) - phase = 1 ! interstitial -#ifdef OSLO_AERO - naermod(:) = 0.0_r8 - vaerosol(:) = 0.0_r8 - hygro(:) = 0.0_r8 - lnsigman(:) = log(2.0_r8) - - m=0 - do kcomp = 1,nmodes - if(hasAerosol(i,kp1,kcomp) .eqv. .TRUE.)then - m = m + 1 - naermod(m) = numberConcentration(i,kp1,kcomp) - vaerosol(m) = volumeConcentration(i,kp1,kcomp) - hygro(m) = hygroscopicity(i,kp1,kcomp) - lnsigman(m) = lnsigma(i,kp1,kcomp) - speciesMap(m) = kcomp - end if - end do - numberOfModes = m -#else - numberOfModes = ntot_amode - - do m = 1, ntot_amode - ! rce-comment - use kp1 here as old-cloud activation involves - ! aerosol from layer below - call loadaer( & - state, pbuf, i, i, kp1, & - m, cs, phase, na, va, & - hy) - naermod(m) = na(i) - vaerosol(m) = va(i) - hygro(m) = hy(i) - end do -#endif - !++ MH_2015/04/10 - if(numberOfModes .gt. 0)then - if (use_hetfrz_classnuc) then - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn_in(i,k,:), fm, fluxn, & - fluxm, flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - else - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn, fm, fluxn, & - fluxm, flux_fullact(k) & -#ifdef OSLO_AERO - ,lnsigman & -#endif - ) - end if - !-- MH_2015/04/10 - endif - - !Difference in cloud fraction this layer and above! - !we are here because there are more clouds above, and some - !aerosols go into that layer! ==> calculate additional cloud fraction - if (k < pver) then - dumc = lcldn(i,k) - lcldn(i,kp1) - else - dumc = lcldn(i,k) - endif - -#ifdef OSLO_AERO - if (use_hetfrz_classnuc) then - fn_tmp(:) = fn_in(i,k,1:nmodes) - else - fn_tmp(:) = fn(:) - end if - fm_tmp(:) = fm(:) - fluxn_tmp(:) = fluxn(:) - fluxm_tmp(:) = fluxm(:) - fn(:) = 0.0_r8 - fn_in(i,k,:) = 0.0_r8 - fm(:) = 0.0_r8 - fluxn(:)=0.0_r8 - fluxm(:)= 0.0_r8 - do m = 1, numberOfModes !Number of coexisting modes to be used for activation - kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) - if (use_hetfrz_classnuc) then - fn_in(i,k,kcomp) = fn_tmp(m) - else - fn(kcomp) = fn_tmp(m) - end if - fm(kcomp) = fm_tmp(m) - fluxn(kcomp) = fluxn_tmp(m) - fluxm(kcomp) = fluxm_tmp(m) - enddo -#endif - - fluxntot = 0.0_r8 - - ! rce-comment 1 - ! flux of activated mass into layer k (in kg/m2/s) - ! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) - ! source of activated mass (in kg/kg/s) = flux divergence - ! = actmassflux/(cs(i,k)*dz(i,k)) - ! so need factor of csbot_cscen = csbot(k)/cs(i,k) - ! dum=1./(dz(i,k)) - dum=csbot_cscen(k)/(dz(i,k)) - - ! rce-comment 2 - ! code for k=pver was changed to use the following conceptual model - ! in k=pver, there can be no cloud-base activation unless one considers - ! a scenario such as the layer being partially cloudy, - ! with clear air at bottom and cloudy air at top - ! assume this scenario, and that the clear/cloudy portions mix with - ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) - ! in the absence of other sources/sinks, qact (the activated particle - ! mixratio) attains a steady state value given by - ! qact_ss = fcloud*fact*qtot - ! where fcloud is cloud fraction, fact is activation fraction, - ! qtot=qact+qint, qint is interstitial particle mixratio - ! the activation rate (from mixing within the layer) can now be - ! written as - ! d(qact)/dt = (qact_ss - qact)/taumix_internal - ! = qtot*(fcloud*fact*wtke/dz) - qact*(wtke/dz) - ! note that (fcloud*fact*wtke/dz) is equal to the nact/mact - ! also, d(qact)/dt can be negative. in the code below - ! it is forced to be >= 0 - ! - ! steve -- - ! you will likely want to change this. i did not really understand - ! what was previously being done in k=pver - ! in the cam3_5_3 code, wtke(i,pver) appears to be equal to the - ! droplet deposition velocity which is quite small - ! in the cam3_5_37 version, wtke is done differently and is much - ! larger in k=pver, so the activation is stronger there - ! - if (k == pver) then - taumix_internal_pver_inv = flux_fullact(k)/dz(i,k) - end if - - do m = 1, ntot_amode - mm = mam_idx(m,0) - fluxn(m) = fluxn(m)*dumc - fluxm(m) = fluxm(m)*dumc - nact(k,m) = nact(k,m) + fluxn(m)*dum - mact(k,m) = mact(k,m) + fluxm(m)*dum - if (k < pver) then - ! note that kp1 is used here - fluxntot = fluxntot & - + fluxn(m)*raercol(kp1,mm,nsav)*cs(i,k) - else - tmpa = raercol(kp1,mm,nsav)*fluxn(m) & - + raercol_cw(kp1,mm,nsav)*(fluxn(m) & - - taumix_internal_pver_inv*dz(i,k)) - fluxntot = fluxntot + max(0.0_r8, tmpa)*cs(i,k) - end if - end do - srcn(k) = srcn(k) + fluxntot/(cs(i,k)*dz(i,k)) - nsource(i,k) = nsource(i,k) + fluxntot/(cs(i,k)*dz(i,k)) -#ifdef EXTRATESTS - if(fluxntot/(cs(i,k)*dz(i,k)) > 0.0_r8 )then - print*,"activated/available(from below)",i,k,m,fluxntot/(cs(i,k)*dz(i,k)) - endif -#endif - endif ! (cldn(i,k) - cldn(i,kp1) > 0.01 .or. k == pver) - - else ! i.e: cldn(i,k) < 0.01_r8 - - ! no liquid cloud - - nsource(i,k) = nsource(i,k) - qcld(k)*dtinv - qcld(k) = 0.0_r8 - - if (cldn(i,k) < 0.01_r8) then - ! no ice cloud either - - ! convert activated aerosol to interstitial in decaying cloud - - do m = 1, ntot_amode - mm = mam_idx(m,0) - raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol - raercol_cw(k,mm,nsav) = 0._r8 - - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) -#ifdef EXTRATESTS - if(i.eq.iDebug .and. getTracerIndex(m,l,.false.).eq.lDebug)then - print*,"no cloud", k, raercol(k,mm,nsav) , raercol_cw(k,mm,nsav) - endif -#endif - raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol - raercol_cw(k,mm,nsav) = 0._r8 - end do - end do - end if - end if - - end do ! old_cloud_main_k_loop - - ! switch nsav, nnew so that nnew is the updated aerosol - ntemp = nsav - nsav = nnew - nnew = ntemp - - ! load new droplets in layers above, below clouds - - dtmin = dtmicro - ekk(top_lev-1) = 0.0_r8 - ekk(pver) = 0.0_r8 - do k = top_lev, pver-1 - ! rce-comment -- ekd(k) is eddy-diffusivity at k/k+1 interface - ! want ekk(k) = ekd(k) * (density at k/k+1 interface) - ! so use pint(i,k+1) as pint is 1:pverp - ! ekk(k)=ekd(k)*2.*pint(i,k)/(rair*(temp(i,k)+temp(i,k+1))) - ! ekk(k)=ekd(k)*2.*pint(i,k+1)/(rair*(temp(i,k)+temp(i,k+1))) - ekk(k) = ekd(k)*csbot(k) - end do - - do k = top_lev, pver - km1 = max0(k-1, top_lev) - ekkp(k) = zn(k)*ekk(k)*zs(k) - ekkm(k) = zn(k)*ekk(k-1)*zs(km1) - tinv = ekkp(k) + ekkm(k) - - ! rce-comment -- tinv is the sum of all first-order-loss-rates - ! for the layer. for most layers, the activation loss rate - ! (for interstitial particles) is accounted for by the loss by - ! turb-transfer to the layer above. - ! k=pver is special, and the loss rate for activation within - ! the layer must be added to tinv. if not, the time step - ! can be too big, and explmix can produce negative values. - ! the negative values are reset to zero, resulting in an - ! artificial source. - if (k == pver) tinv = tinv + taumix_internal_pver_inv - - if (tinv .gt. 1.e-6_r8) then - dtt = 1._r8/tinv - dtmin = min(dtmin, dtt) - end if - end do - - dtmix = 0.9_r8*dtmin - nsubmix = dtmicro/dtmix + 1 - if (nsubmix > 100) then - nsubmix_bnd = 100 - else - nsubmix_bnd = nsubmix - end if - count_submix(nsubmix_bnd) = count_submix(nsubmix_bnd) + 1 - dtmix = dtmicro/nsubmix - - do k = top_lev, pver - kp1 = min(k+1, pver) - km1 = max(k-1, top_lev) - ! maximum overlap assumption - if (cldn(i,kp1) > 1.e-10_r8) then - overlapp(k) = min(cldn(i,k)/cldn(i,kp1), 1._r8) - else - overlapp(k) = 1._r8 - end if - if (cldn(i,km1) > 1.e-10_r8) then - overlapm(k) = min(cldn(i,k)/cldn(i,km1), 1._r8) - else - overlapm(k) = 1._r8 - end if - end do - - - ! rce-comment - ! the activation source(k) = mact(k,m)*raercol(kp1,lmass) - ! should not exceed the rate of transfer of unactivated particles - ! from kp1 to k which = ekkp(k)*raercol(kp1,lmass) - ! however it might if things are not "just right" in subr activate - ! the following is a safety measure to avoid negatives in explmix - do k = top_lev, pver-1 - do m = 1, ntot_amode - nact(k,m) = min( nact(k,m), ekkp(k) ) - mact(k,m) = min( mact(k,m), ekkp(k) ) - end do - end do - -!Don't need the mixing per mode in OSLO_AERO ==> only per tracer -!Note that nsav/nnew is switched above, so operate on nnew here -!nnew is the updated aerosol -#ifdef OSLO_AERO - raercol_tracer(:,:,:) = 0.0_r8 - raercol_cw_tracer(:,:,:) = 0.0_r8 - mact_tracer(:,:) = 0.0_r8 - mfullact_tracer(:,:) = 0.0_r8 - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.FALSE.) !which tracer are we talking about - lptr2 = inverseAerosolTracerList(lptr) !which index is this in the list of aerosol-tracers - mm = mam_idx(m,l) - raercol_tracer(:,lptr2,nnew) = raercol_tracer(:,lptr2,nnew) & - + raercol(:,mm,nnew) - - raercol_cw_tracer(:,lptr2,nnew) = raercol_cw_tracer(:,lptr2,nnew)& - + raercol_cw(:,mm,nnew) - - mact_tracer(:,lptr2) = mact_tracer(:,lptr2) + mact(:,m)*raercol(:,mm,nnew) - mfullact_tracer(:,lptr2) = mfullact_tracer(:,lptr2) + raercol(:,mm,nnew) - -#ifdef EXTRATESTS - if(lptr.eq.lDebug .and. i.eq.iDebug)then - do k=pver,top_lev,-1 - print*, "assigning to tracer space",lptr, raercol(k,mm,nnew) & - , raercol_tracer(k,lptr2,nnew) & - , raercol_cw(k,mm,nnew) & - , raercol_cw_tracer(k,lptr2,nnew) - end do - end if -#endif - end do !l - end do !m - - do lptr2=1,n_aerosol_tracers - mact_tracer(:,lptr2) = mact_tracer(:,lptr2) & - /(mfullact_tracer(:,lptr2) + smallNumber) - end do -#endif OSLO_AERO - - ! old_cloud_nsubmix_loop - do n = 1, nsubmix - qncld(:) = qcld(:) - ! switch nsav, nnew so that nsav is the updated aerosol - ntemp = nsav - nsav = nnew - nnew = ntemp - srcn(:) = 0.0_r8 - - !First mix cloud droplet number concentration - do m = 1, ntot_amode - mm = mam_idx(m,0) - - ! update droplet source - ! rce-comment- activation source in layer k involves particles from k+1 - ! srcn(:)=srcn(:)+nact(:,m)*(raercol(:,mm,nsav)) - srcn(top_lev:pver-1) = srcn(top_lev:pver-1) + nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - - ! rce-comment- new formulation for k=pver - ! srcn( pver )=srcn( pver )+nact( pver ,m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - srcn(pver) = srcn(pver) + max(0.0_r8,tmpa) - end do - - !mixing of cloud droplets - call explmix( & - qcld, srcn, ekkp, ekkm, overlapp, & - overlapm, qncld, zero, zero, pver, & - dtmix, .false.) - -#ifdef OSLO_AERO - !Mix number concentrations consistently!! - do m = 1, ntot_amode - mm = mam_idx(m,0) - ! rce-comment - activation source in layer k involves particles from k+1 - ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) - source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - ! rce-comment - new formulation for k=pver - ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - source(pver) = max(0.0_r8, tmpa) - flxconv = 0._r8 - - call explmix( & - raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & - dtmix, .false.) - - call explmix( & - raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw(:,mm,nsav)) - end do -#endif - -#ifndef OSLO_AERO - ! rce-comment - ! the interstitial particle mixratio is different in clear/cloudy portions - ! of a layer, and generally higher in the clear portion. (we have/had - ! a method for diagnosing the the clear/cloudy mixratios.) the activation - ! source terms involve clear air (from below) moving into cloudy air (above). - ! in theory, the clear-portion mixratio should be used when calculating - ! source terms - do m = 1, ntot_amode - mm = mam_idx(m,0) - ! rce-comment - activation source in layer k involves particles from k+1 - ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) - source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - ! rce-comment - new formulation for k=pver - ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - source(pver) = max(0.0_r8, tmpa) - flxconv = 0._r8 - - call explmix( & - raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & - dtmix, .false.) - - call explmix( & - raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw(:,mm,nsav)) - - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - ! rce-comment - activation source in layer k involves particles from k+1 - ! source(:)= mact(:,m)*(raercol(:,mm,nsav)) - source(top_lev:pver-1) = mact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - ! rce-comment- new formulation for k=pver - ! source( pver )= mact( pver ,m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*mact(pver,m) & - + raercol_cw(pver,mm,nsav)*(mact(pver,m) - taumix_internal_pver_inv) - source(pver) = max(0.0_r8, tmpa) - flxconv = 0._r8 - - call explmix( & - raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & - dtmix, .false.) - - call explmix( & - raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw(:,mm,nsav)) - - end do - end do -#endif - if (called_from_spcam) then - ! - ! turbulent mixing for gas species . - ! - do m=1, pcnst - if (cnst_species_class(m) == cnst_spec_class_gas) then - flxconv = 0.0_r8 - zerogas(:) = 0.0_r8 - call explmix(rgascol(1,m,nnew),zerogas,ekkp,ekkm,overlapp,overlapm, & - rgascol(1,m,nsav),zero, flxconv, pver,dtmix,& - .true., zerogas) - end if - end do - endif - -#ifdef OSLO_AERO - do lptr2=1,n_aerosol_tracers - source(top_lev:pver-1) = mact_tracer(top_lev:pver-1,lptr2) & - *(raercol_tracer(top_lev+1:pver,lptr2,nsav)) - - tmpa = raercol_tracer(pver,lptr2,nsav)*mact_tracer(pver,lptr2) & - + raercol_cw_tracer(pver,lptr2,nsav)*(mact_tracer(pver,lptr2) - taumix_internal_pver_inv) - - source(pver) = max(0.0_r8, tmpa) - flxconv = 0.0_r8 - - call explmix( & - raercol_cw_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw_tracer(:,lptr2,nsav), zero, zero, pver, & - dtmix, .false.) - - call explmix( & - raercol_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_tracer(:,lptr2,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw_tracer(:,lptr2,nsav)) - -#ifdef EXTRATESTS - lptr = aerosolTracerList(lptr2) - if(i.eq.iDebug .and. lptr.eq.lDebug)then - print*, "bugeds for ",trim(cnst_name(lptr)), n, nsubmix - do k=pver,1,-1 - print*, "source (aerosol/cloud) ",k, raercol_cw_tracer(k,lptr2,nnew),raercol_cw_tracer(k,lptr2,nsav) & - , raercol_tracer(k,lptr2,nnew),raercol_tracer(k,lptr2,nsav),source(k) - end do - if(m .le. nbmodes)then - print*, " ", mm, lptr, componentFractionOK(k,m,getTracerIndex(m,l,.false.)) - endif - endif -#endif - end do !Number of aerosol tracers - end do ! old_cloud_nsubmix_loop - - !Set back to the original framework - !Could probably continue in tracer-space from here - !but return back to mixture for easier use of std. NCAR code - tendencyCounted(:)=.FALSE. - do m = 1, ntot_amode - do l=1,nspec_amode(m) - mm=mam_idx(m,l) - lptr = getTracerIndex(m,l,.FALSE.) - lptr2 = inverseAerosolTracerList(lptr) - !All the tracer-space contains sum of all - !modes ==> put in first available component - !and zero in others. - if(.not.tendencyCounted(lptr))then - raercol(:,mm,nnew) = raercol_tracer(:,lptr2,nnew) - raercol_cw(:,mm,nnew) = raercol_cw_tracer(:,lptr2,nnew) - tendencyCounted(lptr) = .TRUE. - else - raercol(:,mm,nnew) = 0.0_r8 - raercol_cw(:,mm,nnew) = 0.0_r8 - end if - end do - end do -#endif - ! evaporate particles again if no cloud - - do k = top_lev, pver - if (cldn(i,k) == 0._r8) then - ! no ice or liquid cloud - qcld(k)=0._r8 - - ! convert activated aerosol to interstitial in decaying cloud - do m = 1, ntot_amode - mm = mam_idx(m,0) - raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) - raercol_cw(k,mm,nnew) = 0._r8 - - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) - raercol_cw(k,mm,nnew) = 0._r8 - end do - end do - end if - end do - - ! droplet number - - ndropcol(i) = 0._r8 - - !Initialize tendnd to zero in all layers since values are set in only top_lev,pver - !Without this the layers above top_lev would be un-initialized - tendnd(i,:) = 0.0_r8 - - do k = top_lev, pver - ndropmix(i,k) = (qcld(k) - ncldwtr(i,k))*dtinv - nsource(i,k) - tendnd(i,k) = (max(qcld(k), 1.e-6_r8) - ncldwtr(i,k))*dtinv - !print*, "tendnd",i,k, "new /old/tend", qcld(k), ncldwtr(i,k), tendnd(i,k) - ndropcol(i) = ndropcol(i) + ncldwtr(i,k)*pdel(i,k) - end do - ndropcol(i) = ndropcol(i)/gravit - -#ifdef EXTRATESTS - print*, "tendnd (#/kg/sec)", minval(tendnd(i,:)), maxval(tendnd(i,:)) -#endif - - if (prog_modal_aero) then - -#ifdef OSLO_AERO - -#ifdef MASS_BALANCE_CHECK - !test for correct transfer between in-cloud / no-cloud.. - newCloud(:,:) = 0.0_r8 - oldCloud(:,:) = 0.0_r8 - newAerosol(:,:) = 0.0_r8 - oldAerosol(:,:) = 0.0_r8 - deltaCloud(:,:) = 0.0_r8 - !Check mass balances #2 (all new cloud droplet species are taken from aerosols or from layer below - do k=pver,1,-1 - mixRatioToMass = cs(i,k)*dz(i,k) - !First sum up cloud tracer in this layer - tendencyCounted(:)=.FALSE. - do m=1,ntot_amode - do l=1,nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) !lptr occurs several times - newCloud(k, lptr) = newCloud(k, lptr) + raercol_cw(k, mm, nnew)*mixRatioToMass - newAerosol(k, lptr) = newAerosol(k, lptr) + raercol(k,mm,nnew)*mixRatioToMass - if(.NOT. tendencyCounted(lptr))then - oldAerosol(k, lptr) = raer(mm)%fld(i,k)*mixRatioToMass - oldCloud(k, lptr) = qqcw(mm)%fld(i,k)*mixRatioToMass - tendencyCounted(lptr)=.TRUE. - endif - enddo - enddo - enddo! k - - k = pver - !Check imbalance in bottom layer - - !Any change in cloud species is either from aerosol concentration or from change in layer below - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.false.) - - !This is the mass which must go to layer above! - deltaCloud(k,lptr) = (oldAerosol(k,lptr) - newAerosol(k,lptr)) &!used to create cloud species - -(newCloud(k,lptr) - oldCloud(k,lptr)) !created cloud species - enddo - enddo - - !if "deltaCloud" is positive in layer below it means that some aerosol species were sent up - - !Move upwards - do k=pver-1,1,-1 - kp1 = k + 1 - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.false.) - deltaCloud(k,lptr) = (oldAerosol(k,lptr)-newAerosol(k,lptr)) & !used to create cloud species - - (newCloud(k,lptr) - oldCloud(k,lptr)) & !created cloud species - - 0.0_r8 ! deltaCloud(kp1,lptr) !species received from below - enddo - enddo - enddo !layers - - stopMe = .FALSE. - tendencyCounted(:) = .FALSE. - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr= getTracerIndex(m,l,.false.) - if(abs(sum(deltaCloud(:,lptr))) > 1.e-8_r8 .and. (.NOT. tendencyCounted(lptr)))then - stopMe = .TRUE. - lptr2 = lptr - print*, "wrong mass budget",i,lptr,cnst_name(lptr), sum(deltaCloud(:,lptr)) - endif - tendencyCounted(lptr) = .TRUE. - enddo - enddo - if(stopMe)then - print*,"error in species : ", cnst_name(lptr2) - do k=pver,1,-1 - print*, "budgets new/old ",k, newCloud(k,lptr2),oldCloud(k,lptr2),newaerosol(k,lptr2),oldAerosol(k,lptr2), deltaCloud(k,lptr2) - enddo - call endrun ("wrong mass budget in column") - endif -#endif -#endif - raertend = 0._r8 - qqcwtend = 0._r8 - - -#ifndef OSLO_AERO - do m = 1, ntot_amode - do l = 0, nspec_amode(m) - - mm = mam_idx(m,l) - lptr = mam_cnst_idx(m,l) - - raertend(top_lev:pver) = (raercol(top_lev:pver,mm,nnew) - raer(mm)%fld(i,top_lev:pver))*dtinv - qqcwtend(top_lev:pver) = (raercol_cw(top_lev:pver,mm,nnew) - qqcw(mm)%fld(i,top_lev:pver))*dtinv - - coltend(i,mm) = sum( pdel(i,:)*raertend )/gravit - coltend_cw(i,mm) = sum( pdel(i,:)*qqcwtend )/gravit - - ptend%q(i,:,lptr) = 0.0_r8 - ptend%q(i,top_lev:pver,lptr) = raertend(top_lev:pver) ! set tendencies for interstitial aerosol - qqcw(mm)%fld(i,:) = 0.0_r8 - qqcw(mm)%fld(i,top_lev:pver) = raercol_cw(top_lev:pver,mm,nnew) ! update cloud-borne aerosol - end do - end do -#else - !OSLO AEROSOLS ... - - coltend_cw(i,:)=0.0_r8 - coltend(i,:) = 0.0_r8 - - !Need to initialize first because process modes arrive several times - tendencyCounted(:) = .FALSE. - do m=1,ntot_amode - do l = 1,getNumberOfTracersInMode(m) - lptr = getTracerIndex(m,l,.false.) - mm = mam_idx(m,l) - - !column tendencies for output - if(.NOT. tendencyCounted(lptr))then - coltend_cw(i,lptr) = coltend_cw(i,lptr) & - + sum( pdel(i,top_lev:pver)*(raercol_cw(top_lev:pver,mm,nnew) & !New, splitted, - - qqcw(mm)%fld(i,top_lev:pver) ) )/gravit*dtinv !Old, total - tendencyCounted(lptr) = .TRUE. - else !Already subtracted total old value, just add new - coltend_cw(i,lptr) = coltend_cw(i,lptr) & - + sum(pdel(i,top_lev:pver)*raercol_cw(top_lev:pver,mm,nnew))/gravit*dtinv !total already subtracted - end if - - ptend%q(i,:,lptr) = 0.0_r8 !Initialize tendencies - qqcw(mm)%fld(i,:) = 0.0_r8 !Throw out old concentrations before summing new ones - end do ! Tracers - end do ! Modes - - !First, sum up all the tracer mass concentrations - do m = 1, ntot_amode - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) !tracer indices for aerosol mass mixing ratios in raer-arrays - lptr = getTracerIndex(m,l,.false.) !index in q-array (1-pcnst) - - !This is a bit tricky since in our scheme the tracers can arrive several times - !the same tracer can exist in several modes, e.g. condensate!! - !Here we sum this into "qqcw" and "ptend" so that they contain TOTAL of those tracers - - !raercol and raercol_cw do not have totals, they have process-tracers splitted onto modes - - !Tendency at this point is the sum (original value subtracted below) - ptend%q(i,top_lev:pver,lptr) = ptend%q(i,top_lev:pver,lptr) + raercol(top_lev:pver,mm,nnew) - !for cloud water concentrations, we don't get tendency , only new concentration - qqcw(mm)%fld(i,top_lev:pver) = qqcw(mm)%fld(i,top_lev:pver) + raercol_cw(top_lev:pver,mm,nnew) - - end do - end do - - !Need this check due to some tracers (e.g. condensate) several times - tendencyCounted(:) = .FALSE. - - ! Recalculating cloud-borne aerosol number mixing ratios - do m=1,ntot_amode - - !Now that all new aerosol masses are summed up, we subtract the original concentrations to obtain the tendencies - do l= 1,nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) - if(.NOT. tendencyCounted(lptr)) then - ptend%q(i,top_lev:pver,lptr) = (ptend%q(i,top_lev:pver,lptr) - raer(mm)%fld(i,top_lev:pver))*dtinv - coltend(i,lptr) = sum(pdel(i,top_lev:pver)*ptend%q(i,top_lev:pver,lptr))/gravit !Save column tendency - tendencyCounted(lptr) = .TRUE. - endif - end do !species - end do !modes -#endif - -#ifdef MASS_BALANCE_CHECK - !Check mass balances (all removed should be in tendencies) - massBalance(:,:) = 0.0_r8 - newMass(:,:) = 0.0_r8 - do m=1,ntot_amode - do l=1,nspec_amode(m) - mm = mam_idx(m,l) !unique index, for example sulfate condendsate in "x mode" or sulf cond in "y mode" - lptr = getTracerIndex(m,l,.false.) - !add up all new values for this tracer - newMass(top_lev:pver,lptr) = newMass(top_lev:pver,lptr) + raercol(top_lev:pver, mm,nnew) - enddo - enddo - tendencyCounted(:)=.FALSE. - do m=1,ntot_amode - do l=1,nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) - if(.NOT. tendencyCounted(lptr))then - massBalance(top_lev:pver, lptr) = newMass(top_lev:pver,lptr) & - - raer(mm)%fld(i,top_lev:pver) & !previous value - - ptend%q(i,top_lev:pver,lptr)/dtinv !added during time step - tendencyCounted(lptr) = .TRUE. - endif - enddo - enddo - tendencyCounted(:) = .FALSE. - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.false.) - !Check for large deviation in mass balance for this tracer - if(.NOT. tendencyCounted(lptr) .and. & - (maxval(massBalance(:,lptr)) > 1.e-30_r8 .or. minval(massBalance(:,lptr)) < -1.0e-30_r8))then - tendencyCounted(lptr) = .TRUE. - print*, "massBalance error", i, lptr, maxVal(massBalance(:,lptr)), minVal(massBalance(:,lptr)) - if(maxVal(massBalance(:,lptr)) > 1.e-30_r8)then - kCrit = maxLoc(massBalance(:,lptr),1) - else - kCrit = minLoc(massBalance(:,lptr),1) - endif - print*, "massBalance error loc", massBalance(kCrit, lptr), newMass(kCrit,lptr), raer(mm)%fld(i,kCrit) - !If mass balance error is larger than 1.e-10 times new or original value ==> stop - if(abs(massBalance(kCrit,lptr)) .gt. 1.e-10_r8*raer(mm)%fld(i,kCrit) & - .and. abs(massBalance(kCrit,lptr)).gt.1.e-10_r8*newMass(kCrit,lptr) )then - stop - endif - endif - enddo - enddo -#endif - - - end if !prog_modal_aero - - if (called_from_spcam) then - ! - ! Gas tendency - ! - do m=1, pcnst - if (cnst_species_class(m) == cnst_spec_class_gas) then - ptend%lq(m) = .true. - ptend%q(i, :, m) = (rgascol(:,m,nnew)-rgas(i,:,m)) * dtinv - end if - end do - endif - - end do ! overall_main_i_loop - -#ifdef EXTRATESTS - !check reasonable values for ncldwtr! - do k=top_lev,pver - if(maxval(ncldwtr(:ncol,k)) .gt. 1.e20_r8)then - print*, "stopping (after dropmixnuc) wrong ncldwtr", maxloc(ncldwtr(:ncol,k)) - do i=1,ncol - print*, "ncldwtr",i,k,ncldwtr(i,k) - enddo - call endrun("wrong ncldwtr (end of dropmixnuc)") - end if - end do !loop on layers -#endif - - ! end of main loop over i/longitude .................................... - - call outfld('NDROPCOL', ndropcol, pcols, lchnk) - call outfld('NDROPSRC', nsource, pcols, lchnk) - call outfld('NDROPMIX', ndropmix, pcols, lchnk) - call outfld('WTKE ', wtke, pcols, lchnk) - -#ifndef OSLO_AERO - !fxm: Make this work with the oslo aerosols also! - call ccncalc(state, pbuf, cs, ccn) -#else - call ccncalc_oslo(state & - , pbuf & - , cs & - , numberConcentration & - , volumeConcentration & - , hygroscopicity & - , lnSigma & - , ccn ) -#endif - do l = 1, psat - call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) - enddo - -#ifndef OSLO_AERO - ! do column tendencies - if (prog_modal_aero) then - do m = 1, ntot_amode - do l = 0, nspec_amode(m) - mm = mam_idx(m,l) - call outfld(fieldname(mm), coltend(:,mm), pcols, lchnk) - call outfld(fieldname_cw(mm), coltend_cw(:,mm), pcols, lchnk) - end do - end do - end if -#endif - - if(called_from_spcam) then - ! - ! output column-integrated Gas tendency (this should be zero) - ! - do m=1, pcnst - if (cnst_species_class(m) == cnst_spec_class_gas) then - do i=1, ncol - coltendgas(i) = sum( pdel(i,:)*ptend%q(i,:,m) )/gravit - end do - fieldnamegas = trim(cnst_name(m)) // '_mixnuc1sp' - call outfld( trim(fieldnamegas), coltendgas, pcols, lchnk) - end if - end do - deallocate(rgascol, coltendgas) - end if - -#ifdef OSLO_AERO - tendencyCounted(:)=.FALSE. - do m = 1, ntot_amode - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) - if(.NOT. tendencyCounted(lptr))then - call outfld(fieldname(mm), coltend(:,lptr), pcols,lchnk) - call outfld(fieldname_cw(mm), coltend_cw(:,lptr), pcols,lchnk) - tendencyCounted(lptr)=.TRUE. - endif - end do - end do -#endif - - deallocate( & - nact, & - mact, & - raer, & - qqcw, & - raercol, & - raercol_cw, & - coltend, & - coltend_cw, & - naermod, & - hygro, & -#ifdef OSLO_AERO - lnsigman, & !Variable std. dev (CAM-Oslo) -#endif - vaerosol, & - fn, & - fm, & - fluxn, & - fluxm ) - -#ifdef OSLO_AERO - deallocate (fluxm_tmp) - deallocate (fluxn_tmp) - deallocate (fm_tmp) - deallocate (fn_tmp) - deallocate(raercol_tracer) - deallocate(raercol_cw_tracer) - deallocate(mact_tracer) - deallocate(mfullact_tracer) -#endif - - -end subroutine dropmixnuc - -!=============================================================================== - -subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & - qold, surfrate, flxconv, pver, dt, is_unact, qactold ) - - ! explicit integration of droplet/aerosol mixing - ! with source due to activation/nucleation - - - integer, intent(in) :: pver ! number of levels - real(r8), intent(out) :: q(pver) ! mixing ratio to be updated - real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step - real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) - real(r8), intent(in) :: ekkp(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! below layer k (k,k+1 interface) - real(r8), intent(in) :: ekkm(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! above layer k (k,k+1 interface) - real(r8), intent(in) :: overlapp(pver) ! cloud overlap below - real(r8), intent(in) :: overlapm(pver) ! cloud overlap above - real(r8), intent(in) :: surfrate ! surface exchange rate (/s) - real(r8), intent(in) :: flxconv ! convergence of flux from surface - real(r8), intent(in) :: dt ! time step (s) - logical, intent(in) :: is_unact ! true if this is an unactivated species - real(r8), intent(in),optional :: qactold(pver) - ! mixing ratio of ACTIVATED species from previous step - ! *** this should only be present - ! if the current species is unactivated number/sfc/mass - - integer k,kp1,km1 - - if ( is_unact ) then - ! the qactold*(1-overlap) terms are resuspension of activated material - do k=top_lev,pver - kp1=min(k+1,pver) - km1=max(k-1,top_lev) - q(k) = qold(k) + dt*( - src(k) + ekkp(k)*(qold(kp1) - qold(k) + & - qactold(kp1)*(1.0_r8-overlapp(k))) & - + ekkm(k)*(qold(km1) - qold(k) + & - qactold(km1)*(1.0_r8-overlapm(k))) ) - ! force to non-negative - ! if(q(k)<-1.e-30)then - ! write(iulog,*)'q=',q(k),' in explmix' - q(k)=max(q(k),0._r8) - ! endif - end do - - ! diffusion loss at base of lowest layer - q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt - ! force to non-negative - ! if(q(pver)<-1.e-30)then - ! write(iulog,*)'q=',q(pver),' in explmix' - q(pver)=max(q(pver),0._r8) - ! endif - else - do k=top_lev,pver - kp1=min(k+1,pver) - km1=max(k-1,top_lev) - q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & - ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) - ! force to non-negative - ! if(q(k)<-1.e-30)then - ! write(iulog,*)'q=',q(k),' in explmix' - q(k)=max(q(k),0._r8) - ! endif - end do - ! diffusion loss at base of lowest layer - q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt - ! force to non-negative - ! if(q(pver)<-1.e-30)then - ! write(iulog,*)'q=',q(pver),' in explmix' - q(pver)=max(q(pver),0._r8) - - end if - -end subroutine explmix - -!=============================================================================== - -subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - na, nmode, volume, hygro, & - fn, fm, fluxn, fluxm, flux_fullact, lnsigman ) - - ! calculates number, surface, and mass fraction of aerosols activated as CCN - ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud - ! assumes an internal mixture within each of up to nmode multiple aerosol modes - ! a gaussiam spectrum of updrafts can be treated. - - ! mks units - - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - - ! input - - real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) - real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) - real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) - real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) - real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) - real(r8), intent(in) :: tair ! air temperature (K) - real(r8), intent(in) :: rhoair ! air density (kg/m3) - real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) - integer, intent(in) :: nmode ! number of aerosol modes - real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) - real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode - real(r8), intent(in), optional :: lnsigman(:) - - ! output - - real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated - real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated - real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) - ! rce-comment - ! used for consistency check -- this should match (ekd(k)*zs(k)) - ! also, fluxm/flux_fullact gives fraction of aerosol mass flux - ! that is activated - - ! local - - integer, parameter:: nx=200 - integer iquasisect_option, isectional - real(r8) integ,integf - real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) - real(r8) xmin(nmode),xmax(nmode) ! ln(r) at section interfaces - real(r8) volmin(nmode),volmax(nmode) ! volume at interfaces - real(r8) tmass ! total aerosol mass concentration (g/cm3) - real(r8) sign(nmode) ! geometric standard deviation of size distribution - real(r8) rm ! number mode radius of aerosol at max supersat (cm) - real(r8) pres ! pressure (Pa) - real(r8) path ! mean free path (m) - real(r8) diff ! diffusivity (m2/s) - real(r8) conduct ! thermal conductivity (Joule/m/sec/deg) - real(r8) diff0,conduct0 - real(r8) es ! saturation vapor pressure - real(r8) qs ! water vapor saturation mixing ratio - real(r8) dqsdt ! change in qs with temperature - real(r8) dqsdp ! change in qs with pressure - real(r8) g ! thermodynamic function (m2/s) - real(r8) zeta(nmode), eta(nmode) - real(r8) lnsmax ! ln(smax) - real(r8) alpha - real(r8) gamma - real(r8) beta - real(r8) sqrtg - real(r8) :: amcube(nmode) ! cube of dry mode radius (m) - !++alfgr (ununsed) real(r8) :: smcrit(nmode) ! critical supersatuation for activation - real(r8) :: lnsm(nmode) ! ln(smcrit) - real(r8) smc(nmode) ! critical supersaturation for number mode radius - real(r8) sumflx_fullact - real(r8) sumflxn(nmode) - real(r8) sumflxm(nmode) - real(r8) sumfn(nmode) - real(r8) sumfm(nmode) - real(r8) fnold(nmode) ! number fraction activated - real(r8) fmold(nmode) ! mass fraction activated - real(r8) exp45logsig_var(nmode) !variable std. dev (CAM-Oslo) - real(r8), target :: f1_var(nmode), f2_var(nmode) - real(r8) wold,gold - real(r8) alogam - real(r8) rlo,rhi,xint1,xint2,xint3,xint4 - real(r8) wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb - real(r8) dfmin,dfmax,fnew,fold,fnmin,fnbar,fsbar,fmbar - real(r8) alw,sqrtalw - real(r8) smax - real(r8) x,arg - real(r8) xmincoeff,xcut,volcut,surfcut - real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf - real(r8) etafactor1,etafactor2(nmode),etafactor2max - real(r8) grow - character(len=*), parameter :: subname='activate_modal' - integer m,n - ! numerical integration parameters - real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 - - real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) - - integer ndist(nx) ! accumulates frequency distribution of integration bins required - data ndist/nx*0/ - save ndist - - fn(:)=0._r8 - fm(:)=0._r8 - fluxn(:)=0._r8 - fluxm(:)=0._r8 - flux_fullact=0._r8 - - if(nmode.eq.1.and.na(1).lt.1.e-20_r8)return - - if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return - - pres=rair*rhoair*tair - diff0=0.211e-4_r8*(p0/pres)*(tair/t0)**1.94_r8 - conduct0=(5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg - call qsat(tair, pres, es, qs) - dqsdt=latvap/(rh2o*tair*tair)*qs - alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) - gamma=(1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) - etafactor2max=1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. - - grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) & - + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) - sqrtg = sqrt(grow) - beta = 2._r8*pi*rhoh2o*grow*gamma - - do m=1,nmode - - if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then - ! number mode radius (m) - ! write(iulog,*)'alogsig,volc,na=',alogsig(m),volc(m),na(m) -#ifdef OSLO_AERO - if(present(lnsigman))then - exp45logsig_var(m) = exp(4.5_r8*lnsigman(m)*lnsigman(m)) - amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig_var(m)*na(m))) ! only if variable size dist - f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) - f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) - else - call endrun("Problem with variable std. dev") - endif -#else - !Std cam - amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig(m)*na(m))) ! only if variable size dist -#endif - ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 - ! should depend on mean radius of mode to account for gas kinetic effects - ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 - ! for approriate size to use for effective diffusivity. - etafactor2(m)=1._r8/(na(m)*beta*sqrtg) - if(hygro(m).gt.1.e-10_r8)then - smc(m)=2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist - else - smc(m)=100._r8 - endif - ! write(iulog,*)'sm,hygro,amcube=',smcrit(m),hygro(m),amcube(m) - else - smc(m)=1._r8 - etafactor2(m)=etafactor2max ! this should make eta big if na is very small. - endif - lnsm(m)=log(smc(m)) ! only if variable size dist - ! write(iulog,'(a,i4,4g12.2)')'m,na,amcube,hygro,sm,lnsm=', & - ! m,na(m),amcube(m),hygro(m),sm(m),lnsm(m) - enddo - - if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts - - wmax=min(wmaxf,wbar+sds*sigw) - wmin=max(wminf,-wdiab) - wmin=max(wmin,wbar-sds*sigw) - w=wmin - dwmax=eps*sigw - dw=dwmax - dfmax=0.2_r8 - dfmin=0.1_r8 - if (wmax <= w) return - do m=1,nmode - sumflxn(m)=0._r8 - sumfn(m)=0._r8 - fnold(m)=0._r8 - sumflxm(m)=0._r8 - sumfm(m)=0._r8 - fmold(m)=0._r8 - enddo - sumflx_fullact=0._r8 - - fold=0._r8 - wold=0._r8 - gold=0._r8 - - dwmin = min( dwmax, 0.01_r8 ) - do n = 1, nx - -100 wnuc=w+wdiab - ! write(iulog,*)'wnuc=',wnuc - alw=alpha*wnuc - sqrtalw=sqrt(alw) - etafactor1=alw*sqrtalw - - do m=1,nmode - eta(m)=etafactor1*etafactor2(m) - zeta(m)=twothird*sqrtalw*aten/sqrtg - enddo - - call maxsat(zeta,eta,nmode,smc,smax & -#ifdef OSLO_AERO - ,f1_var, f2_var & -#endif - ) - ! write(iulog,*)'w,smax=',w,smax - - lnsmax=log(smax) - -#ifdef OSLO_AERO - x=twothird*(lnsm(nmode)-lnsmax)/(sq2*lnsigman(nmode)) -#else - x=twothird*(lnsm(nmode)-lnsmax)/(sq2*alogsig(nmode)) -#endif - fnew=0.5_r8*(1._r8-erf(x)) - - - dwnew = dw - if(fnew-fold.gt.dfmax.and.n.gt.1)then - ! reduce updraft increment for greater accuracy in integration - if (dw .gt. 1.01_r8*dwmin) then - dw=0.7_r8*dw - dw=max(dw,dwmin) - w=wold+dw - go to 100 - else - dwnew = dwmin - endif - endif - - if(fnew-fold.lt.dfmin)then - ! increase updraft increment to accelerate integration - dwnew=min(1.5_r8*dw,dwmax) - endif - fold=fnew - - z=(w-wbar)/(sigw*sq2) - g=exp(-z*z) - fnmin=1._r8 - xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - - do m=1,nmode - ! modal -#ifdef OSLO_AERO - x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) -#else - x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) -#endif - fn(m)=0.5_r8*(1._r8-erf(x)) - fnmin=min(fn(m),fnmin) - ! integration is second order accurate - ! assumes linear variation of f*g with w - fnbar=(fn(m)*g+fnold(m)*gold) -#ifdef OSLO_AERO - arg=x-1.5_r8*sq2*lnsigman(m) -#else - arg=x-1.5_r8*sq2*alogsig(m) -#endif - fm(m)=0.5_r8*(1._r8-erf(arg)) - fmbar=(fm(m)*g+fmold(m)*gold) - wb=(w+wold) - if(w.gt.0._r8)then - sumflxn(m)=sumflxn(m)+sixth*(wb*fnbar & - +(fn(m)*g*w+fnold(m)*gold*wold))*dw - sumflxm(m)=sumflxm(m)+sixth*(wb*fmbar & - +(fm(m)*g*w+fmold(m)*gold*wold))*dw - endif - sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw - ! write(iulog,'(a,9g10.2)')'lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw=',lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw - fnold(m)=fn(m) - sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw - fmold(m)=fm(m) - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact & - + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw - ! sumg=sumg+0.5_r8*(g+gold)*dw - gold=g - wold=w - dw=dwnew - if (n > 1 .and. (w > wmax .or. fnmin > fmax)) exit - w=w+dw - if (n == nx) then - write(iulog,*)'do loop is too short in activate' - write(iulog,*)'wmin=',wmin,' w=',w,' wmax=',wmax,' dw=',dw - write(iulog,*)'wbar=',wbar,' sigw=',sigw,' wdiab=',wdiab - write(iulog,*)'wnuc=',wnuc - write(iulog,*)'na=',(na(m),m=1,nmode) - write(iulog,*)'fn=',(fn(m),m=1,nmode) - ! dump all subr parameters to allow testing with standalone code - ! (build a driver that will read input and call activate) - write(iulog,*)'wbar,sigw,wdiab,tair,rhoair,nmode=' - write(iulog,*) wbar,sigw,wdiab,tair,rhoair,nmode - write(iulog,*)'na=',na - write(iulog,*)'volume=', (volume(m),m=1,nmode) - write(iulog,*)'hydro=' - write(iulog,*) hygro - call endrun(subname) - end if - - enddo - - ndist(n)=ndist(n)+1 - if(w.lt.wmaxf)then - - ! contribution from all updrafts stronger than wmax - ! assuming constant f (close to fmax) - wnuc=w+wdiab - - z1=(w-wbar)/(sigw*sq2) - z2=(wmaxf-wbar)/(sigw*sq2) - g=exp(-z1*z1) - integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) - ! consider only upward flow into cloud base when estimating flux - wf1=max(w,zero) - zf1=(wf1-wbar)/(sigw*sq2) - gf1=exp(-zf1*zf1) - wf2=max(wmaxf,zero) - zf2=(wf2-wbar)/(sigw*sq2) - gf2=exp(-zf2*zf2) - gf=(gf1-gf2) - integf=wbar*sigw*0.5_r8*sq2*sqpi*(erf(zf2)-erf(zf1))+sigw*sigw*gf - - do m=1,nmode - sumflxn(m)=sumflxn(m)+integf*fn(m) - sumfn(m)=sumfn(m)+fn(m)*integ - sumflxm(m)=sumflxm(m)+integf*fm(m) - sumfm(m)=sumfm(m)+fm(m)*integ - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact + integf - ! sumg=sumg+integ - endif - - - do m=1,nmode - fn(m)=sumfn(m)/(sq2*sqpi*sigw) - ! fn(m)=sumfn(m)/(sumg) - if(fn(m).gt.1.01_r8)then - write(iulog,*)'fn=',fn(m),' > 1 in activate' - write(iulog,*)'w,m,na,amcube=',w,m,na(m),amcube(m) - write(iulog,*)'integ,sumfn,sigw=',integ,sumfn(m),sigw - call endrun('activate') - endif - fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) - fm(m)=sumfm(m)/(sq2*sqpi*sigw) - ! fm(m)=sumfm(m)/(sumg) - if(fm(m).gt.1.01_r8)then - write(iulog,*)'fm=',fm(m),' > 1 in activate' - endif - fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) - enddo - ! same form as fluxm - flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) - - else - - ! single updraft - wnuc=wbar+wdiab - - if(wnuc.gt.0._r8)then - - w=wbar - alw=alpha*wnuc - sqrtalw=sqrt(alw) - etafactor1=alw*sqrtalw - - do m=1,nmode - eta(m)=etafactor1*etafactor2(m) - zeta(m)=twothird*sqrtalw*aten/sqrtg - enddo - - call maxsat(zeta,eta,nmode,smc,smax & -#ifdef OSLO_AERO - ,f1_var, f2_var & -#endif - ) - - lnsmax=log(smax) - xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - - - do m=1,nmode -#ifdef OSLO_AERO - x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) -#else - x=twothird*(lnsm(m)-lnsmax)/(sq2*alogsig(m)) -#endif - fn(m)=0.5_r8*(1._r8-erf(x)) -#ifdef OSLO_AERO - arg=x-1.5_r8*sq2*lnsigman(m) -#else - arg=x-1.5_r8*sq2*alogsig(m) -#endif - fm(m)=0.5_r8*(1._r8-erf(arg)) - if(wbar.gt.0._r8)then - fluxn(m)=fn(m)*w - fluxm(m)=fm(m)*w - endif - enddo - flux_fullact = w - endif - - endif - -end subroutine activate_modal - -!=============================================================================== - -subroutine maxsat(zeta,eta,nmode,smc,smax, f1_in, f2_in) - - ! calculates maximum supersaturation for multiple - ! competing aerosol modes. - - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - integer, intent(in) :: nmode ! number of modes - real(r8), intent(in) :: smc(nmode) ! critical supersaturation for number mode radius - real(r8), intent(in) :: zeta(nmode) - real(r8), intent(in) :: eta(nmode) - real(r8), intent(in), optional, target :: f1_in(:) - real(r8), intent(in), optional, target :: f2_in(:) - - real(r8), intent(out) :: smax ! maximum supersaturation - integer :: m ! mode index - real(r8) :: sum, g1, g2, g1sqrt, g2sqrt - real(r8), pointer :: f1_used(:), f2_used(:) - -#ifdef OSLO_AERO - f1_used => f1_in - f2_used => f2_in -#else - f1_used => f1 - f2_used => f2 -#endif - - - do m=1,nmode - if(zeta(m).gt.1.e5_r8*eta(m).or.smc(m)*smc(m).gt.1.e5_r8*eta(m))then - ! weak forcing. essentially none activated - smax=1.e-20_r8 - else - ! significant activation of this mode. calc activation all modes. - exit - endif - ! No significant activation in any mode. Do nothing. - if (m == nmode) return - - enddo - - sum=0.0_r8 - do m=1,nmode - if(eta(m).gt.1.e-20_r8)then - g1=zeta(m)/eta(m) - g1sqrt=sqrt(g1) - g1=g1sqrt*g1 - g2=smc(m)/sqrt(eta(m)+3._r8*zeta(m)) - g2sqrt=sqrt(g2) - g2=g2sqrt*g2 - sum=sum+(f1_used(m)*g1+f2_used(m)*g2)/(smc(m)*smc(m)) - else - sum=1.e20_r8 - endif - enddo - - smax=1._r8/sqrt(sum) - -end subroutine maxsat - -!=============================================================================== - -#ifndef OSLO_AERO -subroutine ccncalc(state, pbuf, cs, ccn) - - ! calculates number concentration of aerosols activated as CCN at - ! supersaturation supersat. - ! assumes an internal mixture of a multiple externally-mixed aerosol modes - ! cgs units - - ! Ghan et al., Atmos. Res., 1993, 198-221. - - ! arguments - - type(physics_state), target, intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - - real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) - real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) - - ! local - - integer :: lchnk ! chunk index - integer :: ncol ! number of columns - real(r8), pointer :: tair(:,:) ! air temperature (K) - - real(r8) naerosol(pcols) ! interstit+activated aerosol number conc (/m3) - real(r8) vaerosol(pcols) ! interstit+activated aerosol volume conc (m3/m3) - - real(r8) amcube(pcols) - real(r8) super(psat) ! supersaturation - real(r8), allocatable :: amcubecoef(:) - real(r8), allocatable :: argfactor(:) - real(r8) :: surften ! surface tension of water w/respect to air (N/m) - real(r8) surften_coef - real(r8) a(pcols) ! surface tension parameter - real(r8) hygro(pcols) ! aerosol hygroscopicity - real(r8) sm(pcols) ! critical supersaturation at mode radius - real(r8) arg(pcols) - ! mathematical constants - real(r8) twothird,sq2 - integer l,m,n,i,k - real(r8) log,cc - real(r8) smcoefcoef,smcoef(pcols) - integer phase ! phase of aerosol - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - tair => state%t - - allocate( & - amcubecoef(ntot_amode), & - argfactor(ntot_amode) ) - - super(:)=supersat(:)*0.01_r8 - sq2=sqrt(2._r8) - twothird=2._r8/3._r8 - surften=0.076_r8 - surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) - smcoefcoef=2._r8/sqrt(27._r8) - - do m=1,ntot_amode - amcubecoef(m)=3._r8/(4._r8*pi*exp45logsig(m)) - argfactor(m)=twothird/(sq2*alogsig(m)) - end do - - ccn = 0._r8 - do k=top_lev,pver - - do i=1,ncol - a(i)=surften_coef/tair(i,k) - smcoef(i)=smcoefcoef*a(i)*sqrt(a(i)) - end do - - do m=1,ntot_amode - - phase=3 ! interstitial+cloudborne - - call loadaer( & - state, pbuf, 1, ncol, k, & - m, cs, phase, naerosol, vaerosol, & - hygro) - - where(naerosol(:ncol)>1.e-3_r8) - amcube(:ncol)=amcubecoef(m)*vaerosol(:ncol)/naerosol(:ncol) - sm(:ncol)=smcoef(:ncol)/sqrt(hygro(:ncol)*amcube(:ncol)) ! critical supersaturation - elsewhere - sm(:ncol)=1._r8 ! value shouldn't matter much since naerosol is small - endwhere - do l=1,psat - do i=1,ncol - arg(i)=argfactor(m)*log(sm(i)/super(l)) - ccn(i,k,l)=ccn(i,k,l)+naerosol(i)*0.5_r8*(1._r8-erf(arg(i))) - enddo - enddo - enddo - enddo - ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 - - deallocate( & - amcubecoef, & - argfactor ) - -end subroutine ccncalc - -#else - -subroutine ccncalc_oslo(state & - , pbuf & - , cs & - , numberConcentration & - , volumeConcentration & - , hygroscopicity & - , lnSigma & - , ccn ) - - ! calculates number concentration of aerosols activated as CCN at - ! supersaturation supersat. - ! assumes an internal mixture of a multiple externally-mixed aerosol modes - ! cgs units - - ! This was used in the BACCHUS-project where it was agreed that - ! CCN would not include cloud-borne aerosols. It is possible to - ! calculate cloud-borne aerosols, but it is complicated, and it was - ! not needed when this code was made. - - ! arguments - - type(physics_state), target, intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) - real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) - real(r8), intent(in) :: numberConcentration(pcols,pver, nmodes) ! interstit+activated aerosol number conc (/m3) - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ! interstit+activated aerosol volume conc (m3/m3) - real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) - real(r8), intent(in) :: lnSigma(pcols,pver,nmodes) - - ! local - integer :: lchnk ! chunk index - integer :: ncol ! number of columns - real(r8), pointer :: tair(:,:) ! air temperature (K) - - - real(r8) super(psat) ! supersaturation - real(r8) surften_coef !Coefficient in ARGI / ARGII - real(r8) amcube !number median radius qubed - real(r8) a ! surface tension parameter - real(r8) sm ! critical supersaturation at mode radius - real(r8) arg ! factor in eqn 15 ARGII - real(r8) argfactor !Coefficient in ARGI/ARGII - ! mathematical constants - real(r8), parameter:: twothird=2.0_r8/3.0_r8 - real(r8), parameter:: sq2=sqrt(2.0_r8) - real(r8), parameter :: surften=0.076_r8 !surface tension of water (J/m2) - real(r8) exp45logsig_var - integer lsat,m,i,k - real(r8) smcoefcoef,smcoef - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - tair => state%t - - super(:)=supersat(:)*0.01_r8 - - !This is curvature effect (A) in ARGI - !eqn 5 in ARG1 (missing division by temperature, see below) - surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) - - !This is part of eqn 9 in ARGII - !where A smcoefcoef is 2/3^(3/2) - smcoefcoef=2._r8/sqrt(27._r8) - - ccn(:,:,:) = 0._r8 - - do m=1,nmodes - do k=top_lev,pver - - do i=1,ncol - - !Curvature-parameter "A" in ARGI (eqn 5) - a = surften_coef/tair(i,k) - - !standard factor for transforming size distr - !volume ==> number (google psd.pdf by zender) - exp45logsig_var = & - exp(4.5_r8*lnsigma(i,k,m)*lnsigma(i,k,m)) - - !Numbe rmedian radius (power of three) - !By definition of lognormal distribution - amcube =(3._r8*volumeConcentration(i,k,m) & -!tht is zero an allowed value for numberConcentration?? - /(4._r8*pi*exp45logsig_var*numberConcentration(i,k,m))) ! only if variable size dist - - - !This is part of eqn 9 in ARGII - !where A smcoefcoef is 2/3^(3/2) - smcoef = smcoefcoef * a * sqrt(a) - - !This is finally solving eqn 9 - !(solve for critical supersat of mode) - sm=smcoef & - / sqrt(hygroscopicity(i,k,m)*amcube) ! critical supersaturation - - !Solve eqn 13 in ARGII - do lsat = 1,psat - - !eqn 15 in ARGII - argfactor=twothird/(sq2*lnSigma(i,k,m)) - - !eqn 15 in ARGII - arg=argfactor*log(sm/super(lsat)) - - !eqn 13 i ARGII - ccn(i,k,lsat)=ccn(i,k,lsat) & - +numberConcentration(i,k,m)& - *0.5_r8*(1._r8-erf(arg)) - end do - end do - end do - end do - - ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 - -end subroutine ccncalc_oslo -#endif - -!=============================================================================== - -subroutine loadaer( & - state, pbuf, istart, istop, k, & - m, cs, phase, naerosol, & - vaerosol, hygro) - - ! return aerosol number, volume concentrations, and bulk hygroscopicity - - ! input arguments - type(physics_state), target, intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - integer, intent(in) :: istart ! start column index (1 <= istart <= istop <= pcols) - integer, intent(in) :: istop ! stop column index - integer, intent(in) :: m ! mode index - integer, intent(in) :: k ! level index - real(r8), intent(in) :: cs(:,:) ! air density (kg/m3) - integer, intent(in) :: phase ! phase of aerosol: 1 for interstitial, 2 for cloud-borne, 3 for sum - - ! output arguments - real(r8), intent(out) :: naerosol(:) ! number conc (1/m3) - real(r8), intent(out) :: vaerosol(:) ! volume conc (m3/m3) - real(r8), intent(out) :: hygro(:) ! bulk hygroscopicity of mode - - ! internal - integer :: lchnk ! chunk identifier - - real(r8), pointer :: raer(:,:) ! interstitial aerosol mass, number mixing ratios - real(r8), pointer :: qqcw(:,:) ! cloud-borne aerosol mass, number mixing ratios - real(r8) :: specdens, spechygro - - real(r8) :: vol(pcols) ! aerosol volume mixing ratio - integer :: i, l - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - - do i = istart, istop - vaerosol(i) = 0._r8 - hygro(i) = 0._r8 - end do - - do l = 1, nspec_amode(m) - - call rad_cnst_get_aer_mmr(0, m, l, 'a', state, pbuf, raer) - call rad_cnst_get_aer_mmr(0, m, l, 'c', state, pbuf, qqcw) - call rad_cnst_get_aer_props(0, m, l, density_aer=specdens, hygro_aer=spechygro) - - if (phase == 3) then - do i = istart, istop - vol(i) = max(raer(i,k) + qqcw(i,k), 0._r8)/specdens - end do - else if (phase == 2) then - do i = istart, istop - vol(i) = max(qqcw(i,k), 0._r8)/specdens - end do - else if (phase == 1) then - do i = istart, istop - vol(i) = max(raer(i,k), 0._r8)/specdens - end do - else - write(iulog,*)'phase=',phase,' in loadaer' - call endrun('phase error in loadaer') - end if - - do i = istart, istop - vaerosol(i) = vaerosol(i) + vol(i) - hygro(i) = hygro(i) + vol(i)*spechygro - end do - - end do - - do i = istart, istop - if (vaerosol(i) > 1.0e-30_r8) then ! +++xl add 8/2/2007 - hygro(i) = hygro(i)/(vaerosol(i)) - vaerosol(i) = vaerosol(i)*cs(i,k) - else - hygro(i) = 0.0_r8 - vaerosol(i) = 0.0_r8 - end if - end do - - ! aerosol number - call rad_cnst_get_mode_num(0, m, 'a', state, pbuf, raer) - call rad_cnst_get_mode_num(0, m, 'c', state, pbuf, qqcw) - if (phase == 3) then - do i = istart, istop - naerosol(i) = (raer(i,k) + qqcw(i,k))*cs(i,k) - end do - else if (phase == 2) then - do i = istart, istop - naerosol(i) = qqcw(i,k)*cs(i,k) - end do - else - do i = istart, istop - naerosol(i) = raer(i,k)*cs(i,k) - end do - end if - ! adjust number so that dgnumlo < dgnum < dgnumhi - do i = istart, istop - naerosol(i) = max(naerosol(i), vaerosol(i)*voltonumbhi_amode(m)) - naerosol(i) = min(naerosol(i), vaerosol(i)*voltonumblo_amode(m)) - end do - -end subroutine loadaer - -!=============================================================================== - -end module ndrop - - - - diff --git a/src/physics/cam_oslo/aeroopt_mod.F90 b/src/physics/cam_oslo/aeroopt_mod.F90 index 91a5490c59..5b703ab375 100644 --- a/src/physics/cam_oslo/aeroopt_mod.F90 +++ b/src/physics/cam_oslo/aeroopt_mod.F90 @@ -155,7 +155,7 @@ subroutine initaeropt() enddo ! !------------------------------------------- - ! Mode 0, BC(ax + ! Mode 0, BC !------------------------------------------- ! read(20,'(I2,f6.3,12e11.4)') & diff --git a/src/physics/cam_oslo/coltst4intcons.F90 b/src/physics/cam_oslo/coltst4intcons.F90 deleted file mode 100644 index e95de3f58a..0000000000 --- a/src/physics/cam_oslo/coltst4intcons.F90 +++ /dev/null @@ -1,302 +0,0 @@ - -subroutine coltst4intcons (lchnk, ncol, qm1, deltah_km, rhoda, fnbc, & - dload_mi, dload_ss, dload_s4, dload_oc, dload_bc, & - dload_bc_0, dload_bc_2, dload_bc_4, dload_bc_12, dload_bc_14, dload_bc_ac, & - dload_oc_4, dload_oc_14, dload_oc_ac, dload_s4_a, dload_s4_1, dload_s4_5) - -! Testing column burdens for internal consistency between intdrypar -! (use of aerodryk*.out look-up tables) and calculations directly -! from the qm1 array. Made by Alf Kirkevag 8/12-2015. - -! Due to a problem with initialization of some values (seemingly), -! the output variables COLR* (column burden ratio for tracers *) -! should not be checked for the first output file from an initial run. -! Initial test results after coorecting a bug in AeroTab October 2016: -! Results from month 5 in a test simulation with 2000 aerosol emissions -! and f10_f10 resolution (10x15_10x15) gave the following globally -! averaged COLR* values: -! -! COLRBC0 = 1.000015 ; -! COLRBC12 = 0.9991855 ; -! COLRBC14 = 0.9992678 ; -! COLRBC2 = 0.9991855 ; -! COLRBC4 = 0.9997123 ; -! COLRBCAC = 1.000379 ; -! COLROC14 = 0.9989312 ; -! COLROC4 = 0.9995964 ; -! COLROCAC = 0.9993698 ; -! COLRSUL1 = 1.034586 ; -! COLRSUL5 = 1.03905 ; -! COLRSULA = 1.000236 ; -! -! with regional variations within 0.01 for all tracers except for the -! externally mixed tracers so4_na (COLRSUL1 = 1.02 - 1.04) and so4_pr -! (COLRSUL5 = 1.035 - 1.039). The biases for COLRSUL1 and COLRSUL5 are -! consistent with a ratio between mass density for sulfuric acid and -! ammonium sulfate (1841/1769=1.041), and that CAM5-Olso does not take -! into account the former. - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst - use aerosoldef - use cam_history, only: outfld - - implicit none - -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: qm1(pcols,pver,pcnst) ! Specific humidity and tracers (kg/kg) - real(r8), intent(in) :: deltah_km(pcols,pver) ! Layer thickness, unit km - real(r8), intent(in) :: rhoda(pcols,pver) - real(r8), intent(in) :: fnbc(pcols,pver) - real(r8), intent(in) :: dload_mi(pcols) - real(r8), intent(in) :: dload_ss(pcols) - real(r8), intent(in) :: dload_s4(pcols) - real(r8), intent(in) :: dload_oc(pcols) - real(r8), intent(in) :: dload_bc(pcols) - real(r8), intent(in) :: dload_bc_0(pcols) - real(r8), intent(in) :: dload_bc_2(pcols) - real(r8), intent(in) :: dload_bc_4(pcols) - real(r8), intent(in) :: dload_bc_12(pcols) - real(r8), intent(in) :: dload_bc_14(pcols) - real(r8), intent(in) :: dload_bc_ac(pcols) - real(r8), intent(in) :: dload_oc_4(pcols) - real(r8), intent(in) :: dload_oc_14(pcols) - real(r8), intent(in) :: dload_oc_ac(pcols) - real(r8), intent(in) :: dload_s4_a(pcols) - real(r8), intent(in) :: dload_s4_1(pcols) - real(r8), intent(in) :: dload_s4_5(pcols) -! -!---------------------------Local variables----------------------------- -! - integer icol, k - real(r8) columnb(pcols), colratio(pcols) -! strict test, only expected to apply for some externally mixed modes: -! real(r8), parameter :: oneplus = 1.003_r8 -! real(r8), parameter :: oneminus = 0.997_r8 -! less strict test, expected to apply for externally mixed modes, except -! in the first time-steps, seemingly due to problem with initialization: - real(r8), parameter :: oneplus = 1.05_r8 - real(r8), parameter :: oneminus = 0.95_r8 -! -! -!---------------------------Test calculations--------------------------- - -!BC: - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*qm1(icol,k,l_bc_ax)*rhoda(icol,k) - colratio(icol) = dload_bc_0(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my bc 0 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLRBC0 ', colratio, pcols,lchnk) - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*qm1(icol,k,l_bc_a)*rhoda(icol,k) - colratio(icol) = dload_bc_2(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my bc 2 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLRBC2 ', colratio, pcols,lchnk) - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*qm1(icol,k,l_bc_ai)*rhoda(icol,k) - colratio(icol) = dload_bc_4(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my bc 4 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLRBC4 ', colratio, pcols,lchnk) - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*qm1(icol,k,l_bc_n)*rhoda(icol,k) - colratio(icol) = dload_bc_12(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my bc 12 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLRBC12', colratio, pcols,lchnk) - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*qm1(icol,k,l_bc_ni)*rhoda(icol,k) - colratio(icol) = dload_bc_14(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my bc 14 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLRBC14 ', colratio, pcols,lchnk) - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*qm1(icol,k,l_bc_ac)*rhoda(icol,k) - colratio(icol) = dload_bc_ac(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my bc ac ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLRBCAC', colratio, pcols,lchnk) - -!OC: - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*qm1(icol,k,l_om_ai)*rhoda(icol,k) - colratio(icol) = dload_oc_4(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my oc 4 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLROC4 ', colratio, pcols,lchnk) - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*qm1(icol,k,l_om_ni)*rhoda(icol,k) - colratio(icol) = dload_oc_14(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my oc 14 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLROC14', colratio, pcols,lchnk) - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*(qm1(icol,k,l_om_ac)+qm1(icol,k,l_soa_a1))*rhoda(icol,k) - colratio(icol) = dload_oc_ac(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my oc ac and soa a1 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLROCAC', colratio, pcols,lchnk) - -!Sulfate: - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*(qm1(icol,k,l_so4_a1) & - + qm1(icol,k,l_so4_a2) & - + qm1(icol,k,l_so4_ac))*rhoda(icol,k) - colratio(icol) = dload_s4_a(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my sulfate a ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLRSULA', colratio, pcols,lchnk) - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*(qm1(icol,k,l_so4_na))*rhoda(icol,k) - colratio(icol) = dload_s4_1(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my sulfate 1 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLRSUL1', colratio, pcols,lchnk) - - do icol=1,ncol - columnb(icol) = 0.0_r8 - colratio(icol) = 0.0_r8 - end do - do icol=1,ncol - do k=1,pver - columnb(icol) = columnb(icol)+deltah_km(icol,k) & - * 1.e9*(qm1(icol,k,l_so4_pr))*rhoda(icol,k) - colratio(icol) = dload_s4_5(icol)/columnb(icol) - end do -! if(colratio(icol).lt.oneminus.or.colratio(icol).gt.oneplus) then -! write(99,*) 'my sulfate 5 ratio =', icol, colratio(icol) -! endif - end do - - call outfld('COLRSUL5', colratio, pcols,lchnk) - - return -end subroutine coltst4intcons diff --git a/src/physics/cam_oslo/ptaero_table.F90 b/src/physics/cam_oslo/ptaero_table.F90 deleted file mode 100644 index 664c708c5b..0000000000 --- a/src/physics/cam_oslo/ptaero_table.F90 +++ /dev/null @@ -1,280 +0,0 @@ -module ptaero_table - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - save - - integer, parameter :: max_table_rank = 4 - - type one_dim_array_t - real(r8), allocatable :: values(:) - end type - - type ptaero_table_t - integer :: rank !table rank - integer, dimension(max_table_rank) :: dims !Dimension - real(r8), dimension(:,:,:,:), allocatable :: values !Table data - TYPE(one_dim_array_t), dimension(:), allocatable :: axisValues !axis values - end type ptaero_table_t - - - -contains - - subroutine construct(table) - TYPE(ptaero_table_t), intent(inout) :: table - - if(allocated(table%values))deallocate(table%values) - if(allocated(table%values))deallocate(table%axisValues) - table%dims(:)=1 - table%rank = 0 - end subroutine construct - - - subroutine initialize(table, mixture_id, property_id, limits1, limits2, limits3, limits4, data2d, data3d, data4d) - implicit none - TYPE(ptaero_table_t), intent(inout) :: table - integer, intent(in) :: mixture_id !mixture id - integer, intent(in) :: property_id !property (e.g. ssa, sigma, radius, whatever) - real(r8), dimension(:,:), intent(in), optional :: data2d !2d data - real(r8), dimension(:,:,:), intent(in), optional :: data3d !3d data - real(r8), dimension(:,:,:,:), intent(in), optional :: data4d !4d data - real(r8), dimension(:),intent(in),optional :: limits1 - real(r8), dimension(:), intent(in),optional :: limits2 - real(r8), dimension(:), intent(in),optional :: limits3 - real(r8), dimension(:), intent(in),optional :: limits4 - - integer :: i - - !Local variables - logical tableFound - - !local - tableFound=.FALSE. - - if(allocated(table%values))then - stop "error" - end if - - !Find the rank - if(present(data2d))then - table%rank = 2 - tableFound = .TRUE. - table%dims(1) = SIZE(data2d,1) - table%dims(2) = SIZE(data2d,2) - endif - if(present(data3d))then - table%rank = 3 - if(tableFound .eqv. .TRUE.)then - stop "error" - end if - tableFound=.TRUE. - table%dims(1) = SIZE(data3d,1) - table%dims(2) = SIZE(data3d,2) - table%dims(3) = SIZE(data3d,3) - end if - if(present(data4d))then - table%rank = 4 - if(tableFound .eqv. .TRUE.)then - stop "error" - end if - tableFound=.TRUE. - table%dims(1) = SIZE(data4d,1) - table%dims(2) = SIZE(data4d,2) - table%dims(3) = SIZE(data4d,3) - table%dims(4) = SIZE(data4d,4) - end if - - allocate(table%values(table%dims(1), table%dims(2), table%dims(3), table%dims(4))) - - !Allocate space for axis values - allocate(table%axisValues(table%rank)) - do i=1,table%rank - allocate(table%axisValues(i)%values(table%dims(i))) - end do - - do i=1,table%rank - select case(i) - case(1) - table%axisValues(i)%values(:)=limits1(:) - case(2) - table%axisValues(i)%values(:)=limits2(:) - case(3) - table%axisValues(i)%values(:)=limits3(:) - case(4) - table%axisValues(i)%values(:)=limits4(:) - end select - end do - - select case(table%rank) - case(2) - table%values(:,:,1,1) = data2d(:,:) - case(3) - table%values(:,:,:,1) = data3d(:,:,:) - case(4) - table%values(:,:,:,:) = data4d(:,:,:,:) - end select - - end subroutine initialize - - !Search for the property along the array limits - recursive function binary_search(arraylimits, numberToFind, iGuess, iLow, iHigh) result(lowLimitIndex) - implicit none - real(r8), dimension(:),intent(in) :: arrayLimits !Limits along the axis we are searching - real(r8), intent(in) :: numberToFind !The property we are trying to find along the axis - - integer, intent(inout) :: iGuess !Guessed index - integer,intent(inout) :: iLow !Lowest possible index - integer, intent(inout) :: iHigh !Highest possible index - - integer :: lowLimitIndex - - if(numberToFind .lt. arrayLimits(iGuess))then - iHigh = iGuess - iGuess = int(0.5_r8*(iLow+iHigh)) - lowLimitIndex=binary_search(arrayLimits, numberToFind, iGuess, iLow, iHigh) - else if (numberToFind .gt. arrayLimits(iGuess+1))then - iLow = iGuess+1 - iGuess = int(0.5_r8*(iLow+iHigh)) - lowLimitIndex = binary_search(arrayLimits, numberToFind, iGuess, iLow, iHigh) - else !property is between iGuess and iGuess+1 ==> we are ok - lowLimitIndex = iLow - end if - end function binary_search - - - !Search and obtain the value - function searchGetValue(table, axisValuesToFind ) RESULT(output) - implicit none - TYPE(ptaero_table_t), intent(in) :: table - real(r8), dimension(:), intent(in) :: axisValuesToFind !array of numbers on axis - - !local variables - integer, dimension(max_table_rank) :: lowLimit !index of axis value below - integer, dimension(max_table_rank) :: highLimit !index of axis value above - real(r8), dimension(max_table_rank):: lowFraction - real(r8), dimension(max_table_rank):: highFraction - real(r8) :: output - - integer :: iGuess - integer :: iLow - integer :: iHigh - integer :: i - - !Get the indexes in question - do i = 1, table%rank - iLow=1 - iHigh = table%dims(i) - iGuess = int(0.5_r8*(iLow+iHigh)) !Guess middle value - lowLimit(i) = binary_search(table%axisValues(i)%values, axisValuesToFind(i), iGuess, iLow, iHigh ) - highLimit(i) = lowLimit(i)+1 - end do - - do i=1,table%rank - !High fraction is distance to low value divided by total distance - highFraction(i) = (axisValuesToFind(i)-table%axisValues(i)%values(lowLimit(i))) & - /(table%axisValues(i)%values(highLimit(i)) - table%axisValues(i)%values(lowLimit(i))) - !Low fraction is one minus high - lowFraction(i) = 1.0_r8 - highFraction(i) - end do - - !Interpolate along table limits - call interpolate(table, lowLimit, highLimit, lowFraction, highFraction,output) - - end function searchGetValue - - - !****************************************************************** - !Interpolate given that you know which indexes you are interested in - subroutine interpolate(table, lowLimits, highLimits, lowFraction, highFraction,answer) - implicit none - type(ptaero_table_t),intent(in) :: table - integer, intent(in), dimension(:) :: lowLimits - integer, intent(in), dimension(:) :: highLimits - real(r8), intent(in), dimension(:) :: lowFraction - real(r8), intent(in), dimension(:) :: highFraction - real(r8), intent(out) :: answer - - real(r8) , dimension(2,2,2) :: tmp3D - real(r8) , dimension(2,2) :: tmp2D - real(r8) , dimension(2) :: tmp1D - - if(table%rank .eq. 3) then - call extract3D(table%values(:,:,:,1), tmp3D, lowLimits, highLimits) - call interpolate3D(tmp3D, tmp2D, tmp1d, answer, highFraction, lowFraction) - elseif(table%rank .eq. 2) then - !call extract2D(table%values(:,:,1,1), tmp2D, lowLimits, highLimits) - call interpolate2D(tmp2D, tmp1d, answer, lowFraction, highFraction) - else if (table%rank .eq. 1)then - !call extract1D(table%values(:,1,1,1,1), tmp1D, lowLimits, highLimits) - call interpolate1D(tmp1D, answer, lowFraction, highFraction) - end if - - end subroutine - - !Extract a compact 3D-array from the table - subroutine extract3D(tmpIn, tmpOut, lowLimits, highLimits) - implicit none - real(r8), dimension(:,:,:),intent(in) :: tmpIn !Full data array - real(r8), dimension(2,2,2),intent(out) :: tmpOut !Extracted, condensed array - integer, dimension(:) :: lowLimits - integer, dimension(:) :: highLImits - - tmpOut(1,1,1)=tmpIn(lowLimits(1),lowLimits(2),lowLimits(3)) - tmpOut(1,1,2)=tmpIn(lowLimits(1),lowLimits(2),highLimits(3)) - - tmpOut(1,2,1)=tmpIn(lowLimits(1),highLimits(2),lowLimits(3)) - tmpOut(1,2,2)=tmpIn(lowLimits(1),highLimits(2),highLimits(3)) - - tmpOut(2,1,1)=tmpIn(highLimits(1),lowLimits(2),lowLimits(3)) - tmpOut(2,1,2)=tmpIn(highLimits(1),lowLimits(2),highLimits(3)) - - tmpOut(2,2,1)=tmpIn(highLimits(1),highLimits(2),lowLimits(3)) - tmpOut(2,2,2)=tmpIn(highLimits(1),highLimits(2),highLimits(3)) - end subroutine - - !Remove dimension 3 and send back a 2d-array - subroutine interpolate3D(tmp3D, tmp2D, tmp1d, answer, lowFraction, highFraction) - implicit none - real(r8), dimension(2,2,2), intent(in) :: tmp3D - real(r8), dimension(2,2),intent(inout) :: tmp2D - real(r8), dimension(2), intent(inout) :: tmp1d - real(r8) :: answer - real(r8), intent(in), dimension(:) :: highFraction - real(r8), intent(in), dimension(:) :: lowFraction - - tmp2D(1,1) = lowFraction(3)*tmp3D(1,1,1) + highFraction(3)*tmp3D(1,1,2) - tmp2D(1,2) = lowFraction(3)*tmp3D(1,2,1) + highFraction(3)*tmp3D(1,2,2) - tmp2D(2,1) = lowFraction(3)*tmp3D(2,1,1) + highFraction(3)*tmp3D(2,1,2) - tmp2D(2,2) = lowFraction(3)*tmp3D(2,2,1) + highFraction(3)*tmp3D(2,2,2) - - call interpolate2D(tmp2D, tmp1D, answer, lowFraction, highFraction) - - end subroutine - - !Remove dimension 2 and send back a 1d-array - subroutine interpolate2D(tmp2D, tmp1D, answer, lowFraction, highFraction) - implicit none - real(r8), dimension(2,2),intent(in) :: tmp2D - real(r8), dimension(2), intent(inout) :: tmp1D - real(r8), dimension(:), intent(in) :: lowFraction - real(r8), dimension(:), intent(in) :: highFraction - real(r8),intent(out) :: answer - - tmp1D(1) = lowFraction(2)*tmp2D(1,1) + highFraction(2)*tmp2D(1,2) - tmp1D(2) = lowFraction(2)*tmp2D(2,1) + highFraction(2)*tmp2D(2,2) - - call interpolate1D(tmp1D, answer, lowFraction, highFraction) - end subroutine interpolate2D - - !Interpolate a 1d-array - subroutine interpolate1D(tmp1D, answer, lowFraction, highFraction) - implicit none - real(r8), intent(in), dimension(2) :: tmp1D - real(r8), intent(out) :: answer - real(r8), intent(in), dimension(:) :: lowFraction - real(r8), intent(in), dimension(:) :: highFraction - - answer = lowFraction(1)*tmp1D(1) + highFraction(1)*tmp1D(2) - end subroutine interpolate1D - -end module ptaero_table diff --git a/src/physics/cam_oslo/table_manager.F90 b/src/physics/cam_oslo/table_manager.F90 deleted file mode 100644 index 6f91a8459d..0000000000 --- a/src/physics/cam_oslo/table_manager.F90 +++ /dev/null @@ -1,95 +0,0 @@ -module table_manager - - use ptaero_table - use commondefinitions - use aerosoldef !for the mixture ids - - integer, parameter, public :: table_property_dry_radius=1 - integer, parameter, public :: table_property_sigma=2 - integer, parameter :: max_number_of_properties=10 !Max # properties for a mixture - - TYPE(ptaero_table_t), target, dimension(max_number_of_properties*(nmodes+1)) :: property_table - - integer, dimension(0:nmodes,max_number_of_properties) :: property_table_index - integer, save :: last_used_index=0 - -contains - - subroutine initialize_tables() - implicit none - integer :: i - - last_used_index = 0 - property_table_index(:,:) = -1 !Negative index means un-used - - do i=1,SIZE(property_table) - !Construct an empty property table - call construct(property_table(i)) - end do - - end subroutine initialize_tables - - !Registers a look-up table - subroutine register_table(mixture_id, property_id, data2D, data3D, data4D, axis1, axis2, axis3, axis4) - implicit none - integer, intent(in) :: mixture_id - integer, intent(in) :: property_id - real(r8), dimension(:,:), intent(in), optional :: data2D - real(r8), dimension(:,:,:), intent(in), optional :: data3D - real(r8), dimension(:,:,:,:), intent(in), optional :: data4D - real(r8), intent(in), dimension(:),optional :: axis1 - real(r8), intent(in), dimension(:),optional :: axis2 - real(r8), intent(in), dimension(:),optional :: axis3 - real(r8), intent(in), dimension(:),optional :: axis4 - - !Increase the number of tables we are keeping track of.. - last_used_index = last_used_index + 1 - - !Remember the placement of this table - property_table_index(mixture_id, property_id) = last_used_index - - !Need to check for what kind of data the table contains.. - if(present(data2D))then - call initialize(property_table(last_used_index) & !This is the table we are initializing - , mixture_id & !id of the mixture - , property_id & !id of the property - , limits1=axis1 & !axis limits (grid) of first axis - , limits2=axis2 & !axis limits (grid) of second axis - , data2d=data2d & !the 2d-data of the table - ) - else if(present(data3D))then - call initialize(property_table(last_used_index) & !This is the table we are initializing - , mixture_id & !id of the mixture - , property_id & !id of the property - , limits1=axis1 & !axis limits (grid) of first axis - , limits2=axis2 & !axis limits (grid) of second axis - , limits3=axis3 & !axis limits (grid) of third axis - , data3d=data3d & !the 2d-data of the table - ) - else if(present(data4D))then - call initialize(property_table(last_used_index) & !This is the table we are initializing - , mixture_id & !id of the mixture - , property_id & !id of the property - , limits1=axis1 & !axis limits (grid) of first axis - , limits2=axis2 & !axis limits (grid) of second axis - , limits3=axis3 & !axis limits (grid) of third axis - , limits4=axis3 & !axis limits (grid) of third axis - , data4d=data4d & !the 2d-data of the table - ) - end if - - end subroutine register_table - - function get_table_pointer(mixture_id, property_id)RESULT(table_pointer) - integer,intent(in) :: mixture_id - integer,intent(in) :: property_id - TYPE(ptaero_table_t), pointer :: table_pointer - - nullify(table_pointer) - - table_pointer=>property_table(property_table_index(mixture_id, property_id)) - - end function - - -end module table_manager From 884089137beb787e257ad81af0c0b8ec787d4607 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 16 Aug 2023 19:27:18 +0200 Subject: [PATCH 08/71] more removal of #ifdef OSLO_AERO --- src/chemistry/oslo_aero/microp_aero.F90 | 1448 ++++---- src/chemistry/oslo_aero/mo_chm_diags.F90 | 349 +- src/chemistry/oslo_aero/mo_drydep.F90 | 7 - src/chemistry/oslo_aero/mo_setsox.F90 | 43 +- src/chemistry/oslo_aero/mo_srf_emissions.F90 | 2 - src/chemistry/oslo_aero/mo_usrrxt.F90 | 17 +- src/chemistry/oslo_aero/parmix_progncdnc.F90 | 91 - .../oslo_aero/vertical_diffusion.F90 | 2982 ++++++++--------- 8 files changed, 2211 insertions(+), 2728 deletions(-) diff --git a/src/chemistry/oslo_aero/microp_aero.F90 b/src/chemistry/oslo_aero/microp_aero.F90 index 895892b557..6086b59139 100644 --- a/src/chemistry/oslo_aero/microp_aero.F90 +++ b/src/chemistry/oslo_aero/microp_aero.F90 @@ -1,907 +1,635 @@ module microp_aero -!--------------------------------------------------------------------------------- -! Purpose: -! CAM driver layer for aerosol activation processes. -! -! ***N.B.*** This module is currently hardcoded to recognize only the aerosols/modes that -! affect the climate calculation. This is implemented by using list -! index 0 in all the calls to rad_constituent interfaces. -! -! Author: Andrew Gettelman -! Based on code from: Hugh Morrison, Xiaohong Liu and Steve Ghan -! May 2010 -! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) -! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) -! for questions contact Andrew Gettelman (andrew@ucar.edu) -! Modifications: A. Gettelman Nov 2010 - changed to support separation of -! microphysics and macrophysics and concentrate aerosol information here -! B. Eaton, Sep 2014 - Refactored to move CAM interface code into the CAM -! interface modules and preserve just the driver layer functionality here. -! -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver, pverp -use ref_pres, only: top_lev => trop_cloud_top_lev -use physconst, only: rair -use constituents, only: cnst_get_ind -use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum, & - physics_state_copy, physics_update -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field -use phys_control, only: phys_getopts, use_hetfrz_classnuc -use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, & - rad_cnst_get_mode_num -#ifndef OSLO_AERO -use nucleate_ice_cam, only: use_preexisting_ice, nucleate_ice_cam_readnl, nucleate_ice_cam_register, & - nucleate_ice_cam_init, nucleate_ice_cam_calc -#endif + !--------------------------------------------------------------------------------- + ! Purpose: + ! CAM driver layer for aerosol activation processes. + ! + ! ***N.B.*** This module is currently hardcoded to recognize only the aerosols/modes that + ! affect the climate calculation. This is implemented by using list + ! index 0 in all the calls to rad_constituent interfaces. + ! + ! Author: Andrew Gettelman + ! Based on code from: Hugh Morrison, Xiaohong Liu and Steve Ghan + ! May 2010 + ! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) + ! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) + ! for questions contact Andrew Gettelman (andrew@ucar.edu) + ! Modifications: A. Gettelman Nov 2010 - changed to support separation of + ! microphysics and macrophysics and concentrate aerosol information here + ! B. Eaton, Sep 2014 - Refactored to move CAM interface code into the CAM + ! interface modules and preserve just the driver layer functionality here. + ! + !--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp + use ref_pres, only: top_lev => trop_cloud_top_lev + use physconst, only: rair + use constituents, only: cnst_get_ind + use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum, & + physics_state_copy, physics_update + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field + use phys_control, only: phys_getopts, use_hetfrz_classnuc + use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, & + rad_cnst_get_mode_num + + use ndrop, only: ndrop_init, dropmixnuc + use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn + + use cam_history, only: addfld, add_default, outfld + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC & + ,MODE_IDX_OMBC_INTMIX_COAT_AIT, lifeCycleNumberMedianRadius, & + l_dst_a2, l_dst_a3, l_bc_ai, getNumberOfTracersInMode, & + getTracerIndex, getCloudTracerIndex + use oslo_utils, only: CalculateNumberConcentration + use parmix_progncdnc + use hetfrz_classnuc_oslo + use nucleate_ice_oslo + + implicit none + private + + public :: microp_aero_init, microp_aero_run, microp_aero_readnl, microp_aero_register + + ! Private module data + + character(len=16) :: eddy_scheme + + ! contact freezing due to dust + ! dust number mean radius (m), Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 + real(r8), parameter :: rn_dst1 = 0.258e-6_r8 + real(r8), parameter :: rn_dst2 = 0.717e-6_r8 + real(r8), parameter :: rn_dst3 = 1.576e-6_r8 + real(r8), parameter :: rn_dst4 = 3.026e-6_r8 + + real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor + + ! smallest mixing ratio considered in microphysics + real(r8), parameter :: qsmall = 1.e-18_r8 + + ! minimum allowed cloud fraction + real(r8), parameter :: mincld = 0.0001_r8 + + ! indices in state%q and pbuf structures + integer :: cldliq_idx = -1 + integer :: cldice_idx = -1 + integer :: numliq_idx = -1 + integer :: numice_idx = -1 + integer :: kvh_idx = -1 + integer :: tke_idx = -1 + integer :: wp2_idx = -1 + integer :: ast_idx = -1 + integer :: cldo_idx = -1 + integer :: dgnumwet_idx = -1 + + ! Bulk aerosols + character(len=20), allocatable :: aername(:) + real(r8), allocatable :: num_to_mass_aer(:) + + integer :: naer_all ! number of aerosols affecting climate + integer :: idxsul = -1 ! index in aerosol list for sulfate + integer :: idxdst2 = -1 ! index in aerosol list for dust2 + integer :: idxdst3 = -1 ! index in aerosol list for dust3 + integer :: idxdst4 = -1 ! index in aerosol list for dust4 + + ! modal aerosols + logical :: clim_modal_aero + + integer :: mode_accum_idx = -1 ! index of accumulation mode + integer :: mode_aitken_idx = -1 ! index of aitken mode + integer :: mode_coarse_idx = -1 ! index of coarse mode + integer :: mode_coarse_dst_idx = -1 ! index of coarse dust mode + integer :: mode_coarse_slt_idx = -1 ! index of coarse sea salt mode + integer :: coarse_dust_idx = -1 ! index of dust in coarse mode + integer :: coarse_nacl_idx = -1 ! index of nacl in coarse mode + integer :: coarse_so4_idx = -1 ! index of sulfate in coarse mode + + integer :: npccn_idx, rndst_idx, nacon_idx + + logical :: separate_dust = .false. + + !========================================================================================= +contains + !========================================================================================= -use ndrop, only: ndrop_init, dropmixnuc -use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn + subroutine microp_aero_register + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Register pbuf fields for aerosols needed by microphysics + ! + ! Author: Cheryl Craig October 2012 + ! + !----------------------------------------------------------------------- + use ppgrid, only: pcols + use physics_buffer, only: pbuf_add_field, dtype_r8 -#ifndef OSLO_AERO -use hetfrz_classnuc_cam, only: hetfrz_classnuc_cam_readnl, hetfrz_classnuc_cam_register, hetfrz_classnuc_cam_init, & - hetfrz_classnuc_cam_save_cbaero, hetfrz_classnuc_cam_calc + call pbuf_add_field('NPCCN', 'physpkg',dtype_r8,(/pcols,pver/), npccn_idx) -#endif -use cam_history, only: addfld, add_default, outfld -use cam_logfile, only: iulog -use cam_abortutils, only: endrun - - -#ifdef OSLO_AERO -use commondefinitions, only: nmodes_oslo => nmodes -use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC & - ,MODE_IDX_OMBC_INTMIX_COAT_AIT, lifeCycleNumberMedianRadius, & - l_dst_a2, l_dst_a3, l_bc_ai, getNumberOfTracersInMode, & - getTracerIndex, getCloudTracerIndex -use oslo_utils, only: CalculateNumberConcentration -use parmix_progncdnc -use hetfrz_classnuc_oslo -use nucleate_ice_oslo -#endif + call pbuf_add_field('RNDST', 'physpkg',dtype_r8,(/pcols,pver,4/), rndst_idx) + call pbuf_add_field('NACON', 'physpkg',dtype_r8,(/pcols,pver,4/), nacon_idx) -implicit none -private -save + call nucleate_ice_oslo_register() + call hetfrz_classnuc_oslo_register() -public :: microp_aero_init, microp_aero_run, microp_aero_readnl, microp_aero_register + end subroutine microp_aero_register -! Private module data + !========================================================================================= -character(len=16) :: eddy_scheme + subroutine microp_aero_init -! contact freezing due to dust -! dust number mean radius (m), Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 -real(r8), parameter :: rn_dst1 = 0.258e-6_r8 -real(r8), parameter :: rn_dst2 = 0.717e-6_r8 -real(r8), parameter :: rn_dst3 = 1.576e-6_r8 -real(r8), parameter :: rn_dst4 = 3.026e-6_r8 + !----------------------------------------------------------------------- + ! + ! Purpose: + ! Initialize constants for aerosols needed by microphysics + ! + ! Author: Andrew Gettelman May 2010 + ! + !----------------------------------------------------------------------- -real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor + ! local variables + integer :: iaer, ierr + integer :: m, n, nmodes, nspec -! smallest mixing ratio considered in microphysics -real(r8), parameter :: qsmall = 1.e-18_r8 + character(len=32) :: str32 + character(len=*), parameter :: routine = 'microp_aero_init' + logical :: history_amwg + !----------------------------------------------------------------------- -! minimum allowed cloud fraction -real(r8), parameter :: mincld = 0.0001_r8 + ! Query the PBL eddy scheme + call phys_getopts(eddy_scheme_out = eddy_scheme, & + history_amwg_out = history_amwg ) -! indices in state%q and pbuf structures -integer :: cldliq_idx = -1 -integer :: cldice_idx = -1 -integer :: numliq_idx = -1 -integer :: numice_idx = -1 -integer :: kvh_idx = -1 -integer :: tke_idx = -1 -integer :: wp2_idx = -1 -integer :: ast_idx = -1 -integer :: cldo_idx = -1 -integer :: dgnumwet_idx = -1 + ! Access the physical properties of the aerosols that are affecting the climate + ! by using routines from the rad_constituents module. -! Bulk aerosols -character(len=20), allocatable :: aername(:) -real(r8), allocatable :: num_to_mass_aer(:) + ! get indices into state and pbuf structures + call cnst_get_ind('CLDLIQ', cldliq_idx) + call cnst_get_ind('CLDICE', cldice_idx) + call cnst_get_ind('NUMLIQ', numliq_idx) + call cnst_get_ind('NUMICE', numice_idx) -integer :: naer_all ! number of aerosols affecting climate -integer :: idxsul = -1 ! index in aerosol list for sulfate -integer :: idxdst2 = -1 ! index in aerosol list for dust2 -integer :: idxdst3 = -1 ! index in aerosol list for dust3 -integer :: idxdst4 = -1 ! index in aerosol list for dust4 + select case(trim(eddy_scheme)) + case ('diag_TKE') + tke_idx = pbuf_get_index('tke') + case ('CLUBB_SGS') + wp2_idx = pbuf_get_index('WP2_nadv') + case default + kvh_idx = pbuf_get_index('kvh') + end select -! modal aerosols -logical :: clim_modal_aero + ! clim_modal_aero determines whether modal aerosols are used in the climate calculation. + ! The modal aerosols can be either prognostic or prescribed. + call rad_cnst_get_info(0, nmodes=nmodes) + clim_modal_aero = (nmodes > 0) -integer :: mode_accum_idx = -1 ! index of accumulation mode -integer :: mode_aitken_idx = -1 ! index of aitken mode -integer :: mode_coarse_idx = -1 ! index of coarse mode -integer :: mode_coarse_dst_idx = -1 ! index of coarse dust mode -integer :: mode_coarse_slt_idx = -1 ! index of coarse sea salt mode -integer :: coarse_dust_idx = -1 ! index of dust in coarse mode -integer :: coarse_nacl_idx = -1 ! index of nacl in coarse mode -integer :: coarse_so4_idx = -1 ! index of sulfate in coarse mode + ast_idx = pbuf_get_index('AST') -integer :: npccn_idx, rndst_idx, nacon_idx + cldo_idx = pbuf_get_index('CLDO') + clim_modal_aero = .true. !Needed to avoid ending up in BAM routines -logical :: separate_dust = .false. + call ndrop_init() -!========================================================================================= -contains -!========================================================================================= - -subroutine microp_aero_register - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Register pbuf fields for aerosols needed by microphysics - ! - ! Author: Cheryl Craig October 2012 - ! - !----------------------------------------------------------------------- - use ppgrid, only: pcols - use physics_buffer, only: pbuf_add_field, dtype_r8 - - call pbuf_add_field('NPCCN', 'physpkg',dtype_r8,(/pcols,pver/), npccn_idx) - - call pbuf_add_field('RNDST', 'physpkg',dtype_r8,(/pcols,pver,4/), rndst_idx) - call pbuf_add_field('NACON', 'physpkg',dtype_r8,(/pcols,pver,4/), nacon_idx) - - call nucleate_ice_oslo_register() - call hetfrz_classnuc_oslo_register() - -end subroutine microp_aero_register - -!========================================================================================= - -subroutine microp_aero_init - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Initialize constants for aerosols needed by microphysics - ! - ! Author: Andrew Gettelman May 2010 - ! - !----------------------------------------------------------------------- - - ! local variables - integer :: iaer, ierr - integer :: m, n, nmodes, nspec - - character(len=32) :: str32 - character(len=*), parameter :: routine = 'microp_aero_init' - logical :: history_amwg - !----------------------------------------------------------------------- - - ! Query the PBL eddy scheme - call phys_getopts(eddy_scheme_out = eddy_scheme, & - history_amwg_out = history_amwg ) - - ! Access the physical properties of the aerosols that are affecting the climate - ! by using routines from the rad_constituents module. - - ! get indices into state and pbuf structures - call cnst_get_ind('CLDLIQ', cldliq_idx) - call cnst_get_ind('CLDICE', cldice_idx) - call cnst_get_ind('NUMLIQ', numliq_idx) - call cnst_get_ind('NUMICE', numice_idx) - - select case(trim(eddy_scheme)) - case ('diag_TKE') - tke_idx = pbuf_get_index('tke') - case ('CLUBB_SGS') - wp2_idx = pbuf_get_index('WP2_nadv') - case default - kvh_idx = pbuf_get_index('kvh') - end select - - ! clim_modal_aero determines whether modal aerosols are used in the climate calculation. - ! The modal aerosols can be either prognostic or prescribed. - call rad_cnst_get_info(0, nmodes=nmodes) - clim_modal_aero = (nmodes > 0) - - ast_idx = pbuf_get_index('AST') - -#if (defined OSLO_AERO) - cldo_idx = pbuf_get_index('CLDO') - clim_modal_aero = .true. !Needed to avoid ending up in BAM routines - - call ndrop_init() -#else - if (clim_modal_aero) then - - cldo_idx = pbuf_get_index('CLDO') - dgnumwet_idx = pbuf_get_index('DGNUMWET') - - call ndrop_init() - - ! Init indices for specific modes/species - - ! mode index for specified mode types - do m = 1, nmodes - call rad_cnst_get_info(0, m, mode_type=str32) - select case (trim(str32)) - case ('accum') - mode_accum_idx = m - case ('aitken') - mode_aitken_idx = m - case ('coarse') - mode_coarse_idx = m - case ('coarse_dust') - mode_coarse_dst_idx = m - case ('coarse_seasalt') - mode_coarse_slt_idx = m - end select - end do - - ! check if coarse dust is in separate mode - separate_dust = mode_coarse_dst_idx > 0 - - ! for 3-mode - if ( mode_coarse_dst_idx<0 ) mode_coarse_dst_idx = mode_coarse_idx - if ( mode_coarse_slt_idx<0 ) mode_coarse_slt_idx = mode_coarse_idx - - ! Check that required mode types were found - if (mode_accum_idx == -1 .or. mode_aitken_idx == -1 .or. & - mode_coarse_dst_idx == -1.or. mode_coarse_slt_idx == -1) then - write(iulog,*) routine//': ERROR required mode type not found - mode idx:', & - mode_accum_idx, mode_aitken_idx, mode_coarse_dst_idx, mode_coarse_slt_idx - call endrun(routine//': ERROR required mode type not found') - end if - - ! species indices for specified types - ! find indices for the dust and seasalt species in the coarse mode - call rad_cnst_get_info(0, mode_coarse_dst_idx, nspec=nspec) - do n = 1, nspec - call rad_cnst_get_info(0, mode_coarse_dst_idx, n, spec_type=str32) - select case (trim(str32)) - case ('dust') - coarse_dust_idx = n - end select - end do - call rad_cnst_get_info(0, mode_coarse_slt_idx, nspec=nspec) - do n = 1, nspec - call rad_cnst_get_info(0, mode_coarse_slt_idx, n, spec_type=str32) - select case (trim(str32)) - case ('seasalt') - coarse_nacl_idx = n - end select - end do - if (mode_coarse_idx>0) then - call rad_cnst_get_info(0, mode_coarse_idx, nspec=nspec) - do n = 1, nspec - call rad_cnst_get_info(0, mode_coarse_idx, n, spec_type=str32) - select case (trim(str32)) - case ('sulfate') - coarse_so4_idx = n - end select - end do - endif - - ! Check that required mode specie types were found - if ( coarse_dust_idx == -1 .or. coarse_nacl_idx == -1 ) then - write(iulog,*) routine//': ERROR required mode-species type not found - indicies:', & - coarse_dust_idx, coarse_nacl_idx - call endrun(routine//': ERROR required mode-species type not found') - end if - - else - - ! Props needed for BAM number concentration calcs. - - call rad_cnst_get_info(0, naero=naer_all) - allocate( & - aername(naer_all), & - num_to_mass_aer(naer_all) ) - - do iaer = 1, naer_all - call rad_cnst_get_aer_props(0, iaer, & - aername = aername(iaer), & - num_to_mass_aer = num_to_mass_aer(iaer) ) - - ! Look for sulfate, dust, and soot in this list (Bulk aerosol only) - if (trim(aername(iaer)) == 'SULFATE') idxsul = iaer - if (trim(aername(iaer)) == 'DUST2') idxdst2 = iaer - if (trim(aername(iaer)) == 'DUST3') idxdst3 = iaer - if (trim(aername(iaer)) == 'DUST4') idxdst4 = iaer - end do - - call ndrop_bam_init() - - end if - -#endif - - call addfld('LCLOUD', (/ 'lev' /), 'A', ' ', 'Liquid cloud fraction used in stratus activation') - - call addfld('WSUB', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity' ) - call addfld('WSUBI', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity for ice' ) - - if (history_amwg) then - call add_default ('WSUB ', 1, ' ') - end if - - call nucleate_ice_oslo_init(mincld, bulk_scale) - call hetfrz_classnuc_oslo_init(mincld) - -end subroutine microp_aero_init - -!========================================================================================= - -subroutine microp_aero_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use mpishorthand - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Namelist variables - real(r8) :: microp_aero_bulk_scale = 2._r8 ! prescribed aerosol bulk sulfur scale factor - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'microp_aero_readnl' - - namelist /microp_aero_nl/ microp_aero_bulk_scale - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'microp_aero_nl', status=ierr) - if (ierr == 0) then - read(unitn, microp_aero_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if + call addfld('LCLOUD', (/ 'lev' /), 'A', ' ', 'Liquid cloud fraction used in stratus activation') -#ifdef SPMD - ! Broadcast namelist variable - call mpibcast(microp_aero_bulk_scale, 1, mpir8, 0, mpicom) -#endif + call addfld('WSUB', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity' ) + call addfld('WSUBI', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity for ice' ) - ! set local variables - bulk_scale = microp_aero_bulk_scale - - call nucleate_ice_oslo_readnl(nlfile) - call hetfrz_classnuc_oslo_readnl(nlfile) - -end subroutine microp_aero_readnl - -!========================================================================================= - -subroutine microp_aero_run ( & - state, ptend_all, deltatin, pbuf) - - ! input arguments - type(physics_state), intent(in) :: state - type(physics_ptend), intent(out) :: ptend_all - real(r8), intent(in) :: deltatin ! time step (s) - type(physics_buffer_desc), pointer :: pbuf(:) - - ! local workspace - ! all units mks unless otherwise stated - - integer :: i, k, m - integer :: itim_old - integer :: nmodes - - type(physics_state) :: state1 ! Local copy of state variable - type(physics_ptend) :: ptend_loc - - real(r8), pointer :: ast(:,:) - - real(r8), pointer :: npccn(:,:) ! number of CCN (liquid activated) - - real(r8), pointer :: rndst(:,:,:) ! radius of 4 dust bins for contact freezing - real(r8), pointer :: nacon(:,:,:) ! number in 4 dust bins for contact freezing - - real(r8), pointer :: num_coarse(:,:) ! number m.r. of coarse mode - real(r8), pointer :: coarse_dust(:,:) ! mass m.r. of coarse dust - real(r8), pointer :: coarse_nacl(:,:) ! mass m.r. of coarse nacl - real(r8), pointer :: coarse_so4(:,:) ! mass m.r. of coarse sulfate - - real(r8), pointer :: kvh(:,:) ! vertical eddy diff coef (m2 s-1) - real(r8), pointer :: tke(:,:) ! TKE from the UW PBL scheme (m2 s-2) - real(r8), pointer :: wp2(:,:) ! CLUBB vertical velocity variance - - real(r8), pointer :: cldn(:,:) ! cloud fraction - real(r8), pointer :: cldo(:,:) ! old cloud fraction - - real(r8), pointer :: dgnumwet(:,:,:) ! aerosol mode diameter - - real(r8), pointer :: aer_mmr(:,:) ! aerosol mass mixing ratio - - real(r8) :: rho(pcols,pver) ! air density (kg m-3) - - real(r8) :: lcldm(pcols,pver) ! liq cloud fraction - - real(r8) :: lcldn(pcols,pver) ! fractional coverage of new liquid cloud - real(r8) :: lcldo(pcols,pver) ! fractional coverage of old liquid cloud - real(r8) :: cldliqf(pcols,pver) ! fractional of total cloud that is liquid - real(r8) :: qcld ! total cloud water - real(r8) :: nctend_mixnuc(pcols,pver) - real(r8) :: dum, dum2 ! temporary dummy variable - real(r8) :: dmc, ssmc, so4mc ! variables for modal scheme. - integer :: dst_idx, num_idx - - ! bulk aerosol variables - real(r8), allocatable :: naer2(:,:,:) ! bulk aerosol number concentration (1/m3) - real(r8), allocatable :: maerosol(:,:,:) ! bulk aerosol mass conc (kg/m3) - - real(r8) :: wsub(pcols,pver) ! diagnosed sub-grid vertical velocity st. dev. (m/s) - real(r8) :: wsubi(pcols,pver) ! diagnosed sub-grid vertical velocity ice (m/s) - real(r8) :: nucboas - - real(r8) :: wght - - integer :: lchnk, ncol - - !++ MH_2015/04/10 - real(r8) :: factnum(pcols,pver,0:nmodes_oslo) ! activation fraction for aerosol number - type qqcw_type - real(r8), pointer :: fldcw(:,:) - end type qqcw_type - type(qqcw_type) :: qqcw(pcnst) - real(r8) :: qaercwpt(pcols,pver,pcnst) - integer :: kk - - !++ MH_2015/04/10 -#ifdef OSLO_AERO - logical :: hasAerosol(pcols, pver, nmodes_oslo) - real(r8) :: f_acm(pcols,pver, nmodes_oslo) - real(r8) :: f_bcm(pcols,pver, nmodes_oslo) - real(r8) :: f_aqm(pcols, pver, nmodes_oslo) - real(r8) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" - real(r8) :: f_soam(pcols, pver, nmodes_oslo) !Needed in "get component fraction" - real(r8) :: numberConcentration(pcols,pver,0:nmodes_oslo) ![#/m3] number concentraiton - real(r8) :: volumeConcentration(pcols,pver,nmodes_oslo) ![m3/m3] volume concentration - real(r8) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity - real(r8) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma - real(r8) :: CProcessModes(pcols,pver) - real(r8) :: cam(pcols,pver,nmodes_oslo) - real(r8) :: f_c(pcols, pver) - real(r8) :: f_aq(pcols,pver) - real(r8) :: f_bc(pcols,pver) - real(r8) :: f_so4_cond(pcols,pver) - real(r8) :: f_soa(pcols,pver) - real(r8) :: volumeCore(pcols,pver,nmodes_oslo) - real(r8) :: volumeCoat(pcols,pver,nmodes_oslo) - real(r8) :: sigmag_amode(3) - real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) - - real(r8) :: fn_bc(pcols,pver), fn_dst1(pcols,pver), fn_dst3(pcols,pver) - real(r8) :: hetraer_bc(pcols,pver), hetraer_dst1(pcols,pver), hetraer_dst3(pcols,pver) - real(r8) :: dstcoat_bc(pcols,pver), dstcoat_dst1(pcols,pver), dstcoat_dst3(pcols,pver) -#endif - !-- MH_2015/04/10 + if (history_amwg) then + call add_default ('WSUB ', 1, ' ') + end if - !------------------------------------------------------------------------------- + call nucleate_ice_oslo_init(mincld, bulk_scale) + call hetfrz_classnuc_oslo_init(mincld) - call physics_state_copy(state,state1) + end subroutine microp_aero_init - lchnk = state1%lchnk - ncol = state1%ncol + !========================================================================================= - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + subroutine microp_aero_readnl(nlfile) - call pbuf_get_field(pbuf, npccn_idx, npccn) + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use mpishorthand - call pbuf_get_field(pbuf, nacon_idx, nacon) - call pbuf_get_field(pbuf, rndst_idx, rndst) + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - call physics_ptend_init(ptend_all, state%psetcols, 'microp_aero') + ! Namelist variables + real(r8) :: microp_aero_bulk_scale = 2._r8 ! prescribed aerosol bulk sulfur scale factor - if (clim_modal_aero) then + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'microp_aero_readnl' - itim_old = pbuf_old_tim_idx() - - call pbuf_get_field(pbuf, ast_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + namelist /microp_aero_nl/ microp_aero_bulk_scale + !----------------------------------------------------------------------------- -#ifndef OSLO_AERO - call rad_cnst_get_info(0, nmodes=nmodes) - call pbuf_get_field(pbuf, dgnumwet_idx, dgnumwet, start=(/1,1,1/), kount=(/pcols,pver,nmodes/) ) + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'microp_aero_nl', status=ierr) + if (ierr == 0) then + read(unitn, microp_aero_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if - allocate(factnum(pcols,pver,nmodes)) +#ifdef SPMD + ! Broadcast namelist variable + call mpibcast(microp_aero_bulk_scale, 1, mpir8, 0, mpicom) #endif - end if - - ! initialize output - npccn(1:ncol,1:pver) = 0._r8 - - nacon(1:ncol,1:pver,:) = 0._r8 - - ! set default or fixed dust bins for contact freezing - rndst(1:ncol,1:pver,1) = rn_dst1 - rndst(1:ncol,1:pver,2) = rn_dst2 - rndst(1:ncol,1:pver,3) = rn_dst3 - rndst(1:ncol,1:pver,4) = rn_dst4 - - ! save copy of cloud borne aerosols for use in heterogeneous freezing - if (use_hetfrz_classnuc) then - call hetfrz_classnuc_oslo_save_cbaero(state, pbuf) - end if + ! set local variables + bulk_scale = microp_aero_bulk_scale + + call nucleate_ice_oslo_readnl(nlfile) + call hetfrz_classnuc_oslo_readnl(nlfile) + + end subroutine microp_aero_readnl + + !========================================================================================= + + subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) + + ! arguments + type(physics_state), intent(in) :: state + type(physics_ptend), intent(out) :: ptend_all + real(r8), intent(in) :: deltatin ! time step (s) + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local workspace + ! all units mks unless otherwise stated + + integer :: i, k, m + integer :: itim_old + integer :: nmodes + + type(physics_state) :: state1 ! Local copy of state variable + type(physics_ptend) :: ptend_loc + + real(r8), pointer :: ast(:,:) + + real(r8), pointer :: npccn(:,:) ! number of CCN (liquid activated) + + real(r8), pointer :: rndst(:,:,:) ! radius of 4 dust bins for contact freezing + real(r8), pointer :: nacon(:,:,:) ! number in 4 dust bins for contact freezing + + real(r8), pointer :: num_coarse(:,:) ! number m.r. of coarse mode + real(r8), pointer :: coarse_dust(:,:) ! mass m.r. of coarse dust + real(r8), pointer :: coarse_nacl(:,:) ! mass m.r. of coarse nacl + real(r8), pointer :: coarse_so4(:,:) ! mass m.r. of coarse sulfate + + real(r8), pointer :: kvh(:,:) ! vertical eddy diff coef (m2 s-1) + real(r8), pointer :: tke(:,:) ! TKE from the UW PBL scheme (m2 s-2) + real(r8), pointer :: wp2(:,:) ! CLUBB vertical velocity variance + + real(r8), pointer :: cldn(:,:) ! cloud fraction + real(r8), pointer :: cldo(:,:) ! old cloud fraction + + real(r8), pointer :: dgnumwet(:,:,:) ! aerosol mode diameter + + real(r8), pointer :: aer_mmr(:,:) ! aerosol mass mixing ratio + + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + + real(r8) :: lcldm(pcols,pver) ! liq cloud fraction + + real(r8) :: lcldn(pcols,pver) ! fractional coverage of new liquid cloud + real(r8) :: lcldo(pcols,pver) ! fractional coverage of old liquid cloud + real(r8) :: cldliqf(pcols,pver) ! fractional of total cloud that is liquid + real(r8) :: qcld ! total cloud water + real(r8) :: nctend_mixnuc(pcols,pver) + real(r8) :: dum, dum2 ! temporary dummy variable + real(r8) :: dmc, ssmc, so4mc ! variables for modal scheme. + integer :: dst_idx, num_idx + + ! bulk aerosol variables + real(r8), allocatable :: naer2(:,:,:) ! bulk aerosol number concentration (1/m3) + real(r8), allocatable :: maerosol(:,:,:) ! bulk aerosol mass conc (kg/m3) + + real(r8) :: wsub(pcols,pver) ! diagnosed sub-grid vertical velocity st. dev. (m/s) + real(r8) :: wsubi(pcols,pver) ! diagnosed sub-grid vertical velocity ice (m/s) + real(r8) :: nucboas + + real(r8) :: wght + + integer :: lchnk, ncol + + !++ MH_2015/04/10 + real(r8) :: factnum(pcols,pver,0:nmodes_oslo) ! activation fraction for aerosol number + type qqcw_type + real(r8), pointer :: fldcw(:,:) + end type qqcw_type + type(qqcw_type) :: qqcw(pcnst) + real(r8) :: qaercwpt(pcols,pver,pcnst) + integer :: kk + logical :: hasAerosol(pcols, pver, nmodes_oslo) + real(r8) :: f_acm(pcols,pver, nmodes_oslo) + real(r8) :: f_bcm(pcols,pver, nmodes_oslo) + real(r8) :: f_aqm(pcols, pver, nmodes_oslo) + real(r8) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" + real(r8) :: f_soam(pcols, pver, nmodes_oslo) !Needed in "get component fraction" + real(r8) :: numberConcentration(pcols,pver,0:nmodes_oslo) ![#/m3] number concentraiton + real(r8) :: volumeConcentration(pcols,pver,nmodes_oslo) ![m3/m3] volume concentration + real(r8) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity + real(r8) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma + real(r8) :: CProcessModes(pcols,pver) + real(r8) :: cam(pcols,pver,nmodes_oslo) + real(r8) :: f_c(pcols, pver) + real(r8) :: f_aq(pcols,pver) + real(r8) :: f_bc(pcols,pver) + real(r8) :: f_so4_cond(pcols,pver) + real(r8) :: f_soa(pcols,pver) + real(r8) :: volumeCore(pcols,pver,nmodes_oslo) + real(r8) :: volumeCoat(pcols,pver,nmodes_oslo) + real(r8) :: sigmag_amode(3) + real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) + real(r8) :: fn_bc(pcols,pver), fn_dst1(pcols,pver), fn_dst3(pcols,pver) + real(r8) :: hetraer_bc(pcols,pver), hetraer_dst1(pcols,pver), hetraer_dst3(pcols,pver) + real(r8) :: dstcoat_bc(pcols,pver), dstcoat_dst1(pcols,pver), dstcoat_dst3(pcols,pver) + !------------------------------------------------------------------------------- + + call physics_state_copy(state,state1) + + lchnk = state1%lchnk + ncol = state1%ncol + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, npccn_idx, npccn) + call pbuf_get_field(pbuf, nacon_idx, nacon) + call pbuf_get_field(pbuf, rndst_idx, rndst) + + call physics_ptend_init(ptend_all, state%psetcols, 'microp_aero') + + if (clim_modal_aero) then + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + end if + + ! initialize output + npccn(1:ncol,1:pver) = 0._r8 + + nacon(1:ncol,1:pver,:) = 0._r8 + + ! set default or fixed dust bins for contact freezing + rndst(1:ncol,1:pver,1) = rn_dst1 + rndst(1:ncol,1:pver,2) = rn_dst2 + rndst(1:ncol,1:pver,3) = rn_dst3 + rndst(1:ncol,1:pver,4) = rn_dst4 + + ! save copy of cloud borne aerosols for use in heterogeneous freezing + if (use_hetfrz_classnuc) then + call hetfrz_classnuc_oslo_save_cbaero(state, pbuf) + end if + + ! initialize time-varying parameters + do k = top_lev, pver + do i = 1, ncol + rho(i,k) = state1%pmid(i,k)/(rair*state1%t(i,k)) + end do + end do - ! initialize time-varying parameters - do k = top_lev, pver - do i = 1, ncol - rho(i,k) = state1%pmid(i,k)/(rair*state1%t(i,k)) - end do - end do - -!++ MH_2015/04/10 factnum(1:ncol,1:pver,0:nmodes_oslo) = 0._r8 - !hetraer(1:ncol,1:pver,1:3) = 0._r8 - !total_aer_num(1:ncol,1:pver,1:3) = 0._r8 - !coated_aer_num(1:ncol,1:pver,1:3) = 0._r8 - !uncoated_aer_num(1:ncol,1:pver,1:3) = 0._r8 - !total_interstitial_aer_num(1:ncol,1:pver,1:3) = 0._r8 - !total_cloudborne_aer_num(1:ncol,1:pver,1:3) = 0._r8 - !awcam(1:ncol,1:pver,1:3) = 0._r8 - !awfacm(1:ncol,1:pver,1:3) = 0._r8 - !dstcoat(1:ncol,1:pver,1:3) = 0._r8 - !++ wy4.0 - !na500(1:ncol,1:pver) = 0._r8 - !tot_na500(1:ncol,1:pver) = 0._r8 - !-- wy4.0 - -#ifdef OSLO_AERO cam(:,:,:) = 0._r8 - !qaercwpt(1:ncol,1:pver,:) = 0.0_r8 - ! do m=1,nmodes_oslo - ! do n=1,getNumberOfTracersInMode(m) - ! kk=getTracerIndex(m,n,.false.)! This gives the tracer index used in the q-array - ! qqcw(kk)%fldcw => qqcw_get_field(pbuf,kk,lchnk) - ! qaercwpt(:,:,kk) = qqcw(kk)%fldcw - ! end do - ! end do -#endif -!-- MH_2015/04/10 - - -#ifndef OSLO_AERO - if (clim_modal_aero) then - ! mode number mixing ratios - call rad_cnst_get_mode_num(0, mode_coarse_dst_idx, 'a', state1, pbuf, num_coarse) - - ! mode specie mass m.r. - call rad_cnst_get_aer_mmr(0, mode_coarse_dst_idx, coarse_dust_idx, 'a', state1, pbuf, coarse_dust) - call rad_cnst_get_aer_mmr(0, mode_coarse_slt_idx, coarse_nacl_idx, 'a', state1, pbuf, coarse_nacl) - if (mode_coarse_idx>0) then - call rad_cnst_get_aer_mmr(0, mode_coarse_idx, coarse_so4_idx, 'a', state1, pbuf, coarse_so4) - endif - - else - ! init number/mass arrays for bulk aerosols - allocate( & - naer2(pcols,pver,naer_all), & - maerosol(pcols,pver,naer_all)) - - do m = 1, naer_all - call rad_cnst_get_aer_mmr(0, m, state1, pbuf, aer_mmr) - maerosol(:ncol,:,m) = aer_mmr(:ncol,:)*rho(:ncol,:) - - if (m .eq. idxsul) then - naer2(:ncol,:,m) = maerosol(:ncol,:,m)*num_to_mass_aer(m)*bulk_scale - else - naer2(:ncol,:,m) = maerosol(:ncol,:,m)*num_to_mass_aer(m) - end if - end do - end if -#endif - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! More refined computation of sub-grid vertical velocity - ! Set to be zero at the surface by initialization. - - select case (trim(eddy_scheme)) - case ('diag_TKE') - call pbuf_get_field(pbuf, tke_idx, tke) - case ('CLUBB_SGS') - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, wp2_idx, wp2, start=(/1,1,itim_old/),kount=(/pcols,pverp,1/)) - allocate(tke(pcols,pverp)) - tke(:ncol,:) = (3._r8/2._r8)*wp2(:ncol,:) - - case default - call pbuf_get_field(pbuf, kvh_idx, kvh) - end select - - ! Set minimum values above top_lev. - wsub(:ncol,:top_lev-1) = 0.20_r8 - wsubi(:ncol,:top_lev-1) = 0.001_r8 - - do k = top_lev, pver - do i = 1, ncol - - select case (trim(eddy_scheme)) - case ('diag_TKE', 'CLUBB_SGS') - wsub(i,k) = sqrt(0.5_r8*(tke(i,k) + tke(i,k+1))*(2._r8/3._r8)) - wsub(i,k) = min(wsub(i,k),10._r8) - case default - ! get sub-grid vertical velocity from diff coef. - ! following morrison et al. 2005, JAS - ! assume mixing length of 30 m - dum = (kvh(i,k) + kvh(i,k+1))/2._r8/30._r8 - ! use maximum sub-grid vertical vel of 10 m/s - dum = min(dum, 10._r8) - ! set wsub to value at current vertical level - wsub(i,k) = dum - end select - - wsubi(i,k) = max(0.001_r8, wsub(i,k)) - if (.not. use_preexisting_ice) then - wsubi(i,k) = min(wsubi(i,k), 0.2_r8) - endif - - wsub(i,k) = max(0.20_r8, wsub(i,k)) - - end do - end do - - call outfld('WSUB', wsub, pcols, lchnk) - call outfld('WSUBI', wsubi, pcols, lchnk) - - if (trim(eddy_scheme) == 'CLUBB_SGS') deallocate(tke) - -!++ MH_2015/04/10 -#ifdef OSLO_AERO - -!Get size distributed interstitial aerosol - call parmix_progncdnc_sub( & - ncol & !I [nbr] number of columns used - ,state%q & !I [kg/kg] mass mixing ratio of tracers - ,rho & !I [kg/m3] air density - ,CProcessModes & !O [kg/m3] added mass (total distributed all background modes) - ,f_c & !O - ,f_bc & !O - ,f_aq & !O - ,f_so4_cond & !O - ,f_soa & - ,cam & !O - ,f_acm & !O [frc] carbon fraction in mode - ,f_bcm & !O [frc] fraction of c being bc - ,f_aqm & !O [frc] fraction of sulfate being aquous - ,f_so4_condm & !O [frc] fraction of non-aquous SO4 being condensate - ,f_soam & - ,numberConcentration & !O [#/m3] number concentration - ,volumeConcentration & !O [m3/m3] volume concentration - ,hygroscopicity & !O [mol/mol] - ,lnsigma & !O [-] log sigma - ,hasAerosol & !I [t/f] do we have this type of aerosol here? - ,volumeCore & - ,volumeCoat & - ) -#endif -!-- MH_2015/04/10 - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - !ICE Nucleation - - call nucleate_ice_oslo_calc(state1, wsubi, pbuf, deltatin, ptend_loc, numberConcentration) - - call physics_ptend_sum(ptend_loc, ptend_all, ncol) - call physics_update(state1, ptend_loc, deltatin) - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! get liquid cloud fraction, check for minimum - - do k = top_lev, pver - do i = 1, ncol - lcldm(i,k) = max(ast(i,k), mincld) - end do - end do - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! Droplet Activation - - if (clim_modal_aero) then - - ! for modal aerosol - - ! partition cloud fraction into liquid water part - lcldn = 0._r8 - lcldo = 0._r8 - cldliqf = 0._r8 - do k = top_lev, pver - do i = 1, ncol - qcld = state1%q(i,k,cldliq_idx) + state1%q(i,k,cldice_idx) - if (qcld > qsmall) then - lcldn(i,k) = cldn(i,k)*state1%q(i,k,cldliq_idx)/qcld - lcldo(i,k) = cldo(i,k)*state1%q(i,k,cldliq_idx)/qcld - cldliqf(i,k) = state1%q(i,k,cldliq_idx)/qcld - end if - end do - end do - - call outfld('LCLOUD', lcldn, pcols, lchnk) - - ! If not using preexsiting ice, then only use cloudbourne aerosol for the - ! liquid clouds. This is the same behavior as CAM5. - if (use_preexisting_ice) then - call dropmixnuc( & - state1, ptend_loc, deltatin, pbuf, wsub, & ! Input - cldn, cldo, cldliqf, & - !++ MH_2015/09/07 - hasAerosol, & - CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, & - cam, f_acm, f_bcm, f_aqm, f_so4_condm, & - f_soam, & - numberConcentration, volumeConcentration, & - hygroscopicity, lnsigma, & - !-- MH_2015/09/07 - nctend_mixnuc, & ! Output - !++ MH_2015/04/10 - factnum ) - !-- MH_2015/04/10 - else - ! Note difference in arguments lcldn, lcldo - cldliqf = 1._r8 - call dropmixnuc( & - state1, ptend_loc, deltatin, pbuf, wsub, & ! Input - lcldn, lcldo, cldliqf, & - !++ MH_2015/09/07 - hasAerosol, & - CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, & - cam, f_acm, f_bcm, f_aqm, f_so4_condm, & - f_soam, & - numberConcentration, volumeConcentration, & - hygroscopicity, lnsigma, & - !-- MH_2015/09/07 - nctend_mixnuc, & ! Output - !++ MH_2015/04/10 - factnum ) - !-- MH_2015/04/10 - end if - - npccn(:ncol,:) = nctend_mixnuc(:ncol,:) - - else - - ! for bulk aerosol - - ! no tendencies returned from ndrop_bam_run, so just init ptend here - call physics_ptend_init(ptend_loc, state1%psetcols, 'none') - - do k = top_lev, pver - do i = 1, ncol - - if (state1%q(i,k,cldliq_idx) >= qsmall) then - - ! get droplet activation rate - - call ndrop_bam_run( & - wsub(i,k), state1%t(i,k), rho(i,k), naer2(i,k,:), naer_all, & - naer_all, maerosol(i,k,:), & - dum2) - dum = dum2 - else - dum = 0._r8 - end if - - npccn(i,k) = (dum*lcldm(i,k) - state1%q(i,k,numliq_idx))/deltatin - end do - end do - end if - - call physics_ptend_sum(ptend_loc, ptend_all, ncol) - call physics_update(state1, ptend_loc, deltatin) - - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! Contact freezing (-40 0.0_r8) then - nacon(i,k,3) = wght*num_coarse(i,k)*rho(i,k) - else - nacon(i,k,3) = 0._r8 - end if - - !also redefine parameters based on size... - - rndst(i,k,3) = 0.5_r8*dgnumwet(i,k,mode_coarse_dst_idx) - if (rndst(i,k,3) <= 0._r8) then - rndst(i,k,3) = rn_dst3 - end if - -#endif - else - - !For Bulk Aerosols: set equal to aerosol number for dust for bins 2-4 (bin 1=0) - - if (idxdst2 > 0) then - nacon(i,k,2) = naer2(i,k,idxdst2) - end if - if (idxdst3 > 0) then - nacon(i,k,3) = naer2(i,k,idxdst3) - end if - if (idxdst4 > 0) then - nacon(i,k,4) = naer2(i,k,idxdst4) - end if - end if - - end if - end do - end do - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - !bulk aerosol ccn concentration (modal does it in ndrop, from dropmixnuc) - - if (.not. clim_modal_aero) then - - ! ccn concentration as diagnostic - call ndrop_bam_ccn(lchnk, ncol, maerosol, naer2) - - deallocate( & - naer2, & - maerosol) - - end if - - ! heterogeneous freezing - if (use_hetfrz_classnuc) then - - call hetfrz_classnuc_oslo_calc(state1, deltatin, factnum, pbuf & + ! More refined computation of sub-grid vertical velocity + ! Set to be zero at the surface by initialization. + + select case (trim(eddy_scheme)) + case ('diag_TKE') + call pbuf_get_field(pbuf, tke_idx, tke) + case ('CLUBB_SGS') + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, wp2_idx, wp2, start=(/1,1,itim_old/),kount=(/pcols,pverp,1/)) + allocate(tke(pcols,pverp)) + tke(:ncol,:) = (3._r8/2._r8)*wp2(:ncol,:) + + case default + call pbuf_get_field(pbuf, kvh_idx, kvh) + end select + + ! Set minimum values above top_lev. + wsub(:ncol,:top_lev-1) = 0.20_r8 + wsubi(:ncol,:top_lev-1) = 0.001_r8 + + do k = top_lev, pver + do i = 1, ncol + + select case (trim(eddy_scheme)) + case ('diag_TKE', 'CLUBB_SGS') + wsub(i,k) = sqrt(0.5_r8*(tke(i,k) + tke(i,k+1))*(2._r8/3._r8)) + wsub(i,k) = min(wsub(i,k),10._r8) + case default + ! get sub-grid vertical velocity from diff coef. + ! following morrison et al. 2005, JAS + ! assume mixing length of 30 m + dum = (kvh(i,k) + kvh(i,k+1))/2._r8/30._r8 + ! use maximum sub-grid vertical vel of 10 m/s + dum = min(dum, 10._r8) + ! set wsub to value at current vertical level + wsub(i,k) = dum + end select + + wsubi(i,k) = max(0.001_r8, wsub(i,k)) + if (.not. use_preexisting_ice) then + wsubi(i,k) = min(wsubi(i,k), 0.2_r8) + endif + + wsub(i,k) = max(0.20_r8, wsub(i,k)) + + end do + end do + + call outfld('WSUB', wsub, pcols, lchnk) + call outfld('WSUBI', wsubi, pcols, lchnk) + + if (trim(eddy_scheme) == 'CLUBB_SGS') deallocate(tke) + + !Get size distributed interstitial aerosol + call parmix_progncdnc_sub( & + ncol & !I [nbr] number of columns used + ,state%q & !I [kg/kg] mass mixing ratio of tracers + ,rho & !I [kg/m3] air density + ,CProcessModes & !O [kg/m3] added mass (total distributed all background modes) + ,f_c & !O + ,f_bc & !O + ,f_aq & !O + ,f_so4_cond & !O + ,f_soa & + ,cam & !O + ,f_acm & !O [frc] carbon fraction in mode + ,f_bcm & !O [frc] fraction of c being bc + ,f_aqm & !O [frc] fraction of sulfate being aquous + ,f_so4_condm & !O [frc] fraction of non-aquous SO4 being condensate + ,f_soam & + ,numberConcentration & !O [#/m3] number concentration + ,volumeConcentration & !O [m3/m3] volume concentration + ,hygroscopicity & !O [mol/mol] + ,lnsigma & !O [-] log sigma + ,hasAerosol & !I [t/f] do we have this type of aerosol here? + ,volumeCore & + ,volumeCoat & + ) + + !ICE Nucleation + call nucleate_ice_oslo_calc(state1, wsubi, pbuf, deltatin, ptend_loc, numberConcentration) + + call physics_ptend_sum(ptend_loc, ptend_all, ncol) + call physics_update(state1, ptend_loc, deltatin) + + ! get liquid cloud fraction, check for minimum + do k = top_lev, pver + do i = 1, ncol + lcldm(i,k) = max(ast(i,k), mincld) + end do + end do + + ! Droplet Activation + + if (clim_modal_aero) then + + ! for modal aerosol + + ! partition cloud fraction into liquid water part + lcldn = 0._r8 + lcldo = 0._r8 + cldliqf = 0._r8 + do k = top_lev, pver + do i = 1, ncol + qcld = state1%q(i,k,cldliq_idx) + state1%q(i,k,cldice_idx) + if (qcld > qsmall) then + lcldn(i,k) = cldn(i,k)*state1%q(i,k,cldliq_idx)/qcld + lcldo(i,k) = cldo(i,k)*state1%q(i,k,cldliq_idx)/qcld + cldliqf(i,k) = state1%q(i,k,cldliq_idx)/qcld + end if + end do + end do + + call outfld('LCLOUD', lcldn, pcols, lchnk) + + ! If not using preexsiting ice, then only use cloudbourne aerosol for the + ! liquid clouds. This is the same behavior as CAM5. + if (use_preexisting_ice) then + call dropmixnuc( & + state1, ptend_loc, deltatin, pbuf, wsub, & ! Input + cldn, cldo, cldliqf, & + hasAerosol, & + CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, & + cam, f_acm, f_bcm, f_aqm, f_so4_condm, & + f_soam, & + numberConcentration, volumeConcentration, & + hygroscopicity, lnsigma, & + nctend_mixnuc, & ! Output + factnum ) + else + ! Note difference in arguments lcldn, lcldo + cldliqf = 1._r8 + call dropmixnuc( & + state1, ptend_loc, deltatin, pbuf, wsub, & ! Input + lcldn, lcldo, cldliqf, & + hasAerosol, & + CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, & + cam, f_acm, f_bcm, f_aqm, f_so4_condm, & + f_soam, & + numberConcentration, volumeConcentration, & + hygroscopicity, lnsigma, & + nctend_mixnuc, & ! Output + factnum ) + end if + npccn(:ncol,:) = nctend_mixnuc(:ncol,:) + + else + + ! for bulk aerosol + + ! no tendencies returned from ndrop_bam_run, so just init ptend here + call physics_ptend_init(ptend_loc, state1%psetcols, 'none') + + do k = top_lev, pver + do i = 1, ncol + if (state1%q(i,k,cldliq_idx) >= qsmall) then + ! get droplet activation rate + call ndrop_bam_run( & + wsub(i,k), state1%t(i,k), rho(i,k), naer2(i,k,:), naer_all, & + naer_all, maerosol(i,k,:), dum2) + dum = dum2 + else + dum = 0._r8 + end if + npccn(i,k) = (dum*lcldm(i,k) - state1%q(i,k,numliq_idx))/deltatin + end do + end do + + end if + + call physics_ptend_sum(ptend_loc, ptend_all, ncol) + call physics_update(state1, ptend_loc, deltatin) + + ! Contact freezing (-40 0) then + nacon(i,k,2) = naer2(i,k,idxdst2) + end if + if (idxdst3 > 0) then + nacon(i,k,3) = naer2(i,k,idxdst3) + end if + if (idxdst4 > 0) then + nacon(i,k,4) = naer2(i,k,idxdst4) + end if + end if + + end if + end do + end do + + !bulk aerosol ccn concentration (modal does it in ndrop, from dropmixnuc) + if (.not. clim_modal_aero) then + ! ccn concentration as diagnostic + call ndrop_bam_ccn(lchnk, ncol, maerosol, naer2) + + deallocate(naer2) + deallocate(maerosol) + end if + + ! heterogeneous freezing + if (use_hetfrz_classnuc) then + call hetfrz_classnuc_oslo_calc(state1, deltatin, factnum, pbuf & ,numberConcentration, volumeConcentration & ,f_acm, f_bcm, f_aqm, f_so4_condm, f_soam & ,hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) + end if - - end if -#ifndef OSLO_AERO - if (clim_modal_aero) then - deallocate(factnum) - end if -#endif - -end subroutine microp_aero_run - -!========================================================================================= + end subroutine microp_aero_run end module microp_aero diff --git a/src/chemistry/oslo_aero/mo_chm_diags.F90 b/src/chemistry/oslo_aero/mo_chm_diags.F90 index ab0c663d1d..943fdb5114 100644 --- a/src/chemistry/oslo_aero/mo_chm_diags.F90 +++ b/src/chemistry/oslo_aero/mo_chm_diags.F90 @@ -49,9 +49,7 @@ module mo_chm_diags character(len=fieldname_len) :: depflx_name(gas_pcnst) character(len=fieldname_len) :: wetdep_name(gas_pcnst) character(len=fieldname_len) :: wtrate_name(gas_pcnst) -#ifdef OSLO_AERO character(len=fieldname_len) :: wetdep_name_area(gas_pcnst) -#endif real(r8), parameter :: N_molwgt = 14.00674_r8 real(r8), parameter :: S_molwgt = 32.066_r8 @@ -68,13 +66,8 @@ subroutine chm_diags_inti use phys_control, only : phys_getopts use mo_drydep, only : has_drydep use species_sums_diags, only : species_sums_init -#if (defined OSLO_AERO) -! use aerosoldef, only: getCloudTracerIndexDirect, getCloudTracerName & -! , N_AEROSOL_TYPES, aerosol_type_name, isAerosol use commondefinitions - use aerosoldef, only: getCloudTracerIndexDirect, getCloudTracerName & - , isAerosol -#endif + use aerosoldef, only: getCloudTracerIndexDirect, getCloudTracerName, isAerosol implicit none integer :: j, k, m, n @@ -107,18 +100,15 @@ subroutine chm_diags_inti logical :: history_scwaccm_forcing logical :: history_chemspecies_srf ! output the chemistry constituents species in the surface layer integer :: bulkaero_species(20) -#ifdef OSLO_AERO integer :: cloudTracerIndex character(len=20) :: cloudTracerName -#endif - !----------------------------------------------------------------------- call phys_getopts( history_aerosol_out = history_aerosol, & - history_chemistry_out = history_chemistry, & - history_chemspecies_srf_out = history_chemspecies_srf, & - history_cesm_forcing_out = history_cesm_forcing, & - history_scwaccm_forcing_out = history_scwaccm_forcing ) + history_chemistry_out = history_chemistry, & + history_chemspecies_srf_out = history_chemspecies_srf, & + history_cesm_forcing_out = history_cesm_forcing, & + history_scwaccm_forcing_out = history_scwaccm_forcing ) id_bry = get_spc_ndx( 'BRY' ) id_cly = get_spc_ndx( 'CLY' ) @@ -248,40 +238,40 @@ subroutine chm_diags_inti id_soax = get_spc_ndx( 'SOAX' ) -!... NOY species + !... NOY species nox_species = (/ id_n, id_no, id_no2 /) noy_species = (/ id_n, id_no, id_no2, id_no3, id_n2o5, id_hno3, id_ho2no2, id_clono2, & - id_brono2, id_pan, id_onit, id_mpan, id_isopno3, id_onitr, id_nh4no3, & - id_honitr, id_alknit, id_isopnita, id_isopnitb, id_isopnooh, id_nc4ch2oh, & - id_nc4cho, id_noa, id_nterpooh, id_pbznit, id_terpnit /) -!... HOX species + id_brono2, id_pan, id_onit, id_mpan, id_isopno3, id_onitr, id_nh4no3, & + id_honitr, id_alknit, id_isopnita, id_isopnitb, id_isopnooh, id_nc4ch2oh, & + id_nc4cho, id_noa, id_nterpooh, id_pbznit, id_terpnit /) + !... HOX species hox_species = (/ id_h, id_oh, id_ho2, id_h2o2 /) -!... CLOY species + !... CLOY species clox_species = (/ id_cl, id_clo, id_hocl, id_cl2, id_cl2o2, id_oclo /) cloy_species = (/ id_cl, id_clo, id_hocl, id_cl2, id_cl2o2, id_oclo, id_hcl, id_clono2, id_brcl /) tcly_species = (/ id_cl, id_clo, id_hocl, id_cl2, id_cl2o2, id_oclo, id_hcl, id_clono2, id_brcl, & - id_ccl4, id_cfc11, id_cfc113, id_cfc114, id_cfc115, id_ch3ccl3, id_cfc12, id_ch3cl, & - id_hcfc22, id_hcfc141b, id_hcfc142b, id_cf2clbr /) + id_ccl4, id_cfc11, id_cfc113, id_cfc114, id_cfc115, id_ch3ccl3, id_cfc12, id_ch3cl, & + id_hcfc22, id_hcfc141b, id_hcfc142b, id_cf2clbr /) -!... FOY species + !... FOY species foy_species = (/ id_F, id_hf, id_cofcl, id_cof2 /) tfy_species = (/ id_f, id_hf, id_cofcl, id_cof2, id_cfc11, id_cfc12, id_cfc113, id_cfc114, id_cfc115, & - id_hcfc22, id_hcfc141b, id_hcfc142b, id_cf2clbr, id_cf3br, id_h1202, id_h2402 /) + id_hcfc22, id_hcfc141b, id_hcfc142b, id_cf2clbr, id_cf3br, id_h1202, id_h2402 /) -!... BROY species + !... BROY species brox_species = (/ id_br, id_bro, id_brcl, id_hobr /) broy_species = (/ id_br, id_bro, id_hbr, id_brono2, id_brcl, id_hobr /) tbry_species = (/ id_br, id_bro, id_hbr, id_brono2, id_brcl, id_hobr, id_cf2clbr, id_cf3br, id_ch3br, id_h1202, & - id_h2402, id_ch2br2, id_chbr3 /) + id_h2402, id_ch2br2, id_chbr3 /) sox_species = (/ id_so2, id_so4, id_h2so4 /) nhx_species = (/ id_nh3, id_nh4 /) bulkaero_species(:) = -1 bulkaero_species(1:20) = (/ id_dst01, id_dst02, id_dst03, id_dst04, & - id_sslt01, id_sslt02, id_sslt03, id_sslt04, & - id_soa, id_so4, id_oc1, id_oc2, id_cb1, id_cb2, id_nh4no3, & - id_soam,id_soai,id_soat,id_soab,id_soax /) + id_sslt01, id_sslt02, id_sslt03, id_sslt04, & + id_soa, id_so4, id_oc1, id_oc2, id_cb1, id_cb2, id_nh4no3, & + id_soam,id_soai,id_soat,id_soab,id_soax /) aer_species(:) = -1 n = 1 @@ -300,7 +290,7 @@ subroutine chm_diags_inti call addfld( 'NOX', (/ 'lev' /), 'A', 'mol/mol', 'nox (N+NO+NO2)' ) call addfld( 'NOY', (/ 'lev' /), 'A', 'mol/mol', & - 'noy = total nitrogen (N+NO+NO2+NO3+2N2O5+HNO3+HO2NO2+ORGNOY+NH4NO3' ) + 'noy = total nitrogen (N+NO+NO2+NO3+2N2O5+HNO3+HO2NO2+ORGNOY+NH4NO3' ) call addfld( 'NOY_SRF', horiz_only, 'A', 'mol/mol', 'surface noy volume mixing ratio' ) call addfld( 'HOX', (/ 'lev' /), 'A', 'mol/mol', 'HOx (H+OH+HO2+2H2O2)' ) @@ -349,14 +339,14 @@ subroutine chm_diags_inti if ( has_jno_i ) then call addfld( 'PJNO_I', (/ 'lev' /), 'I', '/cm^3/s', 'jno_i*no' ) endif -! -! CCMI -! + ! + ! CCMI + ! call addfld( 'DO3CHM_TRP', horiz_only, 'A', 'kg/s', 'integrated net tendency from chem in troposphere', & flag_xyfill=.True. ) call addfld( 'DO3CHM_LMS', horiz_only, 'A', 'kg/s', 'integrated net tendency from chem in lowermost stratosphere', & flag_xyfill=.True. ) -! + ! do m = 1,gas_pcnst spc_name = trim(solsym(m)) @@ -390,19 +380,17 @@ subroutine chm_diags_inti call addfld( wtrate_name(m), (/ 'lev' /), 'A', '/s', spc_name//' wet deposition rate' ) endif -#if defined OSLO_AERO wetdep_name_area(m)='WD_A_'//trim(spc_name) call addfld( wetdep_name_area(m), horiz_only, 'A', 'kg/m2/s ', spc_name//' wet deposition' ) !Needed for budget term of gases! Aerosols have their own budget terms if(n.gt.0) then if(.NOT. isAerosol(n))then - if(history_chemistry)then - call add_default( wetdep_name_area(m), 1, ' ') - end if + if(history_chemistry)then + call add_default( wetdep_name_area(m), 1, ' ') + end if endif - end if -#endif + end if if (spc_name(1:3) == 'num') then unit_basename = ' 1' @@ -410,34 +398,23 @@ subroutine chm_diags_inti unit_basename = 'kg' endif -!akc6 if ( any( aer_species == m ) ) then -!akc6! if ( any( aer_species == m ) .or. isAerosol(n) ) then -!akc6+ -#ifndef OSLO_AERO - if ( any( aer_species == m ) ) then -#else if (n.gt.0) then - if ( any( aer_species == m ) .or. isAerosol(n) ) then -!akc6- -#endif - call addfld( spc_name, (/ 'lev' /), 'A', unit_basename//'/kg ', trim(attr)//' concentration') - call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', unit_basename//'/kg', trim(attr)//" in bottom layer") - else - call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') - call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") - endif -!akc6+ -#ifdef OSLO_AERO + if ( any( aer_species == m ) .or. isAerosol(n) ) then + call addfld( spc_name, (/ 'lev' /), 'A', unit_basename//'/kg ', trim(attr)//' concentration') + call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', unit_basename//'/kg', trim(attr)//" in bottom layer") + else + call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') + call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") + endif else call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") endif -#endif -!akc6- + if ((m /= id_cly) .and. (m /= id_bry)) then if (history_aerosol.or.history_chemistry) then call add_default( spc_name, 1, ' ' ) - endif + endif if (history_chemspecies_srf) then call add_default( trim(spc_name)//'_SRF', 1, ' ' ) endif @@ -474,61 +451,55 @@ subroutine chm_diags_inti if (m==id_cfc12 ) call add_default( spc_name, 1, ' ') endif -#ifdef OSLO_AERO call add_default( spc_name, 1, ' ' ) -#endif - -#if defined OSLO_AERO - !output 3d-field of aersol tracer in cloud water - if(n > 0) then - cloudTracerIndex = getCloudTracerIndexDirect(n) - if(cloudTracerIndex > 0)then - cloudTracerName(1:len(CloudTracerName))=" " - cloudTracerName = getCloudTracerName(n) - call addfld( trim(cloudTracerName), (/'lev'/), 'A','kg/kg', & - trim(cloudTracerName)//' in cloud water') - call add_default( trim(cloudTracerName), 1, ' ' ) - - !Add column burden of cloud tracers - call addfld('cb_'//trim(cloudTracerName),horiz_only, 'A', 'kg/m2', & - 'cb_'//trim(cloudTracerName)//' column in cloud water') - call add_default('cb_'//trim(cloudTracerName),1,' ') - endif - !..and column burden in clean air - call addfld('cb_'//trim(spc_name),horiz_only, 'A', 'kg/m2', & - 'cb_'//trim(spc_name)//' in column') - call add_default('cb_'//trim(spc_name),1,' ' ) - - if(history_aerosol)then - if(cloudTracerIndex > 0)then - !Output budget-terms for cloud borne aerosols - call add_default (trim(cloudTracerName)//'GVF', 1, ' ') - call add_default (trim(cloudTracerName)//'SFWET', 1, ' ') - call add_default (trim(cloudTracerName)//'TBF', 1, ' ') - call add_default (trim(cloudTracerName)//'DDF', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSBS', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSIC', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSBC', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSIS', 1, ' ') - endif - endif - end if -#endif + + !output 3d-field of aersol tracer in cloud water + if(n > 0) then + cloudTracerIndex = getCloudTracerIndexDirect(n) + if(cloudTracerIndex > 0)then + cloudTracerName(1:len(CloudTracerName))=" " + cloudTracerName = getCloudTracerName(n) + call addfld( trim(cloudTracerName), (/'lev'/), 'A','kg/kg', & + trim(cloudTracerName)//' in cloud water') + call add_default( trim(cloudTracerName), 1, ' ' ) + + !Add column burden of cloud tracers + call addfld('cb_'//trim(cloudTracerName),horiz_only, 'A', 'kg/m2', & + 'cb_'//trim(cloudTracerName)//' column in cloud water') + call add_default('cb_'//trim(cloudTracerName),1,' ') + endif + !..and column burden in clean air + call addfld('cb_'//trim(spc_name),horiz_only, 'A', 'kg/m2', & + 'cb_'//trim(spc_name)//' in column') + call add_default('cb_'//trim(spc_name),1,' ' ) + + if(history_aerosol)then + if(cloudTracerIndex > 0)then + !Output budget-terms for cloud borne aerosols + call add_default (trim(cloudTracerName)//'GVF', 1, ' ') + call add_default (trim(cloudTracerName)//'SFWET', 1, ' ') + call add_default (trim(cloudTracerName)//'TBF', 1, ' ') + call add_default (trim(cloudTracerName)//'DDF', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSBS', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSIC', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSBC', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSIS', 1, ' ') + endif + endif + end if enddo call addfld( 'MASS', (/ 'lev' /), 'A', 'kg', 'mass of grid box' ) call addfld( 'AREA', horiz_only, 'A', 'm2', 'area of grid box' ) -#ifdef OSLO_AERO - do n=1,N_AEROSOL_TYPES - call addfld('cb_'//trim(aerosol_type_name(n)),horiz_only, 'A', 'kg/m2',& - 'cb_'//trim(aerosol_type_name(n))//' column of aerosol type') - call add_default('cb_'//trim(aerosol_type_name(n)), 1, ' ') - call addfld('mmr_'//trim(aerosol_type_name(n)),(/'lev'/),'A','kg/kg' ,& - 'mmr_'//trim(aerosol_type_name(n))//' mmr of aerosol type') - call add_default('mmr_'//trim(aerosol_type_name(n)), 1, ' ') - end do -#endif + do n=1,N_AEROSOL_TYPES + call addfld('cb_'//trim(aerosol_type_name(n)),horiz_only, 'A', 'kg/m2',& + 'cb_'//trim(aerosol_type_name(n))//' column of aerosol type') + call add_default('cb_'//trim(aerosol_type_name(n)), 1, ' ') + call addfld('mmr_'//trim(aerosol_type_name(n)),(/'lev'/),'A','kg/kg' ,& + 'mmr_'//trim(aerosol_type_name(n))//' mmr of aerosol type') + call add_default('mmr_'//trim(aerosol_type_name(n)), 1, ' ') + end do call addfld( 'dry_deposition_NOy_as_N', horiz_only, 'I', 'kg/m2/s', 'NOy dry deposition flux ' ) call addfld( 'DF_SOX', horiz_only, 'I', 'kg/m2/s', 'SOx dry deposition flux ' ) @@ -553,27 +524,22 @@ subroutine chm_diags_inti end subroutine chm_diags_inti subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depflx, mmr_tend, pdel, pmid, ltrop, & - wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx, pbuf) + wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx, pbuf) !-------------------------------------------------------------------- ! ... utility routine to output chemistry diagnostic variables !-------------------------------------------------------------------- - + use cam_history, only : outfld use phys_grid, only : get_area_all_p use species_sums_diags, only : species_sums_output -#if (defined OSLO_AERO) use constituents, only : cnst_get_ind use phys_grid, only : pcols use commondefinitions use aerosoldef, only : getCloudTracerIndexDirect, getCloudTracerName & - , aerosolType, isAerosol + , aerosolType, isAerosol use physics_buffer, only : pbuf_get_field, pbuf_get_index use physics_buffer, only : physics_buffer_desc -#endif -! -! CCMI -! - use cam_history_support, only : fillvalue + use cam_history_support, only : fillvalue ! CCMI !-------------------------------------------------------------------- ! ... dummy arguments @@ -595,7 +561,6 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf real(r8), intent(out) :: noy_nitrogen_flx(ncol) ! kgN/m2/sec type(physics_buffer_desc), pointer :: pbuf(:) -#ifdef OSLO_AERO real(r8), dimension(:,:), pointer :: cloudTracerField integer :: cloudTracerIndex character(len=20) :: cloudTracerName @@ -603,7 +568,7 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf real(r8) :: cb(pcols) real(r8) :: cb_aerosol_type(pcols,N_AEROSOL_TYPES) !column burden aerosol types real(r8) :: mmr_aerosol_type(pcols,pver,N_AEROSOL_TYPES) !concentration aerosol types -#endif + !-------------------------------------------------------------------- ! ... local variables !-------------------------------------------------------------------- @@ -612,7 +577,7 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf ! real(r8) :: tmp(ncol,pver) ! real(r8) :: m(ncol,pver) real(r8) :: un2(ncol) - + real(r8), dimension(ncol,pver) :: vmr_nox, vmr_noy, vmr_clox, vmr_cloy, vmr_tcly, vmr_brox, vmr_broy, vmr_toth real(r8), dimension(ncol,pver) :: vmr_tbry, vmr_foy, vmr_tfy real(r8), dimension(ncol,pver) :: mmr_noy, mmr_sox, mmr_nhx, net_chem @@ -660,13 +625,12 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf call outfld( 'AREA', area(:ncol), ncol, lchnk ) call outfld( 'MASS', mass(:ncol,:), ncol, lchnk ) -#ifdef OSLO_AERO - cb_aerosol_type(:,:) = 0.0_r8 - mmr_aerosol_type(:,:,:) = 0.0_r8 -#endif + cb_aerosol_type(:,:) = 0.0_r8 + mmr_aerosol_type(:,:,:) = 0.0_r8 + do m = 1,gas_pcnst - !...FOY (counting Fluorines, not chlorines or bromines) + !...FOY (counting Fluorines, not chlorines or bromines) if ( m == id_cfc12 .or. m == id_hcfc22 .or. m == id_cf2clbr .or. m == id_h1202 .or. m == id_hcfc142b & .or. m == id_cof2 ) then wgt = 2._r8 @@ -686,7 +650,7 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf vmr_tfy(:ncol,:) = vmr_tfy(:ncol,:) + wgt * vmr(:ncol,:,m) endif -!... counting chlorine and bromines, etc... (and total H2 species) + !... counting chlorine and bromines, etc... (and total H2 species) if ( m == id_ch4 .or. m == id_n2o5 .or. m == id_cfc12 .or. m == id_cl2 .or. m == id_cl2o2 .or. m==id_h2o2 ) then wgt = 2._r8 elseif (m == id_cfc114 .or. m == id_hcfc141b .or. m == id_h1202 .or. m == id_h2402 .or. m == id_ch2br2 ) then @@ -698,14 +662,14 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf else wgt = 1._r8 endif -!...NOY + !...NOY if ( any( nox_species == m ) ) then vmr_nox(:ncol,:) = vmr_nox(:ncol,:) + wgt * vmr(:ncol,:,m) endif if ( any( noy_species == m ) ) then vmr_noy(:ncol,:) = vmr_noy(:ncol,:) + wgt * vmr(:ncol,:,m) endif -!...NOY, SOX, NHX + !...NOY, SOX, NHX if ( any( noy_species == m ) ) then mmr_noy(:ncol,:) = mmr_noy(:ncol,:) + wgt * mmr(:ncol,:,m) endif @@ -715,7 +679,7 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf if ( any( nhx_species == m ) ) then mmr_nhx(:ncol,:) = mmr_nhx(:ncol,:) + wgt * mmr(:ncol,:,m) endif -!...CLOY + !...CLOY if ( any( clox_species == m ) ) then vmr_clox(:ncol,:) = vmr_clox(:ncol,:) + wgt * vmr(:ncol,:,m) endif @@ -725,7 +689,7 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf if ( any( tcly_species == m ) ) then vmr_tcly(:ncol,:) = vmr_tcly(:ncol,:) + wgt * vmr(:ncol,:,m) endif -!...BROY + !...BROY if ( any( brox_species == m ) ) then vmr_brox(:ncol,:) = vmr_brox(:ncol,:) + wgt * vmr(:ncol,:,m) endif @@ -735,70 +699,61 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf if ( any( tbry_species == m ) ) then vmr_tbry(:ncol,:) = vmr_tbry(:ncol,:) + wgt * vmr(:ncol,:,m) endif -!...HOY + !...HOY if ( any ( toth_species == m ) ) then vmr_toth(:ncol,:) = vmr_toth(:ncol,:) + wgt * vmr(:ncol,:,m) endif -!...HOx + !...HOx if ( any( hox_species == m ) ) then vmr_hox(:ncol,:) = vmr_hox(:ncol,:) + wgt * vmr(:ncol,:,m) endif -#if defined OSLO_AERO spc_name = trim(solsym(m)) call cnst_get_ind(spc_name, n, abort=.false.) -#endif - -#ifndef OSLO_AERO - if ( any( aer_species == m ) ) then -#else + if (n.gt.0) then - if ( any( aer_species == m ) .or. isAerosol(n) ) then -#endif - call outfld( solsym(m), mmr(:ncol,:,m), ncol ,lchnk ) - call outfld( trim(solsym(m))//'_SRF', mmr(:ncol,pver,m), ncol ,lchnk ) - else - call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) - call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) - endif -#ifdef OSLO_AERO + if ( any( aer_species == m ) .or. isAerosol(n) ) then + call outfld( solsym(m), mmr(:ncol,:,m), ncol ,lchnk ) + call outfld( trim(solsym(m))//'_SRF', mmr(:ncol,pver,m), ncol ,lchnk ) + else + call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) + call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) + endif else call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) end if -#endif -#if defined OSLO_AERO + if(n > 0) then - cloudTracerIndex = getCloudTracerIndexDirect(n) - if(cloudTracerIndex > 0)then - cloudTracerName = getCloudTracerName(n) - call pbuf_get_field(pbuf, cloudTracerIndex, cloudTracerField ) - call outfld ( trim(cloudTracerName),cloudTracerField,pcols,lchnk) - - !Treat column burden (cloud tracer) - mass_tmp(:ncol,:) = cloudTracerField(:ncol,:) *pdel(:ncol,:) * rgrav - cb(:ncol) = sum(mass_tmp(:ncol,:),2) - call outfld(trim('cb_'//trim(cloudTracerName)), cb, pcols, lchnk) - endif - !Treat column burden (normal tracer) - mass_tmp(:ncol,:) = mmr(:ncol,:,m) * pdel(:ncol,:) * rgrav - cb(:ncol) = sum(mass_tmp(:ncol,:),2) - call outfld(trim('cb_'//trim(spc_name)), cb, pcols, lchnk) - - !Sum column burden per aerosol type - if(aerosolType(n) .gt. 0)then - cb_aerosol_type(:ncol,aerosolType(n)) = & - cb_aerosol_type(:ncol,aerosolType(n)) & - + cb(:ncol) - - !Total mass mixing ratio of aerosol type - mmr_aerosol_type(:ncol,:,aerosolType(n)) = & - mmr_aerosol_type(:ncol,:,aerosolType(n)) & - + mmr(:ncol,:,m) - endif + cloudTracerIndex = getCloudTracerIndexDirect(n) + if(cloudTracerIndex > 0)then + cloudTracerName = getCloudTracerName(n) + call pbuf_get_field(pbuf, cloudTracerIndex, cloudTracerField ) + call outfld ( trim(cloudTracerName),cloudTracerField,pcols,lchnk) + + !Treat column burden (cloud tracer) + mass_tmp(:ncol,:) = cloudTracerField(:ncol,:) *pdel(:ncol,:) * rgrav + cb(:ncol) = sum(mass_tmp(:ncol,:),2) + call outfld(trim('cb_'//trim(cloudTracerName)), cb, pcols, lchnk) + endif + !Treat column burden (normal tracer) + mass_tmp(:ncol,:) = mmr(:ncol,:,m) * pdel(:ncol,:) * rgrav + cb(:ncol) = sum(mass_tmp(:ncol,:),2) + call outfld(trim('cb_'//trim(spc_name)), cb, pcols, lchnk) + + !Sum column burden per aerosol type + if(aerosolType(n) .gt. 0)then + cb_aerosol_type(:ncol,aerosolType(n)) = & + cb_aerosol_type(:ncol,aerosolType(n)) & + + cb(:ncol) + + !Total mass mixing ratio of aerosol type + mmr_aerosol_type(:ncol,:,aerosolType(n)) = & + mmr_aerosol_type(:ncol,:,aerosolType(n)) & + + mmr(:ncol,:,m) + endif end if !Check if this is a chemistry tracer -#endif call outfld( depvel_name(m), depvel(:ncol,m), ncol ,lchnk ) call outfld( depflx_name(m), depflx(:ncol,m), ncol ,lchnk ) @@ -819,9 +774,9 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf if ( any( nhx_species == m ) ) then wd_nhx(:ncol) = wd_nhx(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) endif -! -! add contribution from non-conservation tracers -! + ! + ! add contribution from non-conservation tracers + ! if ( id_ndep == m ) then wd_noy(:ncol) = wd_noy(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) end if @@ -835,9 +790,9 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf end do end do call outfld( dtchem_name(m), net_chem(:ncol,:), ncol, lchnk ) -! -! CCMI -! + ! + ! CCMI + ! if ( trim(dtchem_name(m)) == 'DO3CHM' ) then do3chm_trp(:) = 0._r8 do i=1,ncol @@ -862,15 +817,13 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf end where call outfld('DO3CHM_LMS',do3chm_lms(:ncol), ncol, lchnk ) end if -! + ! enddo -#ifdef OSLO_AERO do n=1,N_AEROSOL_TYPES call outfld("mmr_"//trim(aerosol_type_name(n)), mmr_aerosol_type(:ncol,:,n), ncol,lchnk) call outfld("cb_"//trim(aerosol_type_name(n)), cb_aerosol_type(:ncol,n), ncol,lchnk) - enddo -#endif + enddo call outfld( 'NOX', vmr_nox (:ncol,:), ncol, lchnk ) call outfld( 'NOY', vmr_noy (:ncol,:), ncol, lchnk ) call outfld( 'HOX', vmr_hox (:ncol,:), ncol, lchnk ) @@ -892,10 +845,10 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf call outfld( 'DF_SOX', df_sox(:ncol), ncol ,lchnk ) call outfld( 'dry_deposition_NHx_as_N', df_nhx(:ncol), ncol ,lchnk ) if (gas_wetdep_method=='NEU') then - wd_noy(:ncol) = -wd_noy(:ncol) ! downward is possitive - wd_nhx(:ncol) = -wd_nhx(:ncol) - call outfld( 'wet_deposition_NOy_as_N', wd_noy(:ncol), ncol, lchnk ) - call outfld( 'wet_deposition_NHx_as_N', wd_nhx(:ncol), ncol, lchnk ) + wd_noy(:ncol) = -wd_noy(:ncol) ! downward is possitive + wd_nhx(:ncol) = -wd_nhx(:ncol) + call outfld( 'wet_deposition_NOy_as_N', wd_noy(:ncol), ncol, lchnk ) + call outfld( 'wet_deposition_NHx_as_N', wd_nhx(:ncol), ncol, lchnk ) end if nhx_nitrogen_flx = df_nhx + wd_nhx @@ -1000,11 +953,7 @@ end subroutine chm_diags subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) use cam_history, only : outfld -#ifndef OSLO_AERO - use phys_grid, only : get_wght_all_p -#else use phys_grid, only : get_wght_all_p, get_area_all_p -#endif implicit none integer, intent(in) :: lchnk @@ -1014,9 +963,7 @@ subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) real(r8), intent(in) :: pdel(ncol,pver) real(r8), dimension(ncol) :: noy_wk, sox_wk, nhx_wk, wrk_wd -#ifdef OSLO_AERO real(r8), dimension(ncol) :: area -#endif OSLO_AERO integer :: m, k real(r8) :: wght(ncol) ! @@ -1026,10 +973,8 @@ subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) sox_wk(:) = 0._r8 nhx_wk(:) = 0._r8 -#ifdef OSLO_AERO call get_area_all_p(lchnk, ncol, area) area = area * rearth**2 -#endif OSLO_AERO call get_wght_all_p(lchnk, ncol, wght) @@ -1046,9 +991,7 @@ subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) ! if (gas_wetdep_method=='MOZ') then call outfld( wetdep_name(m), wrk_wd(:ncol), ncol, lchnk ) -#ifdef OSLO_AERO call outfld( wetdep_name_area(m), wrk_wd(:ncol)/area(:ncol) ,ncol, lchnk ) -#endif call outfld( wtrate_name(m), het_rates(:ncol,:,m), ncol, lchnk ) if ( any(noy_species == m ) ) then diff --git a/src/chemistry/oslo_aero/mo_drydep.F90 b/src/chemistry/oslo_aero/mo_drydep.F90 index e81f3d66f7..b3c033c8d8 100644 --- a/src/chemistry/oslo_aero/mo_drydep.F90 +++ b/src/chemistry/oslo_aero/mo_drydep.F90 @@ -4,9 +4,6 @@ module mo_drydep ! ... Dry deposition velocity input data and code for netcdf input !--------------------------------------------------------------------- -!LKE (10/11/2010): added HCN, CH3CN, HCOOH -!LKE (7/30/2015): added new TS1 species (phenooh, iepox, noa, etc.) - use shr_kind_mod, only : r8 => shr_kind_r8, shr_kind_cl use chem_mods, only : gas_pcnst use pmgrid, only : plev, plevp @@ -26,8 +23,6 @@ module mo_drydep implicit none - save - interface drydep_inti module procedure dvel_inti_table module procedure dvel_inti_xactive @@ -1616,9 +1611,7 @@ subroutine dvel_inti_xactive( depvel_lnd_file, clim_soilw_file, season_wes_file ! determine if modal aerosols are active so that fraction_landuse array is initialized for modal aerosal dry dep call phys_getopts(prog_modal_aero_out=prog_modal_aero) -#ifdef OSLO_AERO prog_modal_aero = .TRUE. -#endif call dvel_inti_fromlnd() diff --git a/src/chemistry/oslo_aero/mo_setsox.F90 b/src/chemistry/oslo_aero/mo_setsox.F90 index 669d8e7e17..d2c20b8d4d 100644 --- a/src/chemistry/oslo_aero/mo_setsox.F90 +++ b/src/chemistry/oslo_aero/mo_setsox.F90 @@ -1,4 +1,3 @@ - module MO_SETSOX use shr_kind_mod, only : r8 => shr_kind_r8 @@ -8,7 +7,6 @@ module MO_SETSOX public :: sox_inti, setsox public :: has_sox - save logical :: inv_o3 integer :: id_msa @@ -23,8 +21,8 @@ module MO_SETSOX contains -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- + !----------------------------------------------------------------------- + !----------------------------------------------------------------------- subroutine sox_inti !----------------------------------------------------------------------- ! ... initialize the hetero sox routine @@ -35,23 +33,17 @@ subroutine sox_inti use phys_control, only : phys_getopts use sox_cldaero_mod, only : sox_cldaero_init - implicit none - - - call phys_getopts( & - prog_modal_aero_out=modal_aerosols ) + call phys_getopts(prog_modal_aero_out=modal_aerosols ) cloud_borne = modal_aerosols -#ifdef OSLO_AERO - cloud_borne = .TRUE. - modal_aerosols = .TRUE. -#endif + cloud_borne = .TRUE. + modal_aerosols = .TRUE. !----------------------------------------------------------------- ! ... get species indicies !----------------------------------------------------------------- - + if (cloud_borne) then id_h2so4 = get_spc_ndx( 'H2SO4' ) else @@ -131,9 +123,9 @@ subroutine sox_inti call sox_cldaero_init() end subroutine sox_inti - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- + + !----------------------------------------------------------------------- + !----------------------------------------------------------------------- subroutine SETSOX( & ncol, & lchnk, & @@ -183,9 +175,6 @@ subroutine SETSOX( & use sox_cldaero_mod, only : sox_cldaero_update, sox_cldaero_create_obj, sox_cldaero_destroy_obj use cldaero_mod, only : cldaero_conc_t - ! - implicit none - ! !----------------------------------------------------------------------- ! ... Dummy arguments !----------------------------------------------------------------------- @@ -369,13 +358,13 @@ subroutine SETSOX( & if (id_msa > 0) xmsa (:,k) = qin(:,k,id_msa) end do - + !----------------------------------------------------------------- ! ... Temperature dependent Henry constants !----------------------------------------------------------------- ver_loop0: do k = 1,pver !! pver loop for STEP 0 col_loop0: do i = 1,ncol - + if (cloud_borne .and. cldfrc(i,k)>0._r8) then xso4(i,k) = xso4c(i,k) / cldfrc(i,k) xnh4(i,k) = xnh4c(i,k) / cldfrc(i,k) @@ -769,11 +758,11 @@ subroutine SETSOX( & ! (1) Seinfeld ! (2) Benkovitz !----------------------------------------------------------------- - + !............................ ! S(IV) + H2O2 = S(VI) !............................ - + IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED if (cloud_borne) then @@ -830,7 +819,7 @@ subroutine SETSOX( & xso2(i,k) = xso2(i,k) - ccc end if END IF - + if (modal_aerosols) then xdelso4hp(i,k) = xso4(i,k) - xso4_init(i,k) endif @@ -844,7 +833,7 @@ subroutine SETSOX( & * xl & ! [mole/L(a)/s] / const0 & ! [/L(a)/s] / xhnm(i,k) ! [mixing ratio/s] - + ccc = pso4*dtime ccc = max(ccc, 1.e-30_r8) @@ -867,7 +856,7 @@ subroutine SETSOX( & ncol, lchnk, loffset, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, cldconc%xlwc, & xdelso4hp, xh2so4, xso4, xso4_init, nh3g, hno3g, xnh3, xhno3, xnh4c, xno3c, xmsa, xso2, xh2o2, qcw, qin, & aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d=aqso4_h2o2_3d, aqso4_o3_3d=aqso4_o3_3d ) - + xphlwc(:,:) = 0._r8 do k = 1, pver do i = 1, ncol diff --git a/src/chemistry/oslo_aero/mo_srf_emissions.F90 b/src/chemistry/oslo_aero/mo_srf_emissions.F90 index f4e5549266..53fcb4218b 100644 --- a/src/chemistry/oslo_aero/mo_srf_emissions.F90 +++ b/src/chemistry/oslo_aero/mo_srf_emissions.F90 @@ -12,9 +12,7 @@ module mo_srf_emissions use ppgrid, only : pcols, begchunk, endchunk use cam_logfile, only : iulog use tracer_data, only : trfld,trfile -#ifdef OSLO_AERO use oslo_ocean_intr, only: oslo_dms_inq -#endif implicit none diff --git a/src/chemistry/oslo_aero/mo_usrrxt.F90 b/src/chemistry/oslo_aero/mo_usrrxt.F90 index 7834085cd8..ea1c1ef559 100644 --- a/src/chemistry/oslo_aero/mo_usrrxt.F90 +++ b/src/chemistry/oslo_aero/mo_usrrxt.F90 @@ -3,18 +3,13 @@ module mo_usrrxt use shr_kind_mod, only : r8 => shr_kind_r8 use cam_logfile, only : iulog use ppgrid, only : pver, pcols -#ifdef OSLO_AERO -! use aerosoldef, only: nmodes_oslo=> nmodes, lifeCycleNumberMedianRadius - use commondefinitions, only: nmodes_oslo=> nmodes -#endif + use commondefinitions, only: nmodes_oslo=> nmodes implicit none private public :: usrrxt, usrrxt_inti, usrrxt_hrates - save - integer :: usr_O_O2_ndx integer :: usr_HO2_HO2_ndx integer :: usr_N2O5_M_ndx @@ -574,13 +569,7 @@ subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, & real(r8), pointer :: sfc_array(:,:,:), dm_array(:,:,:) -#ifdef OSLO_AERO ntot_amode = nmodes_oslo -#else - ! get info about the modal aerosols - ! get ntot_amode - call rad_cnst_get_info(0, nmodes=ntot_amode) -#endif if (ntot_amode>0) then allocate(sfc_array(pcols,pver,ntot_amode), dm_array(pcols,pver,ntot_amode) ) else @@ -1518,11 +1507,7 @@ subroutine comp_exp( x, y, n ) real(r8), intent(in) :: y(:) integer, intent(in) :: n -#ifdef IBM - call vexp( x, y, n ) -#else x(:n) = exp( y(:n) ) -#endif end subroutine comp_exp diff --git a/src/chemistry/oslo_aero/parmix_progncdnc.F90 b/src/chemistry/oslo_aero/parmix_progncdnc.F90 index fdbc076bb7..22e621d9b8 100644 --- a/src/chemistry/oslo_aero/parmix_progncdnc.F90 +++ b/src/chemistry/oslo_aero/parmix_progncdnc.F90 @@ -291,8 +291,6 @@ subroutine partitionMass( ncol & !I [nbr] number of columns used real(r8) :: total real(r8) :: fraction(pcols,pver,pcnst) !ak: oversized, but only for test use !--test -#undef EXTRATESTS - call modalapp2d_sub(ncol & ,Nnatk(1,1,1) & !I [#/m3] Total number concentration (skip mode 0) @@ -310,95 +308,6 @@ subroutine partitionMass( ncol & !I [nbr] number of columns used ,f_soam & ) -#ifdef EXTRATESTS - !++testing - fraction(:,:,:)=0.0_r8 - do m=1,nbmodes - do l = 1, getNumberOfTracersInMode(m) - lptr = getTracerIndex(m,l,.false.) - do k=1,pver - do i=1,ncol - fraction(i,k,lptr) = fraction(i,k,lptr) & - + getConstituentFraction(CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) & - ,Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), f_so4_condm(i,k,m),f_soam(i,k,m), lptr ) - end do - end do - enddo - enddo - - !testing that the mass fractions summed over all modes and species = 1 (or 0 if not present). - do m1=1,pcnst - do k=1, pver - do i=1,ncol - !Check if "fraction" differs from one (accept 0.01 error), only check for concentrations > 1.e-30 kg/m3 - if((abs(fraction(i,k,m1)-1.0_r8) .gt. 1.e-2) .and. (fraction(i,k,m1).gt.0.0_r8) .and. (CProcessModes(i,k) .gt. 1.e-30_r8) )then - if( ( m1 .eq. l_so4_a1 .and. (1.0_r8-f_c(i,k))*(1.0_r8-f_aq(i,k))*f_so4_cond(i,k) .gt. 1.0e-4_r8).or. & - ( m1 .eq. l_so4_a2 .and. (1.0_r8-f_c(i,k))*f_aq(i,k) .gt. 1.0e-4_r8).or. & - ( m1 .eq. l_so4_ac .and. (1.0_r8-f_c(i,k))*(1.0_r8-f_aq(i,k))*(1.0_r8-f_so4_cond(i,k)) .gt. 1.0e-4_r8).or. & - ( m1 .eq. l_bc_ac .and. f_c(i,k)*f_bc(i,k) .gt. 1.0e-4_r8).or. & - ( m1 .eq. l_om_ac .and. f_c(i,k)*(1.0_r8-f_bc(i,k))*(1.0_r8 - f_soa(i,k)) .gt. 1.0e-4_r8) .or. & - ( m1 .eq. l_soa_a1 .and. f_c(i,k)*(1.0_r8-f_bc(i,k))*f_soa(i,k) .gt. 1.0e-4_r8) & - )then - - print*," " - print*,"fraction error ", m1, fraction(i,k,m1), cnst_name(m1) - print*, "Cprocessmodes", CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) - do l=1,nbmodes - print*, "mode, cam", l, cam(i,k,l),nnatk(i,k,l) - enddo - print*,"ca, sum(cam)", CProcessModes(i,k), sum(cam(i,k,:)) - print*,"sulfate fraction", (1.0_r8 - f_c(i,k)) - print*,"carbon fraction", f_c(i,k) - print*,"non aq sulf fraction", (1.0_r8 - f_aq(i,k))*(1.0_r8 - f_c(i,k)) - !There is something wrong with tracer lptr - do m=1,nmodes - do l =1,getNumberOfTracersInMode(m) - lptr = getTracerIndex(m,l,.false.) - if(lptr .eq. m1)then !This is the tracer with problems - print*, "lptr, fraction ", m,l,lptr, & - getConstituentFraction(CProcessModes(i,k), f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k) & - ,Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), f_so4_condm(i,k,m) , f_soam(i,k,m), lptr,.TRUE. ) & - , NNatk(i,k,m),cam(i,k,m),numberFractionAvailableAqChem(m) - - endif - enddo - enddo - do m=1,nbmodes - print*,"sulfate / c, aq ", m, (1.0_r8-f_acm(i,k,m)), f_acm(i,k,m)& - ,f_aqm(i,k,m), f_so4_condm(i,k,m), f_so4_condm(i,k,m), f_soam(i,k,m) - enddo - - stop !stop on error - endif !if tracer has error - endif !if budget is wrong - enddo - enddo - enddo - - - !Check total carbon - do k=1,pver - do i=1,ncol - total=0.0_r8 - do kcomp=1,nbmodes - total = total + cam(i,k,kcomp)*f_acm(i,k,kcomp) - enddo - if( ABS(total - CProcessModes(i,k)*f_c(i,k)) .gt. 1.e-2_r8*CProcessModes(i,k) )then - if(abs(total) > 1.e-25)then - print*,"CProcessModes", CProcessModes(i,k), total, abs(total - CProcessModes(i,k)*f_c(i,k)) - do kcomp=1,nbmodes - print*,"fcm,cam,fc,ctot", f_acm(i,k,kcomp), cam(i,k,kcomp), f_c(i,k), CProcessModes(i,k) - enddo - stop - endif - endif - end do - end do - - !--testing -#endif - !EXTRATESTS - end subroutine partitionMass !************************************************************* diff --git a/src/chemistry/oslo_aero/vertical_diffusion.F90 b/src/chemistry/oslo_aero/vertical_diffusion.F90 index ad433bb680..a1477e3958 100644 --- a/src/chemistry/oslo_aero/vertical_diffusion.F90 +++ b/src/chemistry/oslo_aero/vertical_diffusion.F90 @@ -1,1561 +1,1499 @@ module vertical_diffusion -!----------------------------------------------------------------------------------------------------- ! -! Module to compute vertical diffusion of momentum, moisture, trace constituents ! -! and static energy. Separate modules compute ! -! 1. stresses associated with turbulent flow over orography ! -! ( turbulent mountain stress ) ! -! 2. eddy diffusivities, including nonlocal tranport terms ! -! 3. molecular diffusivities ! -! Lastly, a implicit diffusion solver is called, and tendencies retrieved by ! -! differencing the diffused and initial states. ! -! ! -! Calling sequence: ! -! ! -! vertical_diffusion_init Initializes vertical diffustion constants and modules ! -! init_molec_diff Initializes molecular diffusivity module ! -! init_eddy_diff Initializes eddy diffusivity module (includes PBL) ! -! init_tms Initializes turbulent mountain stress module ! -! init_vdiff Initializes diffusion solver module ! -! vertical_diffusion_ts_init Time step initialization (only used for upper boundary condition) ! -! vertical_diffusion_tend Computes vertical diffusion tendencies ! -! compute_tms Computes turbulent mountain stresses ! -! compute_eddy_diff Computes eddy diffusivities and countergradient terms ! -! compute_vdiff Solves vertical diffusion equations, including molecular diffusivities ! -! ! -!----------------------------------------------------------------------------------------------------- ! -! Some notes on refactoring changes made in 2015, which were not quite finished. ! -! ! -! - eddy_diff_tend should really only have state, pbuf, and cam_in as inputs. The process of ! -! removing these arguments, and referring to pbuf fields instead, is not complete. ! -! ! -! - compute_vdiff was intended to be split up into three components: ! -! ! -! 1. Diffusion of winds and heat ("U", "V", and "S" in the fieldlist object). ! -! ! -! 2. Turbulent diffusion of a single constituent ! -! ! -! 3. Molecular diffusion of a single constituent ! -! ! -! This reorganization would allow the three resulting functions to each use a simpler interface ! -! than the current combined version, and possibly also remove the need to use the fieldlist ! -! object at all. ! -! ! -! - The conditionals controlled by "do_pbl_diags" are somewhat scattered. It might be better to ! -! pull out these diagnostic calculations and outfld calls into separate functions. ! -! ! -!---------------------------Code history-------------------------------------------------------------- ! -! J. Rosinski : Jun. 1992 ! -! J. McCaa : Sep. 2004 ! -! S. Park : Aug. 2006, Dec. 2008. Jan. 2010 ! -!----------------------------------------------------------------------------------------------------- ! - -use shr_kind_mod, only : r8 => shr_kind_r8, i4=> shr_kind_i4 -use ppgrid, only : pcols, pver, pverp -use constituents, only : pcnst -use diffusion_solver, only : vdiff_selector -use cam_abortutils, only : endrun -use error_messages, only : handle_errmsg -use physconst, only : & - cpair , & ! Specific heat of dry air - gravit , & ! Acceleration due to gravity - rair , & ! Gas constant for dry air - zvir , & ! rh2o/rair - 1 - latvap , & ! Latent heat of vaporization - latice , & ! Latent heat of fusion - karman , & ! von Karman constant - mwdry , & ! Molecular weight of dry air - avogad ! Avogadro's number -use cam_history, only : fieldname_len -use perf_mod -use cam_logfile, only : iulog -use ref_pres, only : do_molec_diff, nbot_molec -use phys_control, only : phys_getopts -use time_manager, only : is_first_step - -#ifdef OSLO_AERO + !----------------------------------------------------------------------------------------------------- ! + ! Module to compute vertical diffusion of momentum, moisture, trace constituents ! + ! and static energy. Separate modules compute ! + ! 1. stresses associated with turbulent flow over orography ! + ! ( turbulent mountain stress ) ! + ! 2. eddy diffusivities, including nonlocal tranport terms ! + ! 3. molecular diffusivities ! + ! Lastly, a implicit diffusion solver is called, and tendencies retrieved by ! + ! differencing the diffused and initial states. ! + ! ! + ! Calling sequence: ! + ! ! + ! vertical_diffusion_init Initializes vertical diffustion constants and modules ! + ! init_molec_diff Initializes molecular diffusivity module ! + ! init_eddy_diff Initializes eddy diffusivity module (includes PBL) ! + ! init_tms Initializes turbulent mountain stress module ! + ! init_vdiff Initializes diffusion solver module ! + ! vertical_diffusion_ts_init Time step initialization (only used for upper boundary condition) ! + ! vertical_diffusion_tend Computes vertical diffusion tendencies ! + ! compute_tms Computes turbulent mountain stresses ! + ! compute_eddy_diff Computes eddy diffusivities and countergradient terms ! + ! compute_vdiff Solves vertical diffusion equations, including molecular diffusivities ! + ! ! + !----------------------------------------------------------------------------------------------------- ! + ! Some notes on refactoring changes made in 2015, which were not quite finished. ! + ! ! + ! - eddy_diff_tend should really only have state, pbuf, and cam_in as inputs. The process of ! + ! removing these arguments, and referring to pbuf fields instead, is not complete. ! + ! ! + ! - compute_vdiff was intended to be split up into three components: ! + ! ! + ! 1. Diffusion of winds and heat ("U", "V", and "S" in the fieldlist object). ! + ! ! + ! 2. Turbulent diffusion of a single constituent ! + ! ! + ! 3. Molecular diffusion of a single constituent ! + ! ! + ! This reorganization would allow the three resulting functions to each use a simpler interface ! + ! than the current combined version, and possibly also remove the need to use the fieldlist ! + ! object at all. ! + ! ! + ! - The conditionals controlled by "do_pbl_diags" are somewhat scattered. It might be better to ! + ! pull out these diagnostic calculations and outfld calls into separate functions. ! + ! ! + !---------------------------Code history-------------------------------------------------------------- ! + ! J. Rosinski : Jun. 1992 ! + ! J. McCaa : Sep. 2004 ! + ! S. Park : Aug. 2006, Dec. 2008. Jan. 2010 ! + !----------------------------------------------------------------------------------------------------- ! + + use shr_kind_mod, only : r8 => shr_kind_r8, i4=> shr_kind_i4 + use ppgrid, only : pcols, pver, pverp + use constituents, only : pcnst + use diffusion_solver, only : vdiff_selector + use cam_abortutils, only : endrun + use error_messages, only : handle_errmsg + use physconst, only : & + cpair , & ! Specific heat of dry air + gravit , & ! Acceleration due to gravity + rair , & ! Gas constant for dry air + zvir , & ! rh2o/rair - 1 + latvap , & ! Latent heat of vaporization + latice , & ! Latent heat of fusion + karman , & ! von Karman constant + mwdry , & ! Molecular weight of dry air + avogad ! Avogadro's number + use cam_history, only : fieldname_len + use perf_mod + use cam_logfile, only : iulog + use ref_pres, only : do_molec_diff, nbot_molec + use phys_control, only : phys_getopts + use time_manager, only : is_first_step use aerosoldef, only: getNumberOfAerosolTracers, fillAerosolTracerList -#endif - -implicit none -private -save - -! ----------------- ! -! Public interfaces ! -! ----------------- ! - -public vd_readnl -public vd_register ! Register multi-time-level variables with physics buffer -public vertical_diffusion_init ! Initialization -public vertical_diffusion_ts_init ! Time step initialization (only used for upper boundary condition) -public vertical_diffusion_tend ! Full vertical diffusion routine - -! ------------ ! -! Private data ! -! ------------ ! - -character(len=16) :: eddy_scheme ! Default set in phys_control.F90, use namelist to change -! 'HB' = Holtslag and Boville (default) -! 'HBR' = Holtslag and Boville and Rash -! 'diag_TKE' = Bretherton and Park ( UW Moist Turbulence Scheme ) -logical, parameter :: wstarent = .true. ! Use wstar (.true.) or TKE (.false.) entrainment closure -! ( when 'diag_TKE' scheme is selected ) -logical :: do_pseudocon_diff = .false. ! If .true., do pseudo-conservative variables diffusion - -character(len=16) :: shallow_scheme ! Shallow convection scheme - -type(vdiff_selector) :: fieldlist_wet ! Logical switches for moist mixing ratio diffusion -type(vdiff_selector) :: fieldlist_dry ! Logical switches for dry mixing ratio diffusion -type(vdiff_selector) :: fieldlist_molec ! Logical switches for molecular diffusion -integer :: tke_idx, kvh_idx, kvm_idx ! TKE and eddy diffusivity indices for fields in the physics buffer -integer :: kvt_idx ! Index for kinematic molecular conductivity -integer :: turbtype_idx, smaw_idx ! Turbulence type and instability functions -integer :: tauresx_idx, tauresy_idx ! Redisual stress for implicit surface stress - -character(len=fieldname_len) :: vdiffnam(pcnst) ! Names of vertical diffusion tendencies -integer :: ixcldice, ixcldliq ! Constituent indices for cloud liquid and ice water -integer :: ixnumice, ixnumliq - -integer :: pblh_idx, tpert_idx, qpert_idx - -! pbuf fields for unicon -integer :: qtl_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on -integer :: qti_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on - -! pbuf fields for tms -integer :: ksrftms_idx = -1 -integer :: tautmsx_idx = -1 -integer :: tautmsy_idx = -1 - -! pbuf fields for blj (Beljaars) -integer :: dragblj_idx = -1 -integer :: taubljx_idx = -1 -integer :: taubljy_idx = -1 - -logical :: diff_cnsrv_mass_check ! do mass conservation check -logical :: do_iss ! switch for implicit turbulent surface stress -logical :: prog_modal_aero = .false. ! set true if prognostic modal aerosols are present -integer :: pmam_ncnst = 0 ! number of prognostic modal aerosol constituents -integer, allocatable :: pmam_cnst_idx(:) ! constituent indices of prognostic modal aerosols - -logical :: do_pbl_diags = .false. -logical :: waccmx_mode = .false. -contains - - ! =============================================================================== ! - ! ! - ! =============================================================================== ! -subroutine vd_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: masterproc, masterprocid, mpi_logical, mpicom - use shr_log_mod, only: errMsg => shr_log_errMsg - use trb_mtn_stress_cam, only: trb_mtn_stress_readnl - use beljaars_drag_cam, only: beljaars_drag_readnl - use eddy_diff_cam, only: eddy_diff_readnl - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'vd_readnl' - - namelist /vert_diff_nl/ diff_cnsrv_mass_check, do_iss - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'vert_diff_nl', status=ierr) - if (ierr == 0) then - read(unitn, vert_diff_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if - - call mpi_bcast(diff_cnsrv_mass_check, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") - call mpi_bcast(do_iss, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") - - ! Get eddy_scheme setting from phys_control. - call phys_getopts( eddy_scheme_out = eddy_scheme, & - shallow_scheme_out = shallow_scheme ) - - ! TMS reads its own namelist. - call trb_mtn_stress_readnl(nlfile) - - ! Beljaars reads its own namelist. - call beljaars_drag_readnl(nlfile) - - if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005' ) call eddy_diff_readnl(nlfile) - -end subroutine vd_readnl + implicit none + private + + ! ----------------- ! + ! Public interfaces ! + ! ----------------- ! + + public vd_readnl + public vd_register ! Register multi-time-level variables with physics buffer + public vertical_diffusion_init ! Initialization + public vertical_diffusion_ts_init ! Time step initialization (only used for upper boundary condition) + public vertical_diffusion_tend ! Full vertical diffusion routine + + ! ------------ ! + ! Private data ! + ! ------------ ! + + character(len=16) :: eddy_scheme ! Default set in phys_control.F90, use namelist to change + ! 'HB' = Holtslag and Boville (default) + ! 'HBR' = Holtslag and Boville and Rash + ! 'diag_TKE' = Bretherton and Park ( UW Moist Turbulence Scheme ) + logical, parameter :: wstarent = .true. ! Use wstar (.true.) or TKE (.false.) entrainment closure + ! ( when 'diag_TKE' scheme is selected ) + logical :: do_pseudocon_diff = .false. ! If .true., do pseudo-conservative variables diffusion + + character(len=16) :: shallow_scheme ! Shallow convection scheme + + type(vdiff_selector) :: fieldlist_wet ! Logical switches for moist mixing ratio diffusion + type(vdiff_selector) :: fieldlist_dry ! Logical switches for dry mixing ratio diffusion + type(vdiff_selector) :: fieldlist_molec ! Logical switches for molecular diffusion + integer :: tke_idx, kvh_idx, kvm_idx ! TKE and eddy diffusivity indices for fields in the physics buffer + integer :: kvt_idx ! Index for kinematic molecular conductivity + integer :: turbtype_idx, smaw_idx ! Turbulence type and instability functions + integer :: tauresx_idx, tauresy_idx ! Redisual stress for implicit surface stress + + character(len=fieldname_len) :: vdiffnam(pcnst) ! Names of vertical diffusion tendencies + integer :: ixcldice, ixcldliq ! Constituent indices for cloud liquid and ice water + integer :: ixnumice, ixnumliq + + integer :: pblh_idx, tpert_idx, qpert_idx + + ! pbuf fields for unicon + integer :: qtl_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on + integer :: qti_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on + + ! pbuf fields for tms + integer :: ksrftms_idx = -1 + integer :: tautmsx_idx = -1 + integer :: tautmsy_idx = -1 + + ! pbuf fields for blj (Beljaars) + integer :: dragblj_idx = -1 + integer :: taubljx_idx = -1 + integer :: taubljy_idx = -1 + + logical :: diff_cnsrv_mass_check ! do mass conservation check + logical :: do_iss ! switch for implicit turbulent surface stress + logical :: prog_modal_aero = .false. ! set true if prognostic modal aerosols are present + integer :: pmam_ncnst = 0 ! number of prognostic modal aerosol constituents + integer, allocatable :: pmam_cnst_idx(:) ! constituent indices of prognostic modal aerosols + + logical :: do_pbl_diags = .false. + logical :: waccmx_mode = .false. ! =============================================================================== ! -! ! +contains ! =============================================================================== ! -subroutine vd_register() + subroutine vd_readnl(nlfile) - !------------------------------------------------ ! - ! Register physics buffer fields and constituents ! - !------------------------------------------------ ! + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: masterproc, masterprocid, mpi_logical, mpicom + use shr_log_mod, only: errMsg => shr_log_errMsg + use trb_mtn_stress_cam, only: trb_mtn_stress_readnl + use beljaars_drag_cam, only: beljaars_drag_readnl + use eddy_diff_cam, only: eddy_diff_readnl - use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 - use trb_mtn_stress_cam, only : trb_mtn_stress_register - use beljaars_drag_cam, only : beljaars_drag_register - use eddy_diff_cam, only : eddy_diff_register + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - ! Add fields to physics buffer + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'vd_readnl' - ! kvt is used by gw_drag. only needs physpkg scope. - call pbuf_add_field('kvt', 'physpkg', dtype_r8, (/pcols,pverp/), kvt_idx) + namelist /vert_diff_nl/ diff_cnsrv_mass_check, do_iss + !----------------------------------------------------------------------------- + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'vert_diff_nl', status=ierr) + if (ierr == 0) then + read(unitn, vert_diff_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if - if (eddy_scheme /= 'CLUBB_SGS') then - call pbuf_add_field('kvh', 'global', dtype_r8, (/pcols, pverp/), kvh_idx) - end if + call mpi_bcast(diff_cnsrv_mass_check, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") + call mpi_bcast(do_iss, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") - call pbuf_add_field('kvm', 'global', dtype_r8, (/pcols, pverp/), kvm_idx ) - call pbuf_add_field('pblh', 'global', dtype_r8, (/pcols/), pblh_idx) - call pbuf_add_field('tke', 'global', dtype_r8, (/pcols, pverp/), tke_idx) - call pbuf_add_field('turbtype', 'global', dtype_i4, (/pcols, pverp/), turbtype_idx) - call pbuf_add_field('smaw', 'global', dtype_r8, (/pcols, pverp/), smaw_idx) + ! Get eddy_scheme setting from phys_control. + call phys_getopts( eddy_scheme_out = eddy_scheme, & + shallow_scheme_out = shallow_scheme ) - call pbuf_add_field('tauresx', 'global', dtype_r8, (/pcols/), tauresx_idx) - call pbuf_add_field('tauresy', 'global', dtype_r8, (/pcols/), tauresy_idx) + ! TMS reads its own namelist. + call trb_mtn_stress_readnl(nlfile) - call pbuf_add_field('tpert', 'global', dtype_r8, (/pcols/), tpert_idx) - call pbuf_add_field('qpert', 'global', dtype_r8, (/pcols,pcnst/), qpert_idx) + ! Beljaars reads its own namelist. + call beljaars_drag_readnl(nlfile) - if (trim(shallow_scheme) == 'UNICON') then - call pbuf_add_field('qtl_flx', 'global', dtype_r8, (/pcols, pverp/), qtl_flx_idx) - call pbuf_add_field('qti_flx', 'global', dtype_r8, (/pcols, pverp/), qti_flx_idx) - end if + if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005' ) call eddy_diff_readnl(nlfile) - ! diag_TKE fields - if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005') then - call eddy_diff_register() - end if + end subroutine vd_readnl - ! TMS fields - call trb_mtn_stress_register() + ! =============================================================================== ! + subroutine vd_register() - ! Beljaars fields - call beljaars_drag_register() + !------------------------------------------------ ! + ! Register physics buffer fields and constituents ! + !------------------------------------------------ ! -end subroutine vd_register + use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 + use trb_mtn_stress_cam, only : trb_mtn_stress_register + use beljaars_drag_cam, only : beljaars_drag_register + use eddy_diff_cam, only : eddy_diff_register -! =============================================================================== ! -! ! -! =============================================================================== ! + ! Add fields to physics buffer -subroutine vertical_diffusion_init(pbuf2d) - - !------------------------------------------------------------------! - ! Initialization of time independent fields for vertical diffusion ! - ! Calls initialization routines for subsidiary modules ! - !----------------------------------------------------------------- ! - - use cam_history, only : addfld, add_default, horiz_only - use cam_history, only : register_vector_field - use eddy_diff_cam, only : eddy_diff_init - use hb_diff, only : init_hb_diff - use molec_diff, only : init_molec_diff - use diffusion_solver, only : init_vdiff, new_fieldlist_vdiff, vdiff_select - use constituents, only : cnst_get_ind, cnst_get_type_byind, cnst_name, cnst_get_molec_byind - use spmd_utils, only : masterproc - use ref_pres, only : press_lim_idx, pref_mid - use physics_buffer, only : pbuf_set_field, pbuf_get_index, physics_buffer_desc - use rad_constituents, only : rad_cnst_get_info, rad_cnst_get_mode_num_idx, & - rad_cnst_get_mam_mmr_idx - use trb_mtn_stress_cam,only : trb_mtn_stress_init - use beljaars_drag_cam, only : beljaars_drag_init - use upper_bc, only : ubc_init - use phys_control, only : waccmx_is, fv_am_correction - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - character(128) :: errstring ! Error status for init_vdiff - integer :: ntop_eddy ! Top interface level to which eddy vertical diffusion is applied ( = 1 ) - integer :: nbot_eddy ! Bottom interface level to which eddy vertical diffusion is applied ( = pver ) - integer :: k ! Vertical loop index - - real(r8), parameter :: ntop_eddy_pres = 1.e-5_r8 ! Pressure below which eddy diffusion is not done in WACCM-X. (Pa) - - integer :: im, l, m, nmodes, nspec - - logical :: history_amwg ! output the variables used by the AMWG diag package - logical :: history_eddy ! output the eddy variables - logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi - integer :: history_budget_histfile_num ! output history file number for budget fields - logical :: history_waccm ! output variables of interest for WACCM runs - - ! ----------------------------------------------------------------- ! - - if (masterproc) then - write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)' - end if - - ! Check to see if WACCM-X is on (currently we don't care whether the - ! ionosphere is on or not, since this neutral diffusion code is the - ! same either way). - waccmx_mode = waccmx_is('ionosphere') .or. waccmx_is('neutral') - - ! ----------------------------------------------------------------- ! - ! Get indices of cloud liquid and ice within the constituents array ! - ! ----------------------------------------------------------------- ! - - call cnst_get_ind( 'CLDLIQ', ixcldliq ) - call cnst_get_ind( 'CLDICE', ixcldice ) - ! These are optional; with the CAM4 microphysics, there are no number - ! constituents. - call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. ) - call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. ) - - ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. - call phys_getopts(prog_modal_aero_out=prog_modal_aero) -#ifdef OSLO_AERO - prog_modal_aero = .TRUE. -#endif - if (prog_modal_aero) then - - ! Get the constituent indices of the number and mass mixing ratios of the modal - ! aerosols. - ! - ! N.B. - This implementation assumes that the prognostic modal aerosols are - ! impacting the climate calculation (i.e., can get info from list 0). - ! -#ifndef OSLO_AERO - !NOTE THAT THIS BREAKS THE CONCEPT OF KEEPEING MAM-AEROSOLS OUT OF - !DIFFUSION, BUT IF YOU ARE USING MAM, YOU SHOULD NOT BEE HERE ANYWAY!! - ! First need total number of mam constituents - call rad_cnst_get_info(0, nmodes=nmodes) - do m = 1, nmodes - call rad_cnst_get_info(0, m, nspec=nspec) - pmam_ncnst = pmam_ncnst + 1 + nspec - end do - - allocate(pmam_cnst_idx(pmam_ncnst)) - - ! Get the constituent indicies - im = 1 - do m = 1, nmodes - call rad_cnst_get_mode_num_idx(m, pmam_cnst_idx(im)) - im = im + 1 - call rad_cnst_get_info(0, m, nspec=nspec) - do l = 1, nspec - call rad_cnst_get_mam_mmr_idx(m, l, pmam_cnst_idx(im)) - im = im + 1 - end do - end do -#else if (defined OSLO_AERO) - pmam_ncnst = getNumberOfAerosolTracers() - allocate(pmam_cnst_idx(pmam_ncnst)) - call fillAerosolTracerList(pmam_cnst_idx) -#endif - end if - - ! Initialize upper boundary condition module - - call ubc_init() - - ! ---------------------------------------------------------------------------------------- ! - ! Initialize molecular diffusivity module ! - ! Note that computing molecular diffusivities is a trivial expense, but constituent ! - ! diffusivities depend on their molecular weights. Decomposing the diffusion matrix ! - ! for each constituent is a needless expense unless the diffusivity is significant. ! - ! ---------------------------------------------------------------------------------------- ! - - !---------------------------------------------------------------------------------------- - ! Initialize molecular diffusion and get top and bottom molecular diffusion limits - !---------------------------------------------------------------------------------------- - - if( do_molec_diff ) then - call init_molec_diff( r8, pcnst, mwdry, avogad, & - errstring) - - call handle_errmsg(errstring, subname="init_molec_diff") - - call addfld( 'TTPXMLC', horiz_only, 'A', 'K/S', 'Top interf. temp. flux: molec. viscosity' ) - if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NBOT_MOLEC =', nbot_molec - end if - - ! ---------------------------------- ! - ! Initialize eddy diffusivity module ! - ! ---------------------------------- ! - - ! ntop_eddy must be 1 or <= nbot_molec - ! Currently, it is always 1 except for WACCM-X. - if ( waccmx_mode ) then - ntop_eddy = press_lim_idx(ntop_eddy_pres, top=.true.) - else - ntop_eddy = 1 - end if - nbot_eddy = pver - - if (masterproc) write(iulog, fmt='(a,i3,5x,a,i3)') 'NTOP_EDDY =', ntop_eddy, 'NBOT_EDDY =', nbot_eddy - - select case ( eddy_scheme ) - case ( 'diag_TKE', 'SPCAM_m2005' ) - if( masterproc ) write(iulog,*) & - 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park' - call eddy_diff_init(pbuf2d, ntop_eddy, nbot_eddy) - case ( 'HB', 'HBR', 'SPCAM_sam1mom') - if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: Holtslag and Boville' - call init_hb_diff(gravit, cpair, ntop_eddy, nbot_eddy, pref_mid, & - karman, eddy_scheme) - call addfld('HB_ri', (/ 'lev' /), 'A', 'no', 'Richardson Number (HB Scheme), I' ) - case ( 'CLUBB_SGS' ) - do_pbl_diags = .true. - end select - - ! ------------------------------------------- ! - ! Initialize turbulent mountain stress module ! - ! ------------------------------------------- ! - - call trb_mtn_stress_init() - - ! ----------------------------------- ! - ! Initialize Beljaars SGO drag module ! - ! ----------------------------------- ! - - call beljaars_drag_init() - - ! ---------------------------------- ! - ! Initialize diffusion solver module ! - ! ---------------------------------- ! - - call init_vdiff(r8, iulog, rair, cpair, gravit, do_iss, fv_am_correction, errstring) - call handle_errmsg(errstring, subname="init_vdiff") - - ! Use fieldlist_wet to select the fields which will be diffused using moist mixing ratios ( all by default ) - ! Use fieldlist_dry to select the fields which will be diffused using dry mixing ratios. - - fieldlist_wet = new_fieldlist_vdiff( pcnst) - fieldlist_dry = new_fieldlist_vdiff( pcnst) - fieldlist_molec = new_fieldlist_vdiff( pcnst) - - if( vdiff_select( fieldlist_wet, 'u' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'u' ) ) - if( vdiff_select( fieldlist_wet, 'v' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'v' ) ) - if( vdiff_select( fieldlist_wet, 's' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 's' ) ) - - constit_loop: do k = 1, pcnst - - if (prog_modal_aero) then - ! Do not diffuse droplet number - treated in dropmixnuc - if (k == ixnumliq) cycle constit_loop - ! Don't diffuse modal aerosol - treated in dropmixnuc - do m = 1, pmam_ncnst - if (k == pmam_cnst_idx(m)) cycle constit_loop - enddo - end if - - if( cnst_get_type_byind(k) .eq. 'wet' ) then - if( vdiff_select( fieldlist_wet, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'q', k ) ) - else - if( vdiff_select( fieldlist_dry, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_dry, 'q', k ) ) - endif - - ! ----------------------------------------------- ! - ! Select constituents for molecular diffusion ! - ! ----------------------------------------------- ! - if ( cnst_get_molec_byind(k) .eq. 'minor' ) then - if( vdiff_select(fieldlist_molec,'q',k) .ne. '' ) call endrun( vdiff_select( fieldlist_molec,'q',k ) ) - endif - - end do constit_loop - - ! ------------------------ ! - ! Diagnostic output fields ! - ! ------------------------ ! - - do k = 1, pcnst - vdiffnam(k) = 'VD'//cnst_name(k) - if( k == 1 ) vdiffnam(k) = 'VD01' !**** compatibility with old code **** - call addfld( vdiffnam(k), (/ 'lev' /), 'A', 'kg/kg/s', 'Vertical diffusion of '//cnst_name(k) ) - end do - - if (.not. do_pbl_diags) then - call addfld( 'PBLH' , horiz_only , 'A', 'm' , 'PBL height' ) - call addfld( 'QT' , (/ 'lev' /) , 'A', 'kg/kg' , 'Total water mixing ratio' ) - call addfld( 'SL' , (/ 'lev' /) , 'A', 'J/kg' , 'Liquid water static energy' ) - call addfld( 'SLV' , (/ 'lev' /) , 'A', 'J/kg' , 'Liq wat virtual static energy' ) - call addfld( 'SLFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Liquid static energy flux' ) - call addfld( 'QTFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Total water flux' ) - call addfld( 'TKE' , (/ 'ilev' /) , 'A', 'm2/s2' , 'Turbulent Kinetic Energy' ) - call addfld( 'TPERT' , horiz_only , 'A', 'K' , 'Perturbation temperature (eddies in PBL)' ) - call addfld( 'QPERT' , horiz_only , 'A', 'kg/kg' , 'Perturbation specific humidity (eddies in PBL)' ) - - call addfld( 'UFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Zonal momentum flux' ) - call addfld( 'VFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Meridional momentm flux' ) - call register_vector_field('UFLX', 'VFLX') - end if - - call addfld( 'USTAR' , horiz_only , 'A', 'm/s' , 'Surface friction velocity' ) - call addfld( 'KVH' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (heat/moisture)' ) - call addfld( 'KVM' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (momentum)' ) - call addfld( 'KVT' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion kinematic molecular conductivity') - call addfld( 'CGS' , (/ 'ilev' /) , 'A', 's/m2' , 'Counter-gradient coeff on surface kinematic fluxes' ) - call addfld( 'DTVKE' , (/ 'lev' /) , 'A', 'K/s' , 'dT/dt vertical diffusion KE dissipation' ) - call addfld( 'DTV' , (/ 'lev' /) , 'A', 'K/s' , 'T vertical diffusion' ) - call addfld( 'DUV' , (/ 'lev' /) , 'A', 'm/s2' , 'U vertical diffusion' ) - call addfld( 'DVV' , (/ 'lev' /) , 'A', 'm/s2' , 'V vertical diffusion' ) - - ! ---------------------------------------------------------------------------- ! - ! Below ( with '_PBL') are for detailed analysis of UW Moist Turbulence Scheme ! - ! ---------------------------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - call addfld( 'qt_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_prePBL' ) - call addfld( 'sl_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_prePBL' ) - call addfld( 'slv_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_prePBL' ) - call addfld( 'u_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_prePBL' ) - call addfld( 'v_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_prePBL' ) - call addfld( 'qv_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_prePBL' ) - call addfld( 'ql_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_prePBL' ) - call addfld( 'qi_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_prePBL' ) - call addfld( 't_pre_PBL', (/ 'lev' /) , 'A', 'K' , 't_prePBL' ) - call addfld( 'rh_pre_PBL', (/ 'lev' /) , 'A', '%' , 'rh_prePBL' ) - - call addfld( 'qt_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_afterPBL' ) - call addfld( 'sl_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_afterPBL' ) - call addfld( 'slv_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_afterPBL' ) - call addfld( 'u_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_afterPBL' ) - call addfld( 'v_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_afterPBL' ) - call addfld( 'qv_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_afterPBL' ) - call addfld( 'ql_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_afterPBL' ) - call addfld( 'qi_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_afterPBL' ) - call addfld( 't_aft_PBL', (/ 'lev' /) , 'A', 'K' , 't_afterPBL' ) - call addfld( 'rh_aft_PBL', (/ 'lev' /) , 'A', '%' , 'rh_afterPBL' ) - - call addfld( 'slflx_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl flux by PBL' ) - call addfld( 'qtflx_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt flux by PBL' ) - call addfld( 'uflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u flux by PBL' ) - call addfld( 'vflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v flux by PBL' ) - - call addfld( 'slflx_cg_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl_cg flux by PBL' ) - call addfld( 'qtflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt_cg flux by PBL' ) - call addfld( 'uflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u_cg flux by PBL' ) - call addfld( 'vflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v_cg flux by PBL' ) - - call addfld( 'qtten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qt tendency by PBL' ) - call addfld( 'slten_PBL', (/ 'lev' /) , 'A', 'J/kg/s' , 'sl tendency by PBL' ) - call addfld( 'uten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'u tendency by PBL' ) - call addfld( 'vten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'v tendency by PBL' ) - call addfld( 'qvten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qv tendency by PBL' ) - call addfld( 'qlten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'ql tendency by PBL' ) - call addfld( 'qiten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qi tendency by PBL' ) - call addfld( 'tten_PBL', (/ 'lev' /) , 'A', 'K/s' , 'T tendency by PBL' ) - call addfld( 'rhten_PBL', (/ 'lev' /) , 'A', '%/s' , 'RH tendency by PBL' ) - - end if - - call addfld ('ustar',horiz_only, 'A', ' ',' ') - call addfld ('obklen',horiz_only, 'A', ' ',' ') - - ! ---------------------------- - ! determine default variables - ! ---------------------------- - - call phys_getopts( history_amwg_out = history_amwg, & - history_eddy_out = history_eddy, & - history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num, & - history_waccm_out = history_waccm) - - if (history_amwg) then - call add_default( vdiffnam(1), 1, ' ' ) - call add_default( 'DTV' , 1, ' ' ) - if (.not. do_pbl_diags) then - call add_default( 'PBLH' , 1, ' ' ) - end if - endif - - if (history_eddy) then - call add_default( 'UFLX ', 1, ' ' ) - call add_default( 'VFLX ', 1, ' ' ) - endif - - if( history_budget ) then - call add_default( vdiffnam(ixcldliq), history_budget_histfile_num, ' ' ) - call add_default( vdiffnam(ixcldice), history_budget_histfile_num, ' ' ) -!AL - call add_default( vdiffnam(ixnumliq), history_budget_histfile_num, ' ' ) - call add_default( vdiffnam(ixnumice), history_budget_histfile_num, ' ' ) -!AL - if( history_budget_histfile_num > 1 ) then - call add_default( vdiffnam(1), history_budget_histfile_num, ' ' ) - call add_default( 'DTV' , history_budget_histfile_num, ' ' ) - end if - end if - - if ( history_waccm ) then - if (do_molec_diff) then - call add_default ( 'TTPXMLC', 1, ' ' ) - end if - call add_default( 'DUV' , 1, ' ' ) - call add_default( 'DVV' , 1, ' ' ) - end if - ! ---------------------------- - - - ksrftms_idx = pbuf_get_index('ksrftms') - tautmsx_idx = pbuf_get_index('tautmsx') - tautmsy_idx = pbuf_get_index('tautmsy') - - dragblj_idx = pbuf_get_index('dragblj') - taubljx_idx = pbuf_get_index('taubljx') - taubljy_idx = pbuf_get_index('taubljy') - - if (eddy_scheme == 'CLUBB_SGS') then - kvh_idx = pbuf_get_index('kvh') - end if - - ! Initialization of some pbuf fields - if (is_first_step()) then - ! Initialization of pbuf fields tke, kvh, kvm are done in phys_inidat - call pbuf_set_field(pbuf2d, turbtype_idx, 0 ) - call pbuf_set_field(pbuf2d, smaw_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, tauresx_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, tauresy_idx, 0.0_r8) - if (trim(shallow_scheme) == 'UNICON') then - call pbuf_set_field(pbuf2d, qtl_flx_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, qti_flx_idx, 0.0_r8) - end if - end if - -end subroutine vertical_diffusion_init + ! kvt is used by gw_drag. only needs physpkg scope. + call pbuf_add_field('kvt', 'physpkg', dtype_r8, (/pcols,pverp/), kvt_idx) -! =============================================================================== ! -! ! -! =============================================================================== ! -subroutine vertical_diffusion_ts_init( pbuf2d, state ) + if (eddy_scheme /= 'CLUBB_SGS') then + call pbuf_add_field('kvh', 'global', dtype_r8, (/pcols, pverp/), kvh_idx) + end if - !-------------------------------------------------------------- ! - ! Timestep dependent setting, ! - ! At present only invokes upper bc code ! - !-------------------------------------------------------------- ! - use upper_bc, only : ubc_timestep_init - use physics_types , only : physics_state - use ppgrid , only : begchunk, endchunk + call pbuf_add_field('kvm', 'global', dtype_r8, (/pcols, pverp/), kvm_idx ) + call pbuf_add_field('pblh', 'global', dtype_r8, (/pcols/), pblh_idx) + call pbuf_add_field('tke', 'global', dtype_r8, (/pcols, pverp/), tke_idx) + call pbuf_add_field('turbtype', 'global', dtype_i4, (/pcols, pverp/), turbtype_idx) + call pbuf_add_field('smaw', 'global', dtype_r8, (/pcols, pverp/), smaw_idx) - use physics_buffer, only : physics_buffer_desc + call pbuf_add_field('tauresx', 'global', dtype_r8, (/pcols/), tauresx_idx) + call pbuf_add_field('tauresy', 'global', dtype_r8, (/pcols/), tauresy_idx) - type(physics_state), intent(in) :: state(begchunk:endchunk) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) + call pbuf_add_field('tpert', 'global', dtype_r8, (/pcols/), tpert_idx) + call pbuf_add_field('qpert', 'global', dtype_r8, (/pcols,pcnst/), qpert_idx) - call ubc_timestep_init( pbuf2d, state) + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_add_field('qtl_flx', 'global', dtype_r8, (/pcols, pverp/), qtl_flx_idx) + call pbuf_add_field('qti_flx', 'global', dtype_r8, (/pcols, pverp/), qti_flx_idx) + end if -end subroutine vertical_diffusion_ts_init + ! diag_TKE fields + if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005') then + call eddy_diff_register() + end if -! =============================================================================== ! -! ! -! =============================================================================== ! + ! TMS fields + call trb_mtn_stress_register() -subroutine vertical_diffusion_tend( & - ztodt , state , cam_in, & - ustar , obklen , ptend , & - cldn , pbuf) - !---------------------------------------------------- ! - ! This is an interface routine for vertical diffusion ! - !---------------------------------------------------- ! - use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field - use physics_types, only : physics_state, physics_ptend, physics_ptend_init - use camsrfexch, only : cam_in_t - use cam_history, only : outfld - - use trb_mtn_stress_cam, only : trb_mtn_stress_tend - use beljaars_drag_cam, only : beljaars_drag_tend - use eddy_diff_cam, only : eddy_diff_tend - use hb_diff, only : compute_hb_diff - use wv_saturation, only : qsat - use molec_diff, only : compute_molec_diff, vd_lu_qdecomp - use constituents, only : qmincg, qmin - use diffusion_solver, only : compute_vdiff, any, operator(.not.) - use physconst, only : cpairv, rairv !Needed for calculation of upward H flux - use time_manager, only : get_nstep - use constituents, only : cnst_get_type_byind, cnst_name, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx - use physconst, only : pi - use pbl_utils, only : virtem, calc_obklen, calc_ustar - use upper_bc, only : ubc_get_vals - use coords_1d, only : Coords1D - - ! --------------- ! - ! Input Arguments ! - ! --------------- ! - - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), intent(in) :: cam_in ! Surface inputs - - real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] - real(r8), intent(in) :: cldn(pcols,pver) ! New stratus fraction [ fraction ] - - ! ---------------------- ! - ! Input-Output Arguments ! - ! ---------------------- ! - - type(physics_ptend), intent(out) :: ptend ! Individual parameterization tendencies - type(physics_buffer_desc), pointer :: pbuf(:) - - ! ---------------- ! - ! Output Arguments ! - ! ---------------- ! - - real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] - real(r8), intent(out) :: obklen(pcols) ! Obukhov length [ m ] - - ! --------------- ! - ! Local Variables ! - ! --------------- ! - - character(128) :: errstring ! Error status for compute_vdiff - - integer :: lchnk ! Chunk identifier - integer :: ncol ! Number of atmospheric columns - integer :: i, k, l, m ! column, level, constituent indices - - real(r8) :: dtk(pcols,pver) ! T tendency from KE dissipation - real(r8), pointer :: tke(:,:) ! Turbulent kinetic energy [ m2/s2 ] - integer(i4),pointer :: turbtype(:,:) ! Turbulent interface types [ no unit ] - real(r8), pointer :: smaw(:,:) ! Normalized Galperin instability function - ! ( 0<= <=4.964 and 1 at neutral ) - - real(r8), pointer :: qtl_flx(:,:) ! overbar(w'qtl') where qtl = qv + ql - real(r8), pointer :: qti_flx(:,:) ! overbar(w'qti') where qti = qv + qi - - real(r8) :: cgs(pcols,pverp) ! Counter-gradient star [ cg/flux ] - real(r8) :: cgh(pcols,pverp) ! Counter-gradient term for heat - real(r8) :: rztodt ! 1./ztodt [ 1/s ] - real(r8), pointer :: ksrftms(:) ! Turbulent mountain stress surface drag coefficient [ kg/s/m2 ] - real(r8), pointer :: tautmsx(:) ! U component of turbulent mountain stress [ N/m2 ] - real(r8), pointer :: tautmsy(:) ! V component of turbulent mountain stress [ N/m2 ] - real(r8) :: tautotx(pcols) ! U component of total surface stress [ N/m2 ] - real(r8) :: tautoty(pcols) ! V component of total surface stress [ N/m2 ] - - real(r8), pointer :: dragblj(:,:) ! Beljaars SGO form drag profile [ 1/s ] - real(r8), pointer :: taubljx(:) ! U component of turbulent mountain stress [ N/m2 ] - real(r8), pointer :: taubljy(:) ! V component of turbulent mountain stress [ N/m2 ] - - real(r8), pointer :: kvh_in(:,:) ! kvh from previous timestep [ m2/s ] - real(r8), pointer :: kvm_in(:,:) ! kvm from previous timestep [ m2/s ] - real(r8), pointer :: kvt(:,:) ! Molecular kinematic conductivity for temperature [ ] - real(r8) :: kvq(pcols,pverp) ! Eddy diffusivity for constituents [ m2/s ] - real(r8) :: kvh(pcols,pverp) ! Eddy diffusivity for heat [ m2/s ] - real(r8) :: kvm(pcols,pverp) ! Eddy diffusivity for momentum [ m2/s ] - real(r8) :: kvm_temp(pcols,pverp) ! Dummy eddy diffusivity for momentum (unused) [ m2/s ] - real(r8) :: dtk_temp(pcols,pverp) ! Unused output from second compute_vdiff call - real(r8) :: tautmsx_temp(pcols) ! Unused output from second compute_vdiff call - real(r8) :: tautmsy_temp(pcols) ! Unused output from second compute_vdiff call - real(r8) :: topflx_temp(pcols) ! Unused output from second compute_vdiff call - real(r8) :: sprod(pcols,pverp) ! Shear production of tke [ m2/s3 ] - real(r8) :: sfi(pcols,pverp) ! Saturation fraction at interfaces [ fraction ] - real(r8) :: sl(pcols,pver) - real(r8) :: qt(pcols,pver) - real(r8) :: slv(pcols,pver) - real(r8) :: sl_prePBL(pcols,pver) - real(r8) :: qt_prePBL(pcols,pver) - real(r8) :: slv_prePBL(pcols,pver) - real(r8) :: slten(pcols,pver) - real(r8) :: qtten(pcols,pver) - real(r8) :: slflx(pcols,pverp) - real(r8) :: qtflx(pcols,pverp) - real(r8) :: uflx(pcols,pverp) - real(r8) :: vflx(pcols,pverp) - real(r8) :: slflx_cg(pcols,pverp) - real(r8) :: qtflx_cg(pcols,pverp) - real(r8) :: uflx_cg(pcols,pverp) - real(r8) :: vflx_cg(pcols,pverp) - real(r8) :: th(pcols,pver) ! Potential temperature - real(r8) :: topflx(pcols) ! Molecular heat flux at top interface - real(r8) :: rhoair - - real(r8) :: ri(pcols,pver) ! richardson number (HB output) - - ! for obklen calculation outside HB - real(r8) :: thvs(pcols) ! Virtual potential temperature at surface - real(r8) :: rrho(pcols) ! Reciprocal of density at surface - real(r8) :: khfs(pcols) ! sfc kinematic heat flux [mK/s] - real(r8) :: kqfs(pcols) ! sfc kinematic water vapor flux [m/s] - real(r8) :: kbfs(pcols) ! sfc kinematic buoyancy flux [m^2/s^3] - - real(r8) :: ftem(pcols,pver) ! Saturation vapor pressure before PBL - real(r8) :: ftem_prePBL(pcols,pver) ! Saturation vapor pressure before PBL - real(r8) :: ftem_aftPBL(pcols,pver) ! Saturation vapor pressure after PBL - real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH - real(r8) :: t_aftPBL(pcols,pver) ! Temperature after PBL diffusion - real(r8) :: tten(pcols,pver) ! Temperature tendency by PBL diffusion - real(r8) :: rhten(pcols,pver) ! RH tendency by PBL diffusion - real(r8) :: qv_aft_PBL(pcols,pver) ! qv after PBL diffusion - real(r8) :: ql_aft_PBL(pcols,pver) ! ql after PBL diffusion - real(r8) :: qi_aft_PBL(pcols,pver) ! qi after PBL diffusion - real(r8) :: s_aft_PBL(pcols,pver) ! s after PBL diffusion - real(r8) :: u_aft_PBL(pcols,pver) ! u after PBL diffusion - real(r8) :: v_aft_PBL(pcols,pver) ! v after PBL diffusion - real(r8) :: qv_pro(pcols,pver) - real(r8) :: ql_pro(pcols,pver) - real(r8) :: qi_pro(pcols,pver) - real(r8) :: s_pro(pcols,pver) - real(r8) :: t_pro(pcols,pver) - real(r8), pointer :: tauresx(:) ! Residual stress to be added in vdiff to correct - real(r8), pointer :: tauresy(:) ! for turb stress mismatch between sfc and atm accumulated. - - ! Interpolated interface values. - real(r8) :: tint(pcols,pver+1) ! Temperature [ K ] - real(r8) :: rairi(pcols,pver+1) ! Gas constant [ J/K/kg ] - real(r8) :: rhoi(pcols,pver+1) ! Density of air [ kg/m^3 ] - real(r8) :: rhoi_dry(pcols,pver+1) ! Density of air based on dry air pressure [ kg/m^3 ] - - ! Upper boundary conditions - real(r8) :: ubc_t(pcols) ! Temperature [ K ] - real(r8) :: ubc_mmr(pcols,pcnst) ! Mixing ratios [ kg/kg ] - real(r8) :: ubc_flux(pcols,pcnst) ! Constituent upper boundary flux (kg/s/m^2) - - ! Pressure coordinates used by the solver. - type(Coords1D) :: p - type(Coords1D) :: p_dry - - real(r8), pointer :: tpert(:) - real(r8), pointer :: qpert(:) - real(r8), pointer :: pblh(:) - - real(r8) :: tmp1(pcols) ! Temporary storage - - integer :: nstep - real(r8) :: sum1, sum2, sum3, pdelx - real(r8) :: sflx - - ! Copy state so we can pass to intent(inout) routines that return - ! new state instead of a tendency. - real(r8) :: s_tmp(pcols,pver) - real(r8) :: u_tmp(pcols,pver) - real(r8) :: v_tmp(pcols,pver) - real(r8) :: q_tmp(pcols,pver,pcnst) - - ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity - real(r8) :: kq_scal(pcols,pver+1) - ! composition dependent mw_fac on interface level - real(r8) :: mw_fac(pcols,pver+1,pcnst) - - ! Dry static energy top boundary condition. - real(r8) :: dse_top(pcols) - - ! Copies of flux arrays used to zero out any parts that are applied - ! elsewhere (e.g. by CLUBB). - real(r8) :: taux(pcols) - real(r8) :: tauy(pcols) - real(r8) :: shflux(pcols) - real(r8) :: cflux(pcols,pcnst) - - logical :: lq(pcnst) - - ! ----------------------- ! - ! Main Computation Begins ! - ! ----------------------- ! - - rztodt = 1._r8 / ztodt - lchnk = state%lchnk - ncol = state%ncol - - call pbuf_get_field(pbuf, tauresx_idx, tauresx) - call pbuf_get_field(pbuf, tauresy_idx, tauresy) - call pbuf_get_field(pbuf, tpert_idx, tpert) - call pbuf_get_field(pbuf, qpert_idx, qpert) - call pbuf_get_field(pbuf, pblh_idx, pblh) - call pbuf_get_field(pbuf, turbtype_idx, turbtype) - - ! Interpolate temperature to interfaces. - do k = 2, pver - do i = 1, ncol - tint(i,k) = 0.5_r8 * ( state%t(i,k) + state%t(i,k-1) ) - end do - end do - tint(:ncol,pver+1) = state%t(:ncol,pver) - - ! Get upper boundary values - call ubc_get_vals( state%lchnk, ncol, state%pint, state%zi, state%t, state%q, state%omega, state%phis, & - ubc_t, ubc_mmr, ubc_flux ) - - ! Always have a fixed upper boundary T if molecular diffusion is active. Why ? - ! For WACCM-X, set ubc temperature to extrapolate from next two lower interface level temperatures - if (do_molec_diff) then - if (waccmx_mode) then - tint(:ncol,1) = 1.5_r8*tint(:ncol,2)-.5_r8*tint(:ncol,3) - else - tint (:ncol,1) = ubc_t(:ncol) - endif - else - tint(:ncol,1) = state%t(:ncol,1) - end if - - ! Set up pressure coordinates for solver calls. - p = Coords1D(state%pint(:ncol,:)) - p_dry = Coords1D(state%pintdry(:ncol,:)) - - !------------------------------------------------------------------------ - ! Check to see if constituent dependent gas constant needed (WACCM-X) - !------------------------------------------------------------------------ - if (waccmx_mode) then - rairi(:ncol,1) = rairv(:ncol,1,lchnk) - do k = 2, pver - do i = 1, ncol - rairi(i,k) = 0.5_r8 * (rairv(i,k,lchnk)+rairv(i,k-1,lchnk)) - end do - end do - rairi(:ncol,pver+1) = rairv(:ncol,pver,lchnk) - else - rairi(:ncol,:pver+1) = rair - endif - - ! Compute rho at interfaces. - do k = 1, pver+1 - do i = 1, ncol - rhoi(i,k) = p%ifc(i,k) / (rairi(i,k)*tint(i,k)) - end do - end do - - ! Compute rho_dry at interfaces. - do k = 1, pver+1 - do i = 1, ncol - rhoi_dry(i,k) = p_dry%ifc(i,k) / (rairi(i,k)*tint(i,k)) - end do - end do - - ! ---------------------------------------- ! - ! Computation of turbulent mountain stress ! - ! ---------------------------------------- ! - - ! Consistent with the computation of 'normal' drag coefficient, we are using - ! the raw input (u,v) to compute 'ksrftms', not the provisionally-marched 'u,v' - ! within the iteration loop of the PBL scheme. - - call trb_mtn_stress_tend(state, pbuf, cam_in) - - call pbuf_get_field(pbuf, ksrftms_idx, ksrftms) - call pbuf_get_field(pbuf, tautmsx_idx, tautmsx) - call pbuf_get_field(pbuf, tautmsy_idx, tautmsy) - - tautotx(:ncol) = cam_in%wsx(:ncol) + tautmsx(:ncol) - tautoty(:ncol) = cam_in%wsy(:ncol) + tautmsy(:ncol) - - ! ------------------------------------- ! - ! Computation of Beljaars SGO form drag ! - ! ------------------------------------- ! - - call beljaars_drag_tend(state, pbuf, cam_in) - - call pbuf_get_field(pbuf, dragblj_idx, dragblj) - call pbuf_get_field(pbuf, taubljx_idx, taubljx) - call pbuf_get_field(pbuf, taubljy_idx, taubljy) - - ! Add Beljaars integrated drag - - tautotx(:ncol) = tautotx(:ncol) + taubljx(:ncol) - tautoty(:ncol) = tautoty(:ncol) + taubljy(:ncol) - - !----------------------------------------------------------------------- ! - ! Computation of eddy diffusivities - Select appropriate PBL scheme ! - !----------------------------------------------------------------------- ! - call pbuf_get_field(pbuf, kvm_idx, kvm_in) - call pbuf_get_field(pbuf, kvh_idx, kvh_in) - call pbuf_get_field(pbuf, smaw_idx, smaw) - call pbuf_get_field(pbuf, tke_idx, tke) - - ! Get potential temperature. - th(:ncol,:pver) = state%t(:ncol,:pver) * state%exner(:ncol,:pver) - - select case (eddy_scheme) - case ( 'diag_TKE', 'SPCAM_m2005' ) - - call eddy_diff_tend(state, pbuf, cam_in, & - ztodt, p, tint, rhoi, cldn, wstarent, & - kvm_in, kvh_in, ksrftms, dragblj, tauresx, tauresy, & - rrho, ustar, pblh, kvm, kvh, kvq, cgh, cgs, tpert, qpert, & - tke, sprod, sfi, turbtype, smaw) - - ! The diag_TKE scheme does not calculate the Monin-Obukhov length, which is used in dry deposition calculations. - ! Use the routines from pbl_utils to accomplish this. Assumes ustar and rrho have been set. - call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) - call calc_obklen(ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & - cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & - khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) - - - case ( 'HB', 'HBR', 'SPCAM_sam1mom' ) - - ! Modification : We may need to use 'taux' instead of 'tautotx' here, for - ! consistency with the previous HB scheme. - - call compute_hb_diff( lchnk , ncol , & - th , state%t , state%q , state%zm , state%zi, & - state%pmid, state%u , state%v , tautotx , tautoty , & - cam_in%shf, cam_in%cflx(:,1), obklen , ustar , pblh , & - kvm , kvh , kvq , cgh , cgs , & - tpert , qpert , cldn , cam_in%ocnfrac , tke , & - ri , & - eddy_scheme ) - - call outfld( 'HB_ri', ri, pcols, lchnk ) - - case ( 'CLUBB_SGS' ) - - ! CLUBB has only a bare-bones placeholder here. If using CLUBB, the - ! PBL diffusion will happen before coupling, so vertical_diffusion - ! is only handling other things, e.g. some boundary conditions, tms, - ! and molecular diffusion. - - call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) - - call calc_ustar( ncol, state%t(:ncol,pver), state%pmid(:ncol,pver), & - cam_in%wsx(:ncol), cam_in%wsy(:ncol), rrho(:ncol), ustar(:ncol)) - ! Use actual qflux, not lhf/latvap as was done previously - call calc_obklen( ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & - cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & - khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) - - ! These tendencies all applied elsewhere. - kvm = 0._r8 - kvh = 0._r8 - kvq = 0._r8 - - ! Not defined since PBL is not actually running here. - cgh = 0._r8 - cgs = 0._r8 - - end select - - call outfld( 'ustar', ustar(:), pcols, lchnk ) - call outfld( 'obklen', obklen(:), pcols, lchnk ) - - ! kvh (in pbuf) is used by other physics parameterizations, and as an initial guess in compute_eddy_diff - ! on the next timestep. It is not updated by the compute_vdiff call below. - call pbuf_set_field(pbuf, kvh_idx, kvh) - - ! kvm (in pbuf) is only used as an initial guess in compute_eddy_diff on the next timestep. - ! The contributions for molecular diffusion made to kvm by the call to compute_vdiff below - ! are not included in the pbuf as these are not needed in the initial guess by compute_eddy_diff. - call pbuf_set_field(pbuf, kvm_idx, kvm) - - !------------------------------------ ! - ! Application of diffusivities ! - !------------------------------------ ! - - ! Set arrays from input state. - q_tmp(:ncol,:,:) = state%q(:ncol,:,:) - s_tmp(:ncol,:) = state%s(:ncol,:) - u_tmp(:ncol,:) = state%u(:ncol,:) - v_tmp(:ncol,:) = state%v(:ncol,:) - - !------------------------------------------------------ ! - ! Write profile output before applying diffusion scheme ! - !------------------------------------------------------ ! - - if (.not. do_pbl_diags) then - sl_prePBL(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & - - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) - qt_prePBL(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & - + q_tmp(:ncol,:,ixcldice) - slv_prePBL(:ncol,:pver) = sl_prePBL(:ncol,:pver) * ( 1._r8 + zvir*qt_prePBL(:ncol,:pver) ) - - call qsat(state%t(:ncol,:), state%pmid(:ncol,:), & - tem2(:ncol,:), ftem(:ncol,:)) - ftem_prePBL(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 - - call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) - call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) - call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) - call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) - call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) - call outfld( 'qv_pre_PBL ', state%q(:ncol,:,1), pcols, lchnk ) - call outfld( 'ql_pre_PBL ', state%q(:ncol,:,ixcldliq), pcols, lchnk ) - call outfld( 'qi_pre_PBL ', state%q(:ncol,:,ixcldice), pcols, lchnk ) - call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) - call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) - - end if - - ! --------------------------------------------------------------------------------- ! - ! Call the diffusivity solver and solve diffusion equation ! - ! The final two arguments are optional function references to ! - ! constituent-independent and constituent-dependent moleculuar diffusivity routines ! - ! --------------------------------------------------------------------------------- ! - - ! Modification : We may need to output 'tautotx_im,tautoty_im' from below 'compute_vdiff' and - ! separately print out as diagnostic output, because these are different from - ! the explicit 'tautotx, tautoty' computed above. - ! Note that the output 'tauresx,tauresy' from below subroutines are fully implicit ones. - - call pbuf_get_field(pbuf, kvt_idx, kvt) - - if (do_molec_diff .and. .not. waccmx_mode) then - ! Top boundary condition for dry static energy - dse_top(:ncol) = cpairv(:ncol,1,lchnk) * tint(:ncol,1) + & - gravit * state%zi(:ncol,1) - else - dse_top(:ncol) = 0._r8 - end if - - select case (eddy_scheme) - case ('CLUBB_SGS') - ! CLUBB applies some fluxes itself, but we still want constituent - ! fluxes applied here (except water vapor). - taux = 0._r8 - tauy = 0._r8 - shflux = 0._r8 - cflux(:,1) = 0._r8 - cflux(:,2:) = cam_in%cflx(:,2:) - case default - taux = cam_in%wsx - tauy = cam_in%wsy - shflux = cam_in%shf - cflux = cam_in%cflx - end select - - if( any(fieldlist_wet) ) then - - if (do_molec_diff) then - call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & - kvm, kvt, tint, rhoi, kq_scal, cnst_mw, & - mw_fac, nbot_molec) - end if - - call compute_vdiff( state%lchnk , & - pcols , pver , pcnst , ncol , tint , & - p , state%t , rhoi, ztodt , taux , & - tauy , shflux , cflux , & - kvh , kvm , kvq , cgs , cgh , & - state%zi , ksrftms , dragblj , & - qmincg , fieldlist_wet , fieldlist_molec,& - u_tmp , v_tmp , q_tmp , s_tmp , & - tautmsx , tautmsy , dtk , topflx , errstring , & - tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & - do_molec_diff, waccmx_mode, & - vd_lu_qdecomp, & - ubc_mmr, ubc_flux, kvt, state%pmid, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & - kq_scal, mw_fac) - - call handle_errmsg(errstring, subname="compute_vdiff", & - extra_msg="Error in fieldlist_wet call from vertical_diffusion.") - - end if - - if( any( fieldlist_dry ) ) then - - if( do_molec_diff ) then - ! kvm is unused in the output here (since it was assigned - ! above), so we use a temp kvm for the inout argument, and - ! ignore the value output by compute_molec_diff. - kvm_temp = kvm - call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & - kvm_temp, kvt, tint, rhoi_dry, kq_scal, cnst_mw, & - mw_fac, nbot_molec) - end if - - call compute_vdiff( state%lchnk , & - pcols , pver , pcnst , ncol , tint , & - p_dry , state%t , rhoi_dry, ztodt , taux , & - tauy , shflux , cflux , & - kvh , kvm , kvq , cgs , cgh , & - state%zi , ksrftms , dragblj , & - qmincg , fieldlist_dry , fieldlist_molec,& - u_tmp , v_tmp , q_tmp , s_tmp , & - tautmsx_temp , tautmsy_temp , dtk_temp , topflx_temp , errstring , & - tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & - do_molec_diff , waccmx_mode, & - vd_lu_qdecomp, & - ubc_mmr, ubc_flux, kvt, state%pmiddry, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & - kq_scal, mw_fac) - - call handle_errmsg(errstring, subname="compute_vdiff", & - extra_msg="Error in fieldlist_dry call from vertical_diffusion.") - - end if - - if (prog_modal_aero) then - - ! Modal aerosol species not diffused, so just add the explicit surface fluxes to the - ! lowest layer - -!Oslo aero adds emissions together with dry deposition -#ifndef OSLO_AERO - tmp1(:ncol) = ztodt * gravit * state%rpdel(:ncol,pver) - do m = 1, pmam_ncnst - l = pmam_cnst_idx(m) - q_tmp(:ncol,pver,l) = q_tmp(:ncol,pver,l) + tmp1(:ncol) * cam_in%cflx(:ncol,l) - enddo -#endif - end if - - ! -------------------------------------------------------- ! - ! Diagnostics and output writing after applying PBL scheme ! - ! -------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - sl(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & - - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) - qt(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & - + q_tmp(:ncol,:,ixcldice) - slv(:ncol,:pver) = sl(:ncol,:pver) * ( 1._r8 + zvir*qt(:ncol,:pver) ) - - slflx(:ncol,1) = 0._r8 - qtflx(:ncol,1) = 0._r8 - uflx(:ncol,1) = 0._r8 - vflx(:ncol,1) = 0._r8 - - slflx_cg(:ncol,1) = 0._r8 - qtflx_cg(:ncol,1) = 0._r8 - uflx_cg(:ncol,1) = 0._r8 - vflx_cg(:ncol,1) = 0._r8 - - do k = 2, pver - do i = 1, ncol - rhoair = state%pint(i,k) / ( rair * ( ( 0.5_r8*(slv(i,k)+slv(i,k-1)) - gravit*state%zi(i,k))/cpair ) ) - slflx(i,k) = kvh(i,k) * & - ( - rhoair*(sl(i,k-1)-sl(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & - + cgh(i,k) ) - qtflx(i,k) = kvh(i,k) * & - ( - rhoair*(qt(i,k-1)-qt(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & - + rhoair*(cam_in%cflx(i,1)+cam_in%cflx(i,ixcldliq)+cam_in%cflx(i,ixcldice))*cgs(i,k) ) - uflx(i,k) = kvm(i,k) * & - ( - rhoair*(u_tmp(i,k-1)-u_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) - vflx(i,k) = kvm(i,k) * & - ( - rhoair*(v_tmp(i,k-1)-v_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) - slflx_cg(i,k) = kvh(i,k) * cgh(i,k) - qtflx_cg(i,k) = kvh(i,k) * rhoair * ( cam_in%cflx(i,1) + & - cam_in%cflx(i,ixcldliq) + cam_in%cflx(i,ixcldice) ) * cgs(i,k) - uflx_cg(i,k) = 0._r8 - vflx_cg(i,k) = 0._r8 - end do - end do - - ! Modification : I should check whether slflx(:ncol,pverp) is correctly computed. - ! Note also that 'tautotx' is explicit total stress, different from - ! the ones that have been actually added into the atmosphere. - - slflx(:ncol,pverp) = cam_in%shf(:ncol) - qtflx(:ncol,pverp) = cam_in%cflx(:ncol,1) - uflx(:ncol,pverp) = tautotx(:ncol) - vflx(:ncol,pverp) = tautoty(:ncol) - - slflx_cg(:ncol,pverp) = 0._r8 - qtflx_cg(:ncol,pverp) = 0._r8 - uflx_cg(:ncol,pverp) = 0._r8 - vflx_cg(:ncol,pverp) = 0._r8 - - if (trim(shallow_scheme) == 'UNICON') then - call pbuf_get_field(pbuf, qtl_flx_idx, qtl_flx) - call pbuf_get_field(pbuf, qti_flx_idx, qti_flx) - qtl_flx(:ncol,1) = 0._r8 - qti_flx(:ncol,1) = 0._r8 - do k = 2, pver - do i = 1, ncol - ! For use in the cloud macrophysics - ! Note that density is not added here. Also, only consider local transport term. - qtl_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldliq)-q_tmp(i,k,ixcldliq))/& - (state%zm(i,k-1)-state%zm(i,k)) - qti_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldice)-q_tmp(i,k,ixcldice))/& - (state%zm(i,k-1)-state%zm(i,k)) - end do - end do - do i = 1, ncol - rhoair = state%pint(i,pverp)/(rair*((slv(i,pver)-gravit*state%zi(i,pverp))/cpair)) - qtl_flx(i,pverp) = cam_in%cflx(i,1)/rhoair - qti_flx(i,pverp) = cam_in%cflx(i,1)/rhoair - end do - end if - - end if - - ! --------------------------------------------------------------- ! - ! Convert the new profiles into vertical diffusion tendencies. ! - ! Convert KE dissipative heat change into "temperature" tendency. ! - ! --------------------------------------------------------------- ! - - ! All variables are modified by vertical diffusion - - lq(:) = .TRUE. - call physics_ptend_init(ptend,state%psetcols, "vertical diffusion", & - ls=.true., lu=.true., lv=.true., lq=lq) - - ptend%s(:ncol,:) = ( s_tmp(:ncol,:) - state%s(:ncol,:) ) * rztodt - ptend%u(:ncol,:) = ( u_tmp(:ncol,:) - state%u(:ncol,:) ) * rztodt - ptend%v(:ncol,:) = ( v_tmp(:ncol,:) - state%v(:ncol,:) ) * rztodt - ptend%q(:ncol,:pver,:) = ( q_tmp(:ncol,:pver,:) - state%q(:ncol,:pver,:) ) * rztodt - if (.not. do_pbl_diags) then - slten(:ncol,:) = ( sl(:ncol,:) - sl_prePBL(:ncol,:) ) * rztodt - qtten(:ncol,:) = ( qt(:ncol,:) - qt_prePBL(:ncol,:) ) * rztodt - end if - - ! ------------------------------------------------------------ ! - ! In order to perform 'pseudo-conservative variable diffusion' ! - ! perform the following two stages: ! - ! ! - ! I. Re-set (1) 'qvten' by 'qtten', and 'qlten = qiten = 0' ! - ! (2) 'sten' by 'slten', and ! - ! (3) 'qlten = qiten = 0' ! - ! ! - ! II. Apply 'positive_moisture' ! - ! ! - ! ------------------------------------------------------------ ! + ! Beljaars fields + call beljaars_drag_register() - if( (eddy_scheme .eq. 'diag_TKE' .or. eddy_scheme .eq. 'SPCAM_m2005') .and. do_pseudocon_diff ) then + end subroutine vd_register + + ! =============================================================================== ! + subroutine vertical_diffusion_init(pbuf2d) + + !------------------------------------------------------------------! + ! Initialization of time independent fields for vertical diffusion ! + ! Calls initialization routines for subsidiary modules ! + !----------------------------------------------------------------- ! + + use cam_history, only : addfld, add_default, horiz_only + use cam_history, only : register_vector_field + use eddy_diff_cam, only : eddy_diff_init + use hb_diff, only : init_hb_diff + use molec_diff, only : init_molec_diff + use diffusion_solver, only : init_vdiff, new_fieldlist_vdiff, vdiff_select + use constituents, only : cnst_get_ind, cnst_get_type_byind, cnst_name, cnst_get_molec_byind + use spmd_utils, only : masterproc + use ref_pres, only : press_lim_idx, pref_mid + use physics_buffer, only : pbuf_set_field, pbuf_get_index, physics_buffer_desc + use rad_constituents, only : rad_cnst_get_info, rad_cnst_get_mode_num_idx, & + rad_cnst_get_mam_mmr_idx + use trb_mtn_stress_cam,only : trb_mtn_stress_init + use beljaars_drag_cam, only : beljaars_drag_init + use upper_bc, only : ubc_init + use phys_control, only : waccmx_is, fv_am_correction + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + character(128) :: errstring ! Error status for init_vdiff + integer :: ntop_eddy ! Top interface level to which eddy vertical diffusion is applied ( = 1 ) + integer :: nbot_eddy ! Bottom interface level to which eddy vertical diffusion is applied ( = pver ) + integer :: k ! Vertical loop index + + real(r8), parameter :: ntop_eddy_pres = 1.e-5_r8 ! Pressure below which eddy diffusion is not done in WACCM-X. (Pa) + + integer :: im, l, m, nmodes, nspec + + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_eddy ! output the eddy variables + logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi + integer :: history_budget_histfile_num ! output history file number for budget fields + logical :: history_waccm ! output variables of interest for WACCM runs + + ! ----------------------------------------------------------------- ! + + if (masterproc) then + write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)' + end if + + ! Check to see if WACCM-X is on (currently we don't care whether the + ! ionosphere is on or not, since this neutral diffusion code is the + ! same either way). + waccmx_mode = waccmx_is('ionosphere') .or. waccmx_is('neutral') + + ! ----------------------------------------------------------------- ! + ! Get indices of cloud liquid and ice within the constituents array ! + ! ----------------------------------------------------------------- ! + + call cnst_get_ind( 'CLDLIQ', ixcldliq ) + call cnst_get_ind( 'CLDICE', ixcldice ) + ! These are optional; with the CAM4 microphysics, there are no number + ! constituents. + call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. ) + call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. ) + + ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. + call phys_getopts(prog_modal_aero_out=prog_modal_aero) + prog_modal_aero = .TRUE. + if (prog_modal_aero) then + + ! Get the constituent indices of the number and mass mixing ratios of the modal + ! aerosols. + ! + ! N.B. - This implementation assumes that the prognostic modal aerosols are + ! impacting the climate calculation (i.e., can get info from list 0). + ! + pmam_ncnst = getNumberOfAerosolTracers() + allocate(pmam_cnst_idx(pmam_ncnst)) + call fillAerosolTracerList(pmam_cnst_idx) + end if + + ! Initialize upper boundary condition module + + call ubc_init() + + ! ---------------------------------------------------------------------------------------- ! + ! Initialize molecular diffusivity module ! + ! Note that computing molecular diffusivities is a trivial expense, but constituent ! + ! diffusivities depend on their molecular weights. Decomposing the diffusion matrix ! + ! for each constituent is a needless expense unless the diffusivity is significant. ! + ! ---------------------------------------------------------------------------------------- ! + + !---------------------------------------------------------------------------------------- + ! Initialize molecular diffusion and get top and bottom molecular diffusion limits + !---------------------------------------------------------------------------------------- + + if( do_molec_diff ) then + call init_molec_diff( r8, pcnst, mwdry, avogad, & + errstring) + + call handle_errmsg(errstring, subname="init_molec_diff") + + call addfld( 'TTPXMLC', horiz_only, 'A', 'K/S', 'Top interf. temp. flux: molec. viscosity' ) + if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NBOT_MOLEC =', nbot_molec + end if + + ! ---------------------------------- ! + ! Initialize eddy diffusivity module ! + ! ---------------------------------- ! + + ! ntop_eddy must be 1 or <= nbot_molec + ! Currently, it is always 1 except for WACCM-X. + if ( waccmx_mode ) then + ntop_eddy = press_lim_idx(ntop_eddy_pres, top=.true.) + else + ntop_eddy = 1 + end if + nbot_eddy = pver + + if (masterproc) write(iulog, fmt='(a,i3,5x,a,i3)') 'NTOP_EDDY =', ntop_eddy, 'NBOT_EDDY =', nbot_eddy + + select case ( eddy_scheme ) + case ( 'diag_TKE', 'SPCAM_m2005' ) + if( masterproc ) write(iulog,*) & + 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park' + call eddy_diff_init(pbuf2d, ntop_eddy, nbot_eddy) + case ( 'HB', 'HBR', 'SPCAM_sam1mom') + if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: Holtslag and Boville' + call init_hb_diff(gravit, cpair, ntop_eddy, nbot_eddy, pref_mid, & + karman, eddy_scheme) + call addfld('HB_ri', (/ 'lev' /), 'A', 'no', 'Richardson Number (HB Scheme), I' ) + case ( 'CLUBB_SGS' ) + do_pbl_diags = .true. + end select + + ! ------------------------------------------- ! + ! Initialize turbulent mountain stress module ! + ! ------------------------------------------- ! + + call trb_mtn_stress_init() + + ! ----------------------------------- ! + ! Initialize Beljaars SGO drag module ! + ! ----------------------------------- ! + + call beljaars_drag_init() + + ! ---------------------------------- ! + ! Initialize diffusion solver module ! + ! ---------------------------------- ! + + call init_vdiff(r8, iulog, rair, cpair, gravit, do_iss, fv_am_correction, errstring) + call handle_errmsg(errstring, subname="init_vdiff") + + ! Use fieldlist_wet to select the fields which will be diffused using moist mixing ratios ( all by default ) + ! Use fieldlist_dry to select the fields which will be diffused using dry mixing ratios. + + fieldlist_wet = new_fieldlist_vdiff( pcnst) + fieldlist_dry = new_fieldlist_vdiff( pcnst) + fieldlist_molec = new_fieldlist_vdiff( pcnst) + + if( vdiff_select( fieldlist_wet, 'u' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'u' ) ) + if( vdiff_select( fieldlist_wet, 'v' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'v' ) ) + if( vdiff_select( fieldlist_wet, 's' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 's' ) ) + + constit_loop: do k = 1, pcnst + + if (prog_modal_aero) then + ! Do not diffuse droplet number - treated in dropmixnuc + if (k == ixnumliq) cycle constit_loop + ! Don't diffuse modal aerosol - treated in dropmixnuc + do m = 1, pmam_ncnst + if (k == pmam_cnst_idx(m)) cycle constit_loop + enddo + end if + + if( cnst_get_type_byind(k) .eq. 'wet' ) then + if( vdiff_select( fieldlist_wet, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'q', k ) ) + else + if( vdiff_select( fieldlist_dry, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_dry, 'q', k ) ) + endif + + ! ----------------------------------------------- ! + ! Select constituents for molecular diffusion ! + ! ----------------------------------------------- ! + if ( cnst_get_molec_byind(k) .eq. 'minor' ) then + if( vdiff_select(fieldlist_molec,'q',k) .ne. '' ) call endrun( vdiff_select( fieldlist_molec,'q',k ) ) + endif + + end do constit_loop + + ! ------------------------ ! + ! Diagnostic output fields ! + ! ------------------------ ! + + do k = 1, pcnst + vdiffnam(k) = 'VD'//cnst_name(k) + if( k == 1 ) vdiffnam(k) = 'VD01' !**** compatibility with old code **** + call addfld( vdiffnam(k), (/ 'lev' /), 'A', 'kg/kg/s', 'Vertical diffusion of '//cnst_name(k) ) + end do + + if (.not. do_pbl_diags) then + call addfld( 'PBLH' , horiz_only , 'A', 'm' , 'PBL height' ) + call addfld( 'QT' , (/ 'lev' /) , 'A', 'kg/kg' , 'Total water mixing ratio' ) + call addfld( 'SL' , (/ 'lev' /) , 'A', 'J/kg' , 'Liquid water static energy' ) + call addfld( 'SLV' , (/ 'lev' /) , 'A', 'J/kg' , 'Liq wat virtual static energy' ) + call addfld( 'SLFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Liquid static energy flux' ) + call addfld( 'QTFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Total water flux' ) + call addfld( 'TKE' , (/ 'ilev' /) , 'A', 'm2/s2' , 'Turbulent Kinetic Energy' ) + call addfld( 'TPERT' , horiz_only , 'A', 'K' , 'Perturbation temperature (eddies in PBL)' ) + call addfld( 'QPERT' , horiz_only , 'A', 'kg/kg' , 'Perturbation specific humidity (eddies in PBL)' ) + + call addfld( 'UFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Zonal momentum flux' ) + call addfld( 'VFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Meridional momentm flux' ) + call register_vector_field('UFLX', 'VFLX') + end if + + call addfld( 'USTAR' , horiz_only , 'A', 'm/s' , 'Surface friction velocity' ) + call addfld( 'KVH' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (heat/moisture)' ) + call addfld( 'KVM' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (momentum)' ) + call addfld( 'KVT' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion kinematic molecular conductivity') + call addfld( 'CGS' , (/ 'ilev' /) , 'A', 's/m2' , 'Counter-gradient coeff on surface kinematic fluxes' ) + call addfld( 'DTVKE' , (/ 'lev' /) , 'A', 'K/s' , 'dT/dt vertical diffusion KE dissipation' ) + call addfld( 'DTV' , (/ 'lev' /) , 'A', 'K/s' , 'T vertical diffusion' ) + call addfld( 'DUV' , (/ 'lev' /) , 'A', 'm/s2' , 'U vertical diffusion' ) + call addfld( 'DVV' , (/ 'lev' /) , 'A', 'm/s2' , 'V vertical diffusion' ) + + ! ---------------------------------------------------------------------------- ! + ! Below ( with '_PBL') are for detailed analysis of UW Moist Turbulence Scheme ! + ! ---------------------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + call addfld( 'qt_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_prePBL' ) + call addfld( 'sl_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_prePBL' ) + call addfld( 'slv_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_prePBL' ) + call addfld( 'u_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_prePBL' ) + call addfld( 'v_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_prePBL' ) + call addfld( 'qv_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_prePBL' ) + call addfld( 'ql_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_prePBL' ) + call addfld( 'qi_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_prePBL' ) + call addfld( 't_pre_PBL', (/ 'lev' /) , 'A', 'K' , 't_prePBL' ) + call addfld( 'rh_pre_PBL', (/ 'lev' /) , 'A', '%' , 'rh_prePBL' ) + + call addfld( 'qt_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_afterPBL' ) + call addfld( 'sl_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_afterPBL' ) + call addfld( 'slv_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_afterPBL' ) + call addfld( 'u_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_afterPBL' ) + call addfld( 'v_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_afterPBL' ) + call addfld( 'qv_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_afterPBL' ) + call addfld( 'ql_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_afterPBL' ) + call addfld( 'qi_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_afterPBL' ) + call addfld( 't_aft_PBL', (/ 'lev' /) , 'A', 'K' , 't_afterPBL' ) + call addfld( 'rh_aft_PBL', (/ 'lev' /) , 'A', '%' , 'rh_afterPBL' ) + + call addfld( 'slflx_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl flux by PBL' ) + call addfld( 'qtflx_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt flux by PBL' ) + call addfld( 'uflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u flux by PBL' ) + call addfld( 'vflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v flux by PBL' ) + + call addfld( 'slflx_cg_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl_cg flux by PBL' ) + call addfld( 'qtflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt_cg flux by PBL' ) + call addfld( 'uflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u_cg flux by PBL' ) + call addfld( 'vflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v_cg flux by PBL' ) + + call addfld( 'qtten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qt tendency by PBL' ) + call addfld( 'slten_PBL', (/ 'lev' /) , 'A', 'J/kg/s' , 'sl tendency by PBL' ) + call addfld( 'uten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'u tendency by PBL' ) + call addfld( 'vten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'v tendency by PBL' ) + call addfld( 'qvten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qv tendency by PBL' ) + call addfld( 'qlten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'ql tendency by PBL' ) + call addfld( 'qiten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qi tendency by PBL' ) + call addfld( 'tten_PBL', (/ 'lev' /) , 'A', 'K/s' , 'T tendency by PBL' ) + call addfld( 'rhten_PBL', (/ 'lev' /) , 'A', '%/s' , 'RH tendency by PBL' ) + + end if + + call addfld ('ustar',horiz_only, 'A', ' ',' ') + call addfld ('obklen',horiz_only, 'A', ' ',' ') + + ! ---------------------------- + ! determine default variables + ! ---------------------------- + + call phys_getopts( history_amwg_out = history_amwg, & + history_eddy_out = history_eddy, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num, & + history_waccm_out = history_waccm) + + if (history_amwg) then + call add_default( vdiffnam(1), 1, ' ' ) + call add_default( 'DTV' , 1, ' ' ) + if (.not. do_pbl_diags) then + call add_default( 'PBLH' , 1, ' ' ) + end if + endif + + if (history_eddy) then + call add_default( 'UFLX ', 1, ' ' ) + call add_default( 'VFLX ', 1, ' ' ) + endif + + if( history_budget ) then + call add_default( vdiffnam(ixcldliq), history_budget_histfile_num, ' ' ) + call add_default( vdiffnam(ixcldice), history_budget_histfile_num, ' ' ) + !AL + call add_default( vdiffnam(ixnumliq), history_budget_histfile_num, ' ' ) + call add_default( vdiffnam(ixnumice), history_budget_histfile_num, ' ' ) + !AL + if( history_budget_histfile_num > 1 ) then + call add_default( vdiffnam(1), history_budget_histfile_num, ' ' ) + call add_default( 'DTV' , history_budget_histfile_num, ' ' ) + end if + end if + + if ( history_waccm ) then + if (do_molec_diff) then + call add_default ( 'TTPXMLC', 1, ' ' ) + end if + call add_default( 'DUV' , 1, ' ' ) + call add_default( 'DVV' , 1, ' ' ) + end if + ! ---------------------------- + + + ksrftms_idx = pbuf_get_index('ksrftms') + tautmsx_idx = pbuf_get_index('tautmsx') + tautmsy_idx = pbuf_get_index('tautmsy') + + dragblj_idx = pbuf_get_index('dragblj') + taubljx_idx = pbuf_get_index('taubljx') + taubljy_idx = pbuf_get_index('taubljy') + + if (eddy_scheme == 'CLUBB_SGS') then + kvh_idx = pbuf_get_index('kvh') + end if + + ! Initialization of some pbuf fields + if (is_first_step()) then + ! Initialization of pbuf fields tke, kvh, kvm are done in phys_inidat + call pbuf_set_field(pbuf2d, turbtype_idx, 0 ) + call pbuf_set_field(pbuf2d, smaw_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tauresx_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tauresy_idx, 0.0_r8) + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_set_field(pbuf2d, qtl_flx_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qti_flx_idx, 0.0_r8) + end if + end if + + end subroutine vertical_diffusion_init - ptend%q(:ncol,:pver,1) = qtten(:ncol,:pver) - ptend%s(:ncol,:pver) = slten(:ncol,:pver) - ptend%q(:ncol,:pver,ixcldliq) = 0._r8 - ptend%q(:ncol,:pver,ixcldice) = 0._r8 - if (ixnumliq > 0) ptend%q(:ncol,:pver,ixnumliq) = 0._r8 - if (ixnumice > 0) ptend%q(:ncol,:pver,ixnumice) = 0._r8 - - do i = 1, ncol - do k = 1, pver - qv_pro(i,k) = state%q(i,k,1) + ptend%q(i,k,1) * ztodt - ql_pro(i,k) = state%q(i,k,ixcldliq) + ptend%q(i,k,ixcldliq) * ztodt - qi_pro(i,k) = state%q(i,k,ixcldice) + ptend%q(i,k,ixcldice) * ztodt - s_pro(i,k) = state%s(i,k) + ptend%s(i,k) * ztodt - t_pro(i,k) = state%t(i,k) + (1._r8/cpair)*ptend%s(i,k) * ztodt - end do - end do - - call positive_moisture( cpair, latvap, latvap+latice, ncol, pver, ztodt, qmin(1), qmin(ixcldliq), qmin(ixcldice), & - state%pdel(:ncol,pver:1:-1), qv_pro(:ncol,pver:1:-1), ql_pro(:ncol,pver:1:-1), & - qi_pro(:ncol,pver:1:-1), t_pro(:ncol,pver:1:-1), s_pro(:ncol,pver:1:-1), & - ptend%q(:ncol,pver:1:-1,1), ptend%q(:ncol,pver:1:-1,ixcldliq), & - ptend%q(:ncol,pver:1:-1,ixcldice), ptend%s(:ncol,pver:1:-1) ) - - end if - - ! ----------------------------------------------------------------- ! - ! Re-calculate diagnostic output variables after vertical diffusion ! - ! ----------------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - qv_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,1) + ptend%q(:ncol,:pver,1) * ztodt - ql_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + ptend%q(:ncol,:pver,ixcldliq) * ztodt - qi_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + ptend%q(:ncol,:pver,ixcldice) * ztodt - s_aft_PBL(:ncol,:pver) = state%s(:ncol,:pver) + ptend%s(:ncol,:pver) * ztodt - t_aftPBL(:ncol,:pver) = ( s_aft_PBL(:ncol,:pver) - gravit*state%zm(:ncol,:pver) ) / cpair - - u_aft_PBL(:ncol,:pver) = state%u(:ncol,:pver) + ptend%u(:ncol,:pver) * ztodt - v_aft_PBL(:ncol,:pver) = state%v(:ncol,:pver) + ptend%v(:ncol,:pver) * ztodt - - call qsat(t_aftPBL(:ncol,:pver), state%pmid(:ncol,:pver), & - tem2(:ncol,:pver), ftem(:ncol,:pver)) - ftem_aftPBL(:ncol,:pver) = qv_aft_PBL(:ncol,:pver) / ftem(:ncol,:pver) * 100._r8 - - tten(:ncol,:pver) = ( t_aftPBL(:ncol,:pver) - state%t(:ncol,:pver) ) * rztodt - rhten(:ncol,:pver) = ( ftem_aftPBL(:ncol,:pver) - ftem_prePBL(:ncol,:pver) ) * rztodt - - end if - - ! -------------------------------------------------------------- ! - ! mass conservation check......... - ! -------------------------------------------------------------- ! - if (diff_cnsrv_mass_check) then - - ! Conservation check - do m = 1, pcnst - fixed_ubc: if ((.not.cnst_fixed_ubc(m)).and.(.not.cnst_fixed_ubflx(m))) then - col_loop: do i = 1, ncol - sum1 = 0._r8 - sum2 = 0._r8 - sum3 = 0._r8 - do k = 1, pver - if(cnst_get_type_byind(m).eq.'wet') then - pdelx = state%pdel(i,k) - else - pdelx = state%pdeldry(i,k) - endif - sum1 = sum1 + state%q(i,k,m)*pdelx/gravit ! total column - sum2 = sum2 +(state%q(i,k,m)+ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! total column after tendancy is applied - sum3 = sum3 +( ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! rate of change in column - enddo - sum1 = sum1 + (cam_in%cflx(i,m) * ztodt) ! add in surface flux (kg/m2) - sflx = (cam_in%cflx(i,m) * ztodt) - if (sum1>1.e-36_r8) then - if( abs((sum2-sum1)/sum1) .gt. 1.e-12_r8 ) then - nstep = get_nstep() - write(iulog,'(a,a8,a,I4,2f8.3,5e25.16)') & - 'MASSCHECK vert diff : nstep,lon,lat,mass1,mass2,sum3,sflx,rel-diff : ', & - trim(cnst_name(m)), ' : ', nstep, state%lon(i)*180._r8/pi, state%lat(i)*180._r8/pi, & - sum1, sum2, sum3, sflx, abs(sum2-sum1)/sum1 - call endrun('vertical_diffusion_tend : mass not conserved' ) - endif - endif - enddo col_loop - endif fixed_ubc - enddo - endif - - ! -------------------------------------------------------------- ! - ! Writing state variables after PBL scheme for detailed analysis ! - ! -------------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - call outfld( 'sl_aft_PBL' , sl, pcols, lchnk ) - call outfld( 'qt_aft_PBL' , qt, pcols, lchnk ) - call outfld( 'slv_aft_PBL' , slv, pcols, lchnk ) - call outfld( 'u_aft_PBL' , u_aft_PBL, pcols, lchnk ) - call outfld( 'v_aft_PBL' , v_aft_PBL, pcols, lchnk ) - call outfld( 'qv_aft_PBL' , qv_aft_PBL, pcols, lchnk ) - call outfld( 'ql_aft_PBL' , ql_aft_PBL, pcols, lchnk ) - call outfld( 'qi_aft_PBL' , qi_aft_PBL, pcols, lchnk ) - call outfld( 't_aft_PBL ' , t_aftPBL, pcols, lchnk ) - call outfld( 'rh_aft_PBL' , ftem_aftPBL, pcols, lchnk ) - call outfld( 'slflx_PBL' , slflx, pcols, lchnk ) - call outfld( 'qtflx_PBL' , qtflx, pcols, lchnk ) - call outfld( 'uflx_PBL' , uflx, pcols, lchnk ) - call outfld( 'vflx_PBL' , vflx, pcols, lchnk ) - call outfld( 'slflx_cg_PBL' , slflx_cg, pcols, lchnk ) - call outfld( 'qtflx_cg_PBL' , qtflx_cg, pcols, lchnk ) - call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) - call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) - call outfld( 'slten_PBL' , slten, pcols, lchnk ) - call outfld( 'qtten_PBL' , qtten, pcols, lchnk ) - call outfld( 'uten_PBL' , ptend%u(:ncol,:), pcols, lchnk ) - call outfld( 'vten_PBL' , ptend%v(:ncol,:), pcols, lchnk ) - call outfld( 'qvten_PBL' , ptend%q(:ncol,:,1), pcols, lchnk ) - call outfld( 'qlten_PBL' , ptend%q(:ncol,:,ixcldliq), pcols, lchnk ) - call outfld( 'qiten_PBL' , ptend%q(:ncol,:,ixcldice), pcols, lchnk ) - call outfld( 'tten_PBL' , tten, pcols, lchnk ) - call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) - - end if - - ! ------------------------------------------- ! - ! Writing the other standard output variables ! - ! ------------------------------------------- ! - - if (.not. do_pbl_diags) then - call outfld( 'QT' , qt, pcols, lchnk ) - call outfld( 'SL' , sl, pcols, lchnk ) - call outfld( 'SLV' , slv, pcols, lchnk ) - call outfld( 'SLFLX' , slflx, pcols, lchnk ) - call outfld( 'QTFLX' , qtflx, pcols, lchnk ) - call outfld( 'UFLX' , uflx, pcols, lchnk ) - call outfld( 'VFLX' , vflx, pcols, lchnk ) - call outfld( 'TKE' , tke, pcols, lchnk ) - - call outfld( 'PBLH' , pblh, pcols, lchnk ) - call outfld( 'TPERT' , tpert, pcols, lchnk ) - call outfld( 'QPERT' , qpert, pcols, lchnk ) - end if - call outfld( 'USTAR' , ustar, pcols, lchnk ) - call outfld( 'KVH' , kvh, pcols, lchnk ) - call outfld( 'KVT' , kvt, pcols, lchnk ) - call outfld( 'KVM' , kvm, pcols, lchnk ) - call outfld( 'CGS' , cgs, pcols, lchnk ) - dtk(:ncol,:) = dtk(:ncol,:) / cpair ! Normalize heating for history - call outfld( 'DTVKE' , dtk, pcols, lchnk ) - dtk(:ncol,:) = ptend%s(:ncol,:) / cpair ! Normalize heating for history using dtk - call outfld( 'DTV' , dtk, pcols, lchnk ) - call outfld( 'DUV' , ptend%u, pcols, lchnk ) - call outfld( 'DVV' , ptend%v, pcols, lchnk ) - do m = 1, pcnst - call outfld( vdiffnam(m) , ptend%q(1,1,m), pcols, lchnk ) - end do - if( do_molec_diff ) then - call outfld( 'TTPXMLC' , topflx, pcols, lchnk ) - end if - - call p%finalize() - call p_dry%finalize() - -end subroutine vertical_diffusion_tend + ! =============================================================================== ! + subroutine vertical_diffusion_ts_init( pbuf2d, state ) -! =============================================================================== ! -! ! -! =============================================================================== ! + !-------------------------------------------------------------- ! + ! Timestep dependent setting, ! + ! At present only invokes upper bc code ! + !-------------------------------------------------------------- ! + use upper_bc, only : ubc_timestep_init + use physics_types , only : physics_state + use ppgrid , only : begchunk, endchunk -subroutine positive_moisture( cp, xlv, xls, ncol, mkx, dt, qvmin, qlmin, qimin, & - dp, qv, ql, qi, t, s, qvten, qlten, qiten, sten ) - ! ------------------------------------------------------------------------------- ! - ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! - ! force them to be larger than minimum value by (1) condensating water vapor ! - ! into liquid or ice, and (2) by transporting water vapor from the very lower ! - ! layer. '2._r8' is multiplied to the minimum values for safety. ! - ! Update final state variables and tendencies associated with this correction. ! - ! If any condensation happens, update (s,t) too. ! - ! Note that (qv,ql,qi,t,s) are final state variables after applying corresponding ! - ! input tendencies. ! - ! Be careful the order of k : '1': near-surface layer, 'mkx' : top layer ! - ! ------------------------------------------------------------------------------- ! - implicit none - integer, intent(in) :: ncol, mkx - real(r8), intent(in) :: cp, xlv, xls - real(r8), intent(in) :: dt, qvmin, qlmin, qimin - real(r8), intent(in) :: dp(ncol,mkx) - real(r8), intent(inout) :: qv(ncol,mkx), ql(ncol,mkx), qi(ncol,mkx), t(ncol,mkx), s(ncol,mkx) - real(r8), intent(inout) :: qvten(ncol,mkx), qlten(ncol,mkx), qiten(ncol,mkx), sten(ncol,mkx) - integer i, k - real(r8) dql, dqi, dqv, sum, aa, dum - - ! Modification : I should check whether this is exactly same as the one used in - ! shallow convection and cloud macrophysics. - - do i = 1, ncol - do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface - dql = max(0._r8,1._r8*qlmin-ql(i,k)) - dqi = max(0._r8,1._r8*qimin-qi(i,k)) - qlten(i,k) = qlten(i,k) + dql/dt - qiten(i,k) = qiten(i,k) + dqi/dt - qvten(i,k) = qvten(i,k) - (dql+dqi)/dt - sten(i,k) = sten(i,k) + xlv * (dql/dt) + xls * (dqi/dt) - ql(i,k) = ql(i,k) + dql - qi(i,k) = qi(i,k) + dqi - qv(i,k) = qv(i,k) - dql - dqi - s(i,k) = s(i,k) + xlv * dql + xls * dqi - t(i,k) = t(i,k) + (xlv * dql + xls * dqi)/cp - dqv = max(0._r8,1._r8*qvmin-qv(i,k)) - qvten(i,k) = qvten(i,k) + dqv/dt - qv(i,k) = qv(i,k) + dqv - if( k .ne. 1 ) then - qv(i,k-1) = qv(i,k-1) - dqv*dp(i,k)/dp(i,k-1) - qvten(i,k-1) = qvten(i,k-1) - dqv*dp(i,k)/dp(i,k-1)/dt - endif - qv(i,k) = max(qv(i,k),qvmin) - ql(i,k) = max(ql(i,k),qlmin) - qi(i,k) = max(qi(i,k),qimin) - end do - ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally - ! extracted from all the layers that has 'qv > 2*qvmin'. This fully - ! preserves column moisture. - if( dqv .gt. 1.e-20_r8 ) then - sum = 0._r8 - do k = 1, mkx - if( qv(i,k) .gt. 2._r8*qvmin ) sum = sum + qv(i,k)*dp(i,k) - enddo - aa = dqv*dp(i,1)/max(1.e-20_r8,sum) - if( aa .lt. 0.5_r8 ) then - do k = 1, mkx - if( qv(i,k) .gt. 2._r8*qvmin ) then - dum = aa*qv(i,k) - qv(i,k) = qv(i,k) - dum - qvten(i,k) = qvten(i,k) - dum/dt - endif - enddo - else - write(iulog,*) 'Full positive_moisture is impossible in vertical_diffusion' - endif - endif - end do - return - -end subroutine positive_moisture + use physics_buffer, only : physics_buffer_desc + + type(physics_state), intent(in) :: state(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + call ubc_timestep_init( pbuf2d, state) + + end subroutine vertical_diffusion_ts_init + + ! =============================================================================== ! + subroutine vertical_diffusion_tend( & + ztodt , state , cam_in, & + ustar , obklen , ptend , & + cldn , pbuf) + !---------------------------------------------------- ! + ! This is an interface routine for vertical diffusion ! + !---------------------------------------------------- ! + use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field + use physics_types, only : physics_state, physics_ptend, physics_ptend_init + use camsrfexch, only : cam_in_t + use cam_history, only : outfld + + use trb_mtn_stress_cam, only : trb_mtn_stress_tend + use beljaars_drag_cam, only : beljaars_drag_tend + use eddy_diff_cam, only : eddy_diff_tend + use hb_diff, only : compute_hb_diff + use wv_saturation, only : qsat + use molec_diff, only : compute_molec_diff, vd_lu_qdecomp + use constituents, only : qmincg, qmin + use diffusion_solver, only : compute_vdiff, any, operator(.not.) + use physconst, only : cpairv, rairv !Needed for calculation of upward H flux + use time_manager, only : get_nstep + use constituents, only : cnst_get_type_byind, cnst_name, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx + use physconst, only : pi + use pbl_utils, only : virtem, calc_obklen, calc_ustar + use upper_bc, only : ubc_get_vals + use coords_1d, only : Coords1D + + ! --------------- ! + ! Input Arguments ! + ! --------------- ! + + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), intent(in) :: cam_in ! Surface inputs + + real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] + real(r8), intent(in) :: cldn(pcols,pver) ! New stratus fraction [ fraction ] + + ! ---------------------- ! + ! Input-Output Arguments ! + ! ---------------------- ! + + type(physics_ptend), intent(out) :: ptend ! Individual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + ! ---------------- ! + ! Output Arguments ! + ! ---------------- ! + + real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] + real(r8), intent(out) :: obklen(pcols) ! Obukhov length [ m ] + + ! --------------- ! + ! Local Variables ! + ! --------------- ! + + character(128) :: errstring ! Error status for compute_vdiff + + integer :: lchnk ! Chunk identifier + integer :: ncol ! Number of atmospheric columns + integer :: i, k, l, m ! column, level, constituent indices + + real(r8) :: dtk(pcols,pver) ! T tendency from KE dissipation + real(r8), pointer :: tke(:,:) ! Turbulent kinetic energy [ m2/s2 ] + integer(i4),pointer :: turbtype(:,:) ! Turbulent interface types [ no unit ] + real(r8), pointer :: smaw(:,:) ! Normalized Galperin instability function + ! ( 0<= <=4.964 and 1 at neutral ) + + real(r8), pointer :: qtl_flx(:,:) ! overbar(w'qtl') where qtl = qv + ql + real(r8), pointer :: qti_flx(:,:) ! overbar(w'qti') where qti = qv + qi + + real(r8) :: cgs(pcols,pverp) ! Counter-gradient star [ cg/flux ] + real(r8) :: cgh(pcols,pverp) ! Counter-gradient term for heat + real(r8) :: rztodt ! 1./ztodt [ 1/s ] + real(r8), pointer :: ksrftms(:) ! Turbulent mountain stress surface drag coefficient [ kg/s/m2 ] + real(r8), pointer :: tautmsx(:) ! U component of turbulent mountain stress [ N/m2 ] + real(r8), pointer :: tautmsy(:) ! V component of turbulent mountain stress [ N/m2 ] + real(r8) :: tautotx(pcols) ! U component of total surface stress [ N/m2 ] + real(r8) :: tautoty(pcols) ! V component of total surface stress [ N/m2 ] + + real(r8), pointer :: dragblj(:,:) ! Beljaars SGO form drag profile [ 1/s ] + real(r8), pointer :: taubljx(:) ! U component of turbulent mountain stress [ N/m2 ] + real(r8), pointer :: taubljy(:) ! V component of turbulent mountain stress [ N/m2 ] + + real(r8), pointer :: kvh_in(:,:) ! kvh from previous timestep [ m2/s ] + real(r8), pointer :: kvm_in(:,:) ! kvm from previous timestep [ m2/s ] + real(r8), pointer :: kvt(:,:) ! Molecular kinematic conductivity for temperature [ ] + real(r8) :: kvq(pcols,pverp) ! Eddy diffusivity for constituents [ m2/s ] + real(r8) :: kvh(pcols,pverp) ! Eddy diffusivity for heat [ m2/s ] + real(r8) :: kvm(pcols,pverp) ! Eddy diffusivity for momentum [ m2/s ] + real(r8) :: kvm_temp(pcols,pverp) ! Dummy eddy diffusivity for momentum (unused) [ m2/s ] + real(r8) :: dtk_temp(pcols,pverp) ! Unused output from second compute_vdiff call + real(r8) :: tautmsx_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: tautmsy_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: topflx_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: sprod(pcols,pverp) ! Shear production of tke [ m2/s3 ] + real(r8) :: sfi(pcols,pverp) ! Saturation fraction at interfaces [ fraction ] + real(r8) :: sl(pcols,pver) + real(r8) :: qt(pcols,pver) + real(r8) :: slv(pcols,pver) + real(r8) :: sl_prePBL(pcols,pver) + real(r8) :: qt_prePBL(pcols,pver) + real(r8) :: slv_prePBL(pcols,pver) + real(r8) :: slten(pcols,pver) + real(r8) :: qtten(pcols,pver) + real(r8) :: slflx(pcols,pverp) + real(r8) :: qtflx(pcols,pverp) + real(r8) :: uflx(pcols,pverp) + real(r8) :: vflx(pcols,pverp) + real(r8) :: slflx_cg(pcols,pverp) + real(r8) :: qtflx_cg(pcols,pverp) + real(r8) :: uflx_cg(pcols,pverp) + real(r8) :: vflx_cg(pcols,pverp) + real(r8) :: th(pcols,pver) ! Potential temperature + real(r8) :: topflx(pcols) ! Molecular heat flux at top interface + real(r8) :: rhoair + + real(r8) :: ri(pcols,pver) ! richardson number (HB output) + + ! for obklen calculation outside HB + real(r8) :: thvs(pcols) ! Virtual potential temperature at surface + real(r8) :: rrho(pcols) ! Reciprocal of density at surface + real(r8) :: khfs(pcols) ! sfc kinematic heat flux [mK/s] + real(r8) :: kqfs(pcols) ! sfc kinematic water vapor flux [m/s] + real(r8) :: kbfs(pcols) ! sfc kinematic buoyancy flux [m^2/s^3] + + real(r8) :: ftem(pcols,pver) ! Saturation vapor pressure before PBL + real(r8) :: ftem_prePBL(pcols,pver) ! Saturation vapor pressure before PBL + real(r8) :: ftem_aftPBL(pcols,pver) ! Saturation vapor pressure after PBL + real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH + real(r8) :: t_aftPBL(pcols,pver) ! Temperature after PBL diffusion + real(r8) :: tten(pcols,pver) ! Temperature tendency by PBL diffusion + real(r8) :: rhten(pcols,pver) ! RH tendency by PBL diffusion + real(r8) :: qv_aft_PBL(pcols,pver) ! qv after PBL diffusion + real(r8) :: ql_aft_PBL(pcols,pver) ! ql after PBL diffusion + real(r8) :: qi_aft_PBL(pcols,pver) ! qi after PBL diffusion + real(r8) :: s_aft_PBL(pcols,pver) ! s after PBL diffusion + real(r8) :: u_aft_PBL(pcols,pver) ! u after PBL diffusion + real(r8) :: v_aft_PBL(pcols,pver) ! v after PBL diffusion + real(r8) :: qv_pro(pcols,pver) + real(r8) :: ql_pro(pcols,pver) + real(r8) :: qi_pro(pcols,pver) + real(r8) :: s_pro(pcols,pver) + real(r8) :: t_pro(pcols,pver) + real(r8), pointer :: tauresx(:) ! Residual stress to be added in vdiff to correct + real(r8), pointer :: tauresy(:) ! for turb stress mismatch between sfc and atm accumulated. + + ! Interpolated interface values. + real(r8) :: tint(pcols,pver+1) ! Temperature [ K ] + real(r8) :: rairi(pcols,pver+1) ! Gas constant [ J/K/kg ] + real(r8) :: rhoi(pcols,pver+1) ! Density of air [ kg/m^3 ] + real(r8) :: rhoi_dry(pcols,pver+1) ! Density of air based on dry air pressure [ kg/m^3 ] + + ! Upper boundary conditions + real(r8) :: ubc_t(pcols) ! Temperature [ K ] + real(r8) :: ubc_mmr(pcols,pcnst) ! Mixing ratios [ kg/kg ] + real(r8) :: ubc_flux(pcols,pcnst) ! Constituent upper boundary flux (kg/s/m^2) + + ! Pressure coordinates used by the solver. + type(Coords1D) :: p + type(Coords1D) :: p_dry + + real(r8), pointer :: tpert(:) + real(r8), pointer :: qpert(:) + real(r8), pointer :: pblh(:) + + real(r8) :: tmp1(pcols) ! Temporary storage + + integer :: nstep + real(r8) :: sum1, sum2, sum3, pdelx + real(r8) :: sflx + + ! Copy state so we can pass to intent(inout) routines that return + ! new state instead of a tendency. + real(r8) :: s_tmp(pcols,pver) + real(r8) :: u_tmp(pcols,pver) + real(r8) :: v_tmp(pcols,pver) + real(r8) :: q_tmp(pcols,pver,pcnst) + + ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity + real(r8) :: kq_scal(pcols,pver+1) + ! composition dependent mw_fac on interface level + real(r8) :: mw_fac(pcols,pver+1,pcnst) + + ! Dry static energy top boundary condition. + real(r8) :: dse_top(pcols) + + ! Copies of flux arrays used to zero out any parts that are applied + ! elsewhere (e.g. by CLUBB). + real(r8) :: taux(pcols) + real(r8) :: tauy(pcols) + real(r8) :: shflux(pcols) + real(r8) :: cflux(pcols,pcnst) + + logical :: lq(pcnst) + + ! ----------------------- ! + ! Main Computation Begins ! + ! ----------------------- ! + + rztodt = 1._r8 / ztodt + lchnk = state%lchnk + ncol = state%ncol + + call pbuf_get_field(pbuf, tauresx_idx, tauresx) + call pbuf_get_field(pbuf, tauresy_idx, tauresy) + call pbuf_get_field(pbuf, tpert_idx, tpert) + call pbuf_get_field(pbuf, qpert_idx, qpert) + call pbuf_get_field(pbuf, pblh_idx, pblh) + call pbuf_get_field(pbuf, turbtype_idx, turbtype) + + ! Interpolate temperature to interfaces. + do k = 2, pver + do i = 1, ncol + tint(i,k) = 0.5_r8 * ( state%t(i,k) + state%t(i,k-1) ) + end do + end do + tint(:ncol,pver+1) = state%t(:ncol,pver) + + ! Get upper boundary values + call ubc_get_vals( state%lchnk, ncol, state%pint, state%zi, state%t, state%q, state%omega, state%phis, & + ubc_t, ubc_mmr, ubc_flux ) + + ! Always have a fixed upper boundary T if molecular diffusion is active. Why ? + ! For WACCM-X, set ubc temperature to extrapolate from next two lower interface level temperatures + if (do_molec_diff) then + if (waccmx_mode) then + tint(:ncol,1) = 1.5_r8*tint(:ncol,2)-.5_r8*tint(:ncol,3) + else + tint (:ncol,1) = ubc_t(:ncol) + endif + else + tint(:ncol,1) = state%t(:ncol,1) + end if + + ! Set up pressure coordinates for solver calls. + p = Coords1D(state%pint(:ncol,:)) + p_dry = Coords1D(state%pintdry(:ncol,:)) + + !------------------------------------------------------------------------ + ! Check to see if constituent dependent gas constant needed (WACCM-X) + !------------------------------------------------------------------------ + if (waccmx_mode) then + rairi(:ncol,1) = rairv(:ncol,1,lchnk) + do k = 2, pver + do i = 1, ncol + rairi(i,k) = 0.5_r8 * (rairv(i,k,lchnk)+rairv(i,k-1,lchnk)) + end do + end do + rairi(:ncol,pver+1) = rairv(:ncol,pver,lchnk) + else + rairi(:ncol,:pver+1) = rair + endif + + ! Compute rho at interfaces. + do k = 1, pver+1 + do i = 1, ncol + rhoi(i,k) = p%ifc(i,k) / (rairi(i,k)*tint(i,k)) + end do + end do + + ! Compute rho_dry at interfaces. + do k = 1, pver+1 + do i = 1, ncol + rhoi_dry(i,k) = p_dry%ifc(i,k) / (rairi(i,k)*tint(i,k)) + end do + end do + + ! ---------------------------------------- ! + ! Computation of turbulent mountain stress ! + ! ---------------------------------------- ! + + ! Consistent with the computation of 'normal' drag coefficient, we are using + ! the raw input (u,v) to compute 'ksrftms', not the provisionally-marched 'u,v' + ! within the iteration loop of the PBL scheme. + + call trb_mtn_stress_tend(state, pbuf, cam_in) + + call pbuf_get_field(pbuf, ksrftms_idx, ksrftms) + call pbuf_get_field(pbuf, tautmsx_idx, tautmsx) + call pbuf_get_field(pbuf, tautmsy_idx, tautmsy) + + tautotx(:ncol) = cam_in%wsx(:ncol) + tautmsx(:ncol) + tautoty(:ncol) = cam_in%wsy(:ncol) + tautmsy(:ncol) + + ! ------------------------------------- ! + ! Computation of Beljaars SGO form drag ! + ! ------------------------------------- ! + + call beljaars_drag_tend(state, pbuf, cam_in) + + call pbuf_get_field(pbuf, dragblj_idx, dragblj) + call pbuf_get_field(pbuf, taubljx_idx, taubljx) + call pbuf_get_field(pbuf, taubljy_idx, taubljy) + + ! Add Beljaars integrated drag + + tautotx(:ncol) = tautotx(:ncol) + taubljx(:ncol) + tautoty(:ncol) = tautoty(:ncol) + taubljy(:ncol) + + !----------------------------------------------------------------------- ! + ! Computation of eddy diffusivities - Select appropriate PBL scheme ! + !----------------------------------------------------------------------- ! + call pbuf_get_field(pbuf, kvm_idx, kvm_in) + call pbuf_get_field(pbuf, kvh_idx, kvh_in) + call pbuf_get_field(pbuf, smaw_idx, smaw) + call pbuf_get_field(pbuf, tke_idx, tke) + + ! Get potential temperature. + th(:ncol,:pver) = state%t(:ncol,:pver) * state%exner(:ncol,:pver) + + select case (eddy_scheme) + case ( 'diag_TKE', 'SPCAM_m2005' ) + + call eddy_diff_tend(state, pbuf, cam_in, & + ztodt, p, tint, rhoi, cldn, wstarent, & + kvm_in, kvh_in, ksrftms, dragblj, tauresx, tauresy, & + rrho, ustar, pblh, kvm, kvh, kvq, cgh, cgs, tpert, qpert, & + tke, sprod, sfi, turbtype, smaw) + + ! The diag_TKE scheme does not calculate the Monin-Obukhov length, which is used in dry deposition calculations. + ! Use the routines from pbl_utils to accomplish this. Assumes ustar and rrho have been set. + call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) + call calc_obklen(ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & + cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & + khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) + + + case ( 'HB', 'HBR', 'SPCAM_sam1mom' ) + + ! Modification : We may need to use 'taux' instead of 'tautotx' here, for + ! consistency with the previous HB scheme. + + call compute_hb_diff( lchnk , ncol , & + th , state%t , state%q , state%zm , state%zi, & + state%pmid, state%u , state%v , tautotx , tautoty , & + cam_in%shf, cam_in%cflx(:,1), obklen , ustar , pblh , & + kvm , kvh , kvq , cgh , cgs , & + tpert , qpert , cldn , cam_in%ocnfrac , tke , & + ri , & + eddy_scheme ) + + call outfld( 'HB_ri', ri, pcols, lchnk ) + + case ( 'CLUBB_SGS' ) + + ! CLUBB has only a bare-bones placeholder here. If using CLUBB, the + ! PBL diffusion will happen before coupling, so vertical_diffusion + ! is only handling other things, e.g. some boundary conditions, tms, + ! and molecular diffusion. + + call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) + + call calc_ustar( ncol, state%t(:ncol,pver), state%pmid(:ncol,pver), & + cam_in%wsx(:ncol), cam_in%wsy(:ncol), rrho(:ncol), ustar(:ncol)) + ! Use actual qflux, not lhf/latvap as was done previously + call calc_obklen( ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & + cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & + khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) + + ! These tendencies all applied elsewhere. + kvm = 0._r8 + kvh = 0._r8 + kvq = 0._r8 + + ! Not defined since PBL is not actually running here. + cgh = 0._r8 + cgs = 0._r8 + + end select + + call outfld( 'ustar', ustar(:), pcols, lchnk ) + call outfld( 'obklen', obklen(:), pcols, lchnk ) + + ! kvh (in pbuf) is used by other physics parameterizations, and as an initial guess in compute_eddy_diff + ! on the next timestep. It is not updated by the compute_vdiff call below. + call pbuf_set_field(pbuf, kvh_idx, kvh) + + ! kvm (in pbuf) is only used as an initial guess in compute_eddy_diff on the next timestep. + ! The contributions for molecular diffusion made to kvm by the call to compute_vdiff below + ! are not included in the pbuf as these are not needed in the initial guess by compute_eddy_diff. + call pbuf_set_field(pbuf, kvm_idx, kvm) + + !------------------------------------ ! + ! Application of diffusivities ! + !------------------------------------ ! + + ! Set arrays from input state. + q_tmp(:ncol,:,:) = state%q(:ncol,:,:) + s_tmp(:ncol,:) = state%s(:ncol,:) + u_tmp(:ncol,:) = state%u(:ncol,:) + v_tmp(:ncol,:) = state%v(:ncol,:) + + !------------------------------------------------------ ! + ! Write profile output before applying diffusion scheme ! + !------------------------------------------------------ ! + + if (.not. do_pbl_diags) then + sl_prePBL(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & + - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) + qt_prePBL(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & + + q_tmp(:ncol,:,ixcldice) + slv_prePBL(:ncol,:pver) = sl_prePBL(:ncol,:pver) * ( 1._r8 + zvir*qt_prePBL(:ncol,:pver) ) + + call qsat(state%t(:ncol,:), state%pmid(:ncol,:), & + tem2(:ncol,:), ftem(:ncol,:)) + ftem_prePBL(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 + + call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) + call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) + call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) + call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) + call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) + call outfld( 'qv_pre_PBL ', state%q(:ncol,:,1), pcols, lchnk ) + call outfld( 'ql_pre_PBL ', state%q(:ncol,:,ixcldliq), pcols, lchnk ) + call outfld( 'qi_pre_PBL ', state%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) + call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) + + end if + + ! --------------------------------------------------------------------------------- ! + ! Call the diffusivity solver and solve diffusion equation ! + ! The final two arguments are optional function references to ! + ! constituent-independent and constituent-dependent moleculuar diffusivity routines ! + ! --------------------------------------------------------------------------------- ! + + ! Modification : We may need to output 'tautotx_im,tautoty_im' from below 'compute_vdiff' and + ! separately print out as diagnostic output, because these are different from + ! the explicit 'tautotx, tautoty' computed above. + ! Note that the output 'tauresx,tauresy' from below subroutines are fully implicit ones. + + call pbuf_get_field(pbuf, kvt_idx, kvt) + + if (do_molec_diff .and. .not. waccmx_mode) then + ! Top boundary condition for dry static energy + dse_top(:ncol) = cpairv(:ncol,1,lchnk) * tint(:ncol,1) + & + gravit * state%zi(:ncol,1) + else + dse_top(:ncol) = 0._r8 + end if + + select case (eddy_scheme) + case ('CLUBB_SGS') + ! CLUBB applies some fluxes itself, but we still want constituent + ! fluxes applied here (except water vapor). + taux = 0._r8 + tauy = 0._r8 + shflux = 0._r8 + cflux(:,1) = 0._r8 + cflux(:,2:) = cam_in%cflx(:,2:) + case default + taux = cam_in%wsx + tauy = cam_in%wsy + shflux = cam_in%shf + cflux = cam_in%cflx + end select + + if( any(fieldlist_wet) ) then + + if (do_molec_diff) then + call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & + kvm, kvt, tint, rhoi, kq_scal, cnst_mw, & + mw_fac, nbot_molec) + end if + + call compute_vdiff( state%lchnk , & + pcols , pver , pcnst , ncol , tint , & + p , state%t , rhoi, ztodt , taux , & + tauy , shflux , cflux , & + kvh , kvm , kvq , cgs , cgh , & + state%zi , ksrftms , dragblj , & + qmincg , fieldlist_wet , fieldlist_molec,& + u_tmp , v_tmp , q_tmp , s_tmp , & + tautmsx , tautmsy , dtk , topflx , errstring , & + tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & + do_molec_diff, waccmx_mode, & + vd_lu_qdecomp, & + ubc_mmr, ubc_flux, kvt, state%pmid, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & + kq_scal, mw_fac) + + call handle_errmsg(errstring, subname="compute_vdiff", & + extra_msg="Error in fieldlist_wet call from vertical_diffusion.") + + end if + + if( any( fieldlist_dry ) ) then + + if( do_molec_diff ) then + ! kvm is unused in the output here (since it was assigned + ! above), so we use a temp kvm for the inout argument, and + ! ignore the value output by compute_molec_diff. + kvm_temp = kvm + call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & + kvm_temp, kvt, tint, rhoi_dry, kq_scal, cnst_mw, & + mw_fac, nbot_molec) + end if + + call compute_vdiff( state%lchnk , & + pcols , pver , pcnst , ncol , tint , & + p_dry , state%t , rhoi_dry, ztodt , taux , & + tauy , shflux , cflux , & + kvh , kvm , kvq , cgs , cgh , & + state%zi , ksrftms , dragblj , & + qmincg , fieldlist_dry , fieldlist_molec,& + u_tmp , v_tmp , q_tmp , s_tmp , & + tautmsx_temp , tautmsy_temp , dtk_temp , topflx_temp , errstring , & + tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & + do_molec_diff , waccmx_mode, & + vd_lu_qdecomp, & + ubc_mmr, ubc_flux, kvt, state%pmiddry, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & + kq_scal, mw_fac) + + call handle_errmsg(errstring, subname="compute_vdiff", & + extra_msg="Error in fieldlist_dry call from vertical_diffusion.") + + end if + + ! -------------------------------------------------------- ! + ! Diagnostics and output writing after applying PBL scheme ! + ! -------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + sl(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & + - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) + qt(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & + + q_tmp(:ncol,:,ixcldice) + slv(:ncol,:pver) = sl(:ncol,:pver) * ( 1._r8 + zvir*qt(:ncol,:pver) ) + + slflx(:ncol,1) = 0._r8 + qtflx(:ncol,1) = 0._r8 + uflx(:ncol,1) = 0._r8 + vflx(:ncol,1) = 0._r8 + + slflx_cg(:ncol,1) = 0._r8 + qtflx_cg(:ncol,1) = 0._r8 + uflx_cg(:ncol,1) = 0._r8 + vflx_cg(:ncol,1) = 0._r8 + + do k = 2, pver + do i = 1, ncol + rhoair = state%pint(i,k) / ( rair * ( ( 0.5_r8*(slv(i,k)+slv(i,k-1)) - gravit*state%zi(i,k))/cpair ) ) + slflx(i,k) = kvh(i,k) * & + ( - rhoair*(sl(i,k-1)-sl(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & + + cgh(i,k) ) + qtflx(i,k) = kvh(i,k) * & + ( - rhoair*(qt(i,k-1)-qt(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & + + rhoair*(cam_in%cflx(i,1)+cam_in%cflx(i,ixcldliq)+cam_in%cflx(i,ixcldice))*cgs(i,k) ) + uflx(i,k) = kvm(i,k) * & + ( - rhoair*(u_tmp(i,k-1)-u_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) + vflx(i,k) = kvm(i,k) * & + ( - rhoair*(v_tmp(i,k-1)-v_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) + slflx_cg(i,k) = kvh(i,k) * cgh(i,k) + qtflx_cg(i,k) = kvh(i,k) * rhoair * ( cam_in%cflx(i,1) + & + cam_in%cflx(i,ixcldliq) + cam_in%cflx(i,ixcldice) ) * cgs(i,k) + uflx_cg(i,k) = 0._r8 + vflx_cg(i,k) = 0._r8 + end do + end do + + ! Modification : I should check whether slflx(:ncol,pverp) is correctly computed. + ! Note also that 'tautotx' is explicit total stress, different from + ! the ones that have been actually added into the atmosphere. + + slflx(:ncol,pverp) = cam_in%shf(:ncol) + qtflx(:ncol,pverp) = cam_in%cflx(:ncol,1) + uflx(:ncol,pverp) = tautotx(:ncol) + vflx(:ncol,pverp) = tautoty(:ncol) + + slflx_cg(:ncol,pverp) = 0._r8 + qtflx_cg(:ncol,pverp) = 0._r8 + uflx_cg(:ncol,pverp) = 0._r8 + vflx_cg(:ncol,pverp) = 0._r8 + + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_get_field(pbuf, qtl_flx_idx, qtl_flx) + call pbuf_get_field(pbuf, qti_flx_idx, qti_flx) + qtl_flx(:ncol,1) = 0._r8 + qti_flx(:ncol,1) = 0._r8 + do k = 2, pver + do i = 1, ncol + ! For use in the cloud macrophysics + ! Note that density is not added here. Also, only consider local transport term. + qtl_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldliq)-q_tmp(i,k,ixcldliq))/& + (state%zm(i,k-1)-state%zm(i,k)) + qti_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldice)-q_tmp(i,k,ixcldice))/& + (state%zm(i,k-1)-state%zm(i,k)) + end do + end do + do i = 1, ncol + rhoair = state%pint(i,pverp)/(rair*((slv(i,pver)-gravit*state%zi(i,pverp))/cpair)) + qtl_flx(i,pverp) = cam_in%cflx(i,1)/rhoair + qti_flx(i,pverp) = cam_in%cflx(i,1)/rhoair + end do + end if + + end if + + ! --------------------------------------------------------------- ! + ! Convert the new profiles into vertical diffusion tendencies. ! + ! Convert KE dissipative heat change into "temperature" tendency. ! + ! --------------------------------------------------------------- ! + + ! All variables are modified by vertical diffusion + + lq(:) = .TRUE. + call physics_ptend_init(ptend,state%psetcols, "vertical diffusion", & + ls=.true., lu=.true., lv=.true., lq=lq) + + ptend%s(:ncol,:) = ( s_tmp(:ncol,:) - state%s(:ncol,:) ) * rztodt + ptend%u(:ncol,:) = ( u_tmp(:ncol,:) - state%u(:ncol,:) ) * rztodt + ptend%v(:ncol,:) = ( v_tmp(:ncol,:) - state%v(:ncol,:) ) * rztodt + ptend%q(:ncol,:pver,:) = ( q_tmp(:ncol,:pver,:) - state%q(:ncol,:pver,:) ) * rztodt + if (.not. do_pbl_diags) then + slten(:ncol,:) = ( sl(:ncol,:) - sl_prePBL(:ncol,:) ) * rztodt + qtten(:ncol,:) = ( qt(:ncol,:) - qt_prePBL(:ncol,:) ) * rztodt + end if + + ! ------------------------------------------------------------ ! + ! In order to perform 'pseudo-conservative variable diffusion' ! + ! perform the following two stages: ! + ! ! + ! I. Re-set (1) 'qvten' by 'qtten', and 'qlten = qiten = 0' ! + ! (2) 'sten' by 'slten', and ! + ! (3) 'qlten = qiten = 0' ! + ! ! + ! II. Apply 'positive_moisture' ! + ! ! + ! ------------------------------------------------------------ ! + + if( (eddy_scheme .eq. 'diag_TKE' .or. eddy_scheme .eq. 'SPCAM_m2005') .and. do_pseudocon_diff ) then + + ptend%q(:ncol,:pver,1) = qtten(:ncol,:pver) + ptend%s(:ncol,:pver) = slten(:ncol,:pver) + ptend%q(:ncol,:pver,ixcldliq) = 0._r8 + ptend%q(:ncol,:pver,ixcldice) = 0._r8 + if (ixnumliq > 0) ptend%q(:ncol,:pver,ixnumliq) = 0._r8 + if (ixnumice > 0) ptend%q(:ncol,:pver,ixnumice) = 0._r8 + + do i = 1, ncol + do k = 1, pver + qv_pro(i,k) = state%q(i,k,1) + ptend%q(i,k,1) * ztodt + ql_pro(i,k) = state%q(i,k,ixcldliq) + ptend%q(i,k,ixcldliq) * ztodt + qi_pro(i,k) = state%q(i,k,ixcldice) + ptend%q(i,k,ixcldice) * ztodt + s_pro(i,k) = state%s(i,k) + ptend%s(i,k) * ztodt + t_pro(i,k) = state%t(i,k) + (1._r8/cpair)*ptend%s(i,k) * ztodt + end do + end do + + call positive_moisture( cpair, latvap, latvap+latice, ncol, pver, ztodt, qmin(1), qmin(ixcldliq), qmin(ixcldice), & + state%pdel(:ncol,pver:1:-1), qv_pro(:ncol,pver:1:-1), ql_pro(:ncol,pver:1:-1), & + qi_pro(:ncol,pver:1:-1), t_pro(:ncol,pver:1:-1), s_pro(:ncol,pver:1:-1), & + ptend%q(:ncol,pver:1:-1,1), ptend%q(:ncol,pver:1:-1,ixcldliq), & + ptend%q(:ncol,pver:1:-1,ixcldice), ptend%s(:ncol,pver:1:-1) ) + + end if + + ! ----------------------------------------------------------------- ! + ! Re-calculate diagnostic output variables after vertical diffusion ! + ! ----------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + qv_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,1) + ptend%q(:ncol,:pver,1) * ztodt + ql_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + ptend%q(:ncol,:pver,ixcldliq) * ztodt + qi_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + ptend%q(:ncol,:pver,ixcldice) * ztodt + s_aft_PBL(:ncol,:pver) = state%s(:ncol,:pver) + ptend%s(:ncol,:pver) * ztodt + t_aftPBL(:ncol,:pver) = ( s_aft_PBL(:ncol,:pver) - gravit*state%zm(:ncol,:pver) ) / cpair + + u_aft_PBL(:ncol,:pver) = state%u(:ncol,:pver) + ptend%u(:ncol,:pver) * ztodt + v_aft_PBL(:ncol,:pver) = state%v(:ncol,:pver) + ptend%v(:ncol,:pver) * ztodt + + call qsat(t_aftPBL(:ncol,:pver), state%pmid(:ncol,:pver), & + tem2(:ncol,:pver), ftem(:ncol,:pver)) + ftem_aftPBL(:ncol,:pver) = qv_aft_PBL(:ncol,:pver) / ftem(:ncol,:pver) * 100._r8 + + tten(:ncol,:pver) = ( t_aftPBL(:ncol,:pver) - state%t(:ncol,:pver) ) * rztodt + rhten(:ncol,:pver) = ( ftem_aftPBL(:ncol,:pver) - ftem_prePBL(:ncol,:pver) ) * rztodt + + end if + + ! -------------------------------------------------------------- ! + ! mass conservation check......... + ! -------------------------------------------------------------- ! + if (diff_cnsrv_mass_check) then + + ! Conservation check + do m = 1, pcnst + fixed_ubc: if ((.not.cnst_fixed_ubc(m)).and.(.not.cnst_fixed_ubflx(m))) then + col_loop: do i = 1, ncol + sum1 = 0._r8 + sum2 = 0._r8 + sum3 = 0._r8 + do k = 1, pver + if(cnst_get_type_byind(m).eq.'wet') then + pdelx = state%pdel(i,k) + else + pdelx = state%pdeldry(i,k) + endif + sum1 = sum1 + state%q(i,k,m)*pdelx/gravit ! total column + sum2 = sum2 +(state%q(i,k,m)+ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! total column after tendancy is applied + sum3 = sum3 +( ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! rate of change in column + enddo + sum1 = sum1 + (cam_in%cflx(i,m) * ztodt) ! add in surface flux (kg/m2) + sflx = (cam_in%cflx(i,m) * ztodt) + if (sum1>1.e-36_r8) then + if( abs((sum2-sum1)/sum1) .gt. 1.e-12_r8 ) then + nstep = get_nstep() + write(iulog,'(a,a8,a,I4,2f8.3,5e25.16)') & + 'MASSCHECK vert diff : nstep,lon,lat,mass1,mass2,sum3,sflx,rel-diff : ', & + trim(cnst_name(m)), ' : ', nstep, state%lon(i)*180._r8/pi, state%lat(i)*180._r8/pi, & + sum1, sum2, sum3, sflx, abs(sum2-sum1)/sum1 + call endrun('vertical_diffusion_tend : mass not conserved' ) + endif + endif + enddo col_loop + endif fixed_ubc + enddo + endif + + ! -------------------------------------------------------------- ! + ! Writing state variables after PBL scheme for detailed analysis ! + ! -------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + call outfld( 'sl_aft_PBL' , sl, pcols, lchnk ) + call outfld( 'qt_aft_PBL' , qt, pcols, lchnk ) + call outfld( 'slv_aft_PBL' , slv, pcols, lchnk ) + call outfld( 'u_aft_PBL' , u_aft_PBL, pcols, lchnk ) + call outfld( 'v_aft_PBL' , v_aft_PBL, pcols, lchnk ) + call outfld( 'qv_aft_PBL' , qv_aft_PBL, pcols, lchnk ) + call outfld( 'ql_aft_PBL' , ql_aft_PBL, pcols, lchnk ) + call outfld( 'qi_aft_PBL' , qi_aft_PBL, pcols, lchnk ) + call outfld( 't_aft_PBL ' , t_aftPBL, pcols, lchnk ) + call outfld( 'rh_aft_PBL' , ftem_aftPBL, pcols, lchnk ) + call outfld( 'slflx_PBL' , slflx, pcols, lchnk ) + call outfld( 'qtflx_PBL' , qtflx, pcols, lchnk ) + call outfld( 'uflx_PBL' , uflx, pcols, lchnk ) + call outfld( 'vflx_PBL' , vflx, pcols, lchnk ) + call outfld( 'slflx_cg_PBL' , slflx_cg, pcols, lchnk ) + call outfld( 'qtflx_cg_PBL' , qtflx_cg, pcols, lchnk ) + call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) + call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) + call outfld( 'slten_PBL' , slten, pcols, lchnk ) + call outfld( 'qtten_PBL' , qtten, pcols, lchnk ) + call outfld( 'uten_PBL' , ptend%u(:ncol,:), pcols, lchnk ) + call outfld( 'vten_PBL' , ptend%v(:ncol,:), pcols, lchnk ) + call outfld( 'qvten_PBL' , ptend%q(:ncol,:,1), pcols, lchnk ) + call outfld( 'qlten_PBL' , ptend%q(:ncol,:,ixcldliq), pcols, lchnk ) + call outfld( 'qiten_PBL' , ptend%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 'tten_PBL' , tten, pcols, lchnk ) + call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) + + end if + + ! ------------------------------------------- ! + ! Writing the other standard output variables ! + ! ------------------------------------------- ! + + if (.not. do_pbl_diags) then + call outfld( 'QT' , qt, pcols, lchnk ) + call outfld( 'SL' , sl, pcols, lchnk ) + call outfld( 'SLV' , slv, pcols, lchnk ) + call outfld( 'SLFLX' , slflx, pcols, lchnk ) + call outfld( 'QTFLX' , qtflx, pcols, lchnk ) + call outfld( 'UFLX' , uflx, pcols, lchnk ) + call outfld( 'VFLX' , vflx, pcols, lchnk ) + call outfld( 'TKE' , tke, pcols, lchnk ) + + call outfld( 'PBLH' , pblh, pcols, lchnk ) + call outfld( 'TPERT' , tpert, pcols, lchnk ) + call outfld( 'QPERT' , qpert, pcols, lchnk ) + end if + call outfld( 'USTAR' , ustar, pcols, lchnk ) + call outfld( 'KVH' , kvh, pcols, lchnk ) + call outfld( 'KVT' , kvt, pcols, lchnk ) + call outfld( 'KVM' , kvm, pcols, lchnk ) + call outfld( 'CGS' , cgs, pcols, lchnk ) + dtk(:ncol,:) = dtk(:ncol,:) / cpair ! Normalize heating for history + call outfld( 'DTVKE' , dtk, pcols, lchnk ) + dtk(:ncol,:) = ptend%s(:ncol,:) / cpair ! Normalize heating for history using dtk + call outfld( 'DTV' , dtk, pcols, lchnk ) + call outfld( 'DUV' , ptend%u, pcols, lchnk ) + call outfld( 'DVV' , ptend%v, pcols, lchnk ) + do m = 1, pcnst + call outfld( vdiffnam(m) , ptend%q(1,1,m), pcols, lchnk ) + end do + if( do_molec_diff ) then + call outfld( 'TTPXMLC' , topflx, pcols, lchnk ) + end if + + call p%finalize() + call p_dry%finalize() + + end subroutine vertical_diffusion_tend + + ! =============================================================================== ! + subroutine positive_moisture( cp, xlv, xls, ncol, mkx, dt, qvmin, qlmin, qimin, & + dp, qv, ql, qi, t, s, qvten, qlten, qiten, sten ) + ! ------------------------------------------------------------------------------- ! + ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! + ! force them to be larger than minimum value by (1) condensating water vapor ! + ! into liquid or ice, and (2) by transporting water vapor from the very lower ! + ! layer. '2._r8' is multiplied to the minimum values for safety. ! + ! Update final state variables and tendencies associated with this correction. ! + ! If any condensation happens, update (s,t) too. ! + ! Note that (qv,ql,qi,t,s) are final state variables after applying corresponding ! + ! input tendencies. ! + ! Be careful the order of k : '1': near-surface layer, 'mkx' : top layer ! + ! ------------------------------------------------------------------------------- ! + implicit none + integer, intent(in) :: ncol, mkx + real(r8), intent(in) :: cp, xlv, xls + real(r8), intent(in) :: dt, qvmin, qlmin, qimin + real(r8), intent(in) :: dp(ncol,mkx) + real(r8), intent(inout) :: qv(ncol,mkx), ql(ncol,mkx), qi(ncol,mkx), t(ncol,mkx), s(ncol,mkx) + real(r8), intent(inout) :: qvten(ncol,mkx), qlten(ncol,mkx), qiten(ncol,mkx), sten(ncol,mkx) + integer i, k + real(r8) dql, dqi, dqv, sum, aa, dum + + ! Modification : I should check whether this is exactly same as the one used in + ! shallow convection and cloud macrophysics. + + do i = 1, ncol + do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface + dql = max(0._r8,1._r8*qlmin-ql(i,k)) + dqi = max(0._r8,1._r8*qimin-qi(i,k)) + qlten(i,k) = qlten(i,k) + dql/dt + qiten(i,k) = qiten(i,k) + dqi/dt + qvten(i,k) = qvten(i,k) - (dql+dqi)/dt + sten(i,k) = sten(i,k) + xlv * (dql/dt) + xls * (dqi/dt) + ql(i,k) = ql(i,k) + dql + qi(i,k) = qi(i,k) + dqi + qv(i,k) = qv(i,k) - dql - dqi + s(i,k) = s(i,k) + xlv * dql + xls * dqi + t(i,k) = t(i,k) + (xlv * dql + xls * dqi)/cp + dqv = max(0._r8,1._r8*qvmin-qv(i,k)) + qvten(i,k) = qvten(i,k) + dqv/dt + qv(i,k) = qv(i,k) + dqv + if( k .ne. 1 ) then + qv(i,k-1) = qv(i,k-1) - dqv*dp(i,k)/dp(i,k-1) + qvten(i,k-1) = qvten(i,k-1) - dqv*dp(i,k)/dp(i,k-1)/dt + endif + qv(i,k) = max(qv(i,k),qvmin) + ql(i,k) = max(ql(i,k),qlmin) + qi(i,k) = max(qi(i,k),qimin) + end do + ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally + ! extracted from all the layers that has 'qv > 2*qvmin'. This fully + ! preserves column moisture. + if( dqv .gt. 1.e-20_r8 ) then + sum = 0._r8 + do k = 1, mkx + if( qv(i,k) .gt. 2._r8*qvmin ) sum = sum + qv(i,k)*dp(i,k) + enddo + aa = dqv*dp(i,1)/max(1.e-20_r8,sum) + if( aa .lt. 0.5_r8 ) then + do k = 1, mkx + if( qv(i,k) .gt. 2._r8*qvmin ) then + dum = aa*qv(i,k) + qv(i,k) = qv(i,k) - dum + qvten(i,k) = qvten(i,k) - dum/dt + endif + enddo + else + write(iulog,*) 'Full positive_moisture is impossible in vertical_diffusion' + endif + endif + end do + return + + end subroutine positive_moisture end module vertical_diffusion From 00f5bb01423e6c9b0c128f717f732fefc9f84307 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 16 Aug 2023 20:41:31 +0200 Subject: [PATCH 09/71] more removal of OSLO_AERO ifdefs --- .../oslo_aero/hetfrz_classnuc_oslo.F90 | 1758 ++++++++--------- src/chemistry/oslo_aero/initlogn.F90 | 456 ++--- .../oslo_aero/mo_gas_phase_chemdr.F90 | 9 - src/chemistry/oslo_aero/mo_neu_wetdep.F90 | 8 - 4 files changed, 1075 insertions(+), 1156 deletions(-) diff --git a/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 b/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 index aadea38e2d..3910d2869a 100644 --- a/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 +++ b/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 @@ -1,680 +1,680 @@ module hetfrz_classnuc_oslo -!--------------------------------------------------------------------------------- -! -! CAM Interfaces for hetfrz_classnuc module. -! -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver, begchunk, endchunk -use physconst, only: rair, cpair, rh2o, rhoh2o, mwh2o, tmelt, pi -use constituents, only: cnst_get_ind, pcnst -use physics_types, only: physics_state -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field -use phys_control, only: phys_getopts, use_hetfrz_classnuc - -use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, & - pbuf_get_index, pbuf_get_field -use cam_history, only: addfld, add_default, outfld - -use ref_pres, only: top_lev => trop_cloud_top_lev -use wv_saturation, only: svp_water, svp_ice - -use cam_logfile, only: iulog -use error_messages, only: handle_errmsg, alloc_err -use cam_abortutils, only: endrun - -use hetfrz_classnuc, only: hetfrz_classnuc_init, hetfrz_classnuc_calc -use oslo_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius -use aerosoldef, only : MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT -implicit none -private -save - -public :: & - hetfrz_classnuc_oslo_readnl, & - hetfrz_classnuc_oslo_register, & - hetfrz_classnuc_oslo_init, & - hetfrz_classnuc_oslo_calc, & - hetfrz_classnuc_oslo_save_cbaero - -! Namelist variables -logical :: hist_hetfrz_classnuc = .false. - -! Vars set via init method. -real(r8) :: mincld ! minimum allowed cloud fraction - -! constituent indices -integer :: & - cldliq_idx = -1, & - cldice_idx = -1, & - numliq_idx = -1, & - numice_idx = -1 - -! pbuf indices for fields provided by heterogeneous freezing -integer :: & - frzimm_idx, & - frzcnt_idx, & - frzdep_idx - -! pbuf indices for fields needed by heterogeneous freezing -integer :: & - ast_idx = -1 - -! specie properties -real(r8) :: specdens_dust -real(r8) :: specdens_so4 -real(r8) :: specdens_bc -real(r8) :: specdens_soa -real(r8) :: specdens_pom - -! List all species -integer :: ncnst = 0 ! Total number of constituents (mass and number) needed - ! by the parameterization (depends on aerosol model used) - -integer :: so4_accum ! sulfate in accumulation mode -integer :: bc_accum ! black-c in accumulation mode -integer :: pom_accum ! p-organic in accumulation mode -integer :: soa_accum ! s-organic in accumulation mode -integer :: dst_accum ! dust in accumulation mode -integer :: ncl_accum ! seasalt in accumulation mode -integer :: num_accum ! number in accumulation mode - -integer :: dst_coarse ! dust in coarse mode -integer :: ncl_coarse ! seasalt in coarse mode -integer :: so4_coarse ! sulfate in coarse mode -integer :: num_coarse ! number in coarse mode - -integer :: dst_finedust ! dust in finedust mode -integer :: so4_finedust ! sulfate in finedust mode -integer :: num_finedust ! number in finedust mode - -integer :: dst_coardust ! dust in coardust mode -integer :: so4_coardust ! sulfate in coardust mode -integer :: num_coardust ! number in coardust mode - -integer :: bc_pcarbon ! black-c in primary carbon mode -integer :: pom_pcarbon ! p-organic in primary carbon mode -integer :: num_pcarbon ! number in primary carbon mode - -! Index arrays for looping over all constituents -integer, allocatable :: mode_idx(:) -integer, allocatable :: spec_idx(:) - -! Copy of cloud borne aerosols before modification by droplet nucleation -! The basis is converted from mass to volume. -real(r8), allocatable :: aer_cb(:,:,:,:) - -! Copy of interstitial aerosols with basis converted from mass to volume. -real(r8), allocatable :: aer(:,:,:,:) - -!=============================================================================== + !--------------------------------------------------------------------------------- + ! + ! CAM Interfaces for hetfrz_classnuc module. + ! + !--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, begchunk, endchunk + use physconst, only: rair, cpair, rh2o, rhoh2o, mwh2o, tmelt, pi + use constituents, only: cnst_get_ind, pcnst + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field + use phys_control, only: phys_getopts, use_hetfrz_classnuc + + use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, & + pbuf_get_index, pbuf_get_field + use cam_history, only: addfld, add_default, outfld + + use ref_pres, only: top_lev => trop_cloud_top_lev + use wv_saturation, only: svp_water, svp_ice + + use cam_logfile, only: iulog + use error_messages, only: handle_errmsg, alloc_err + use cam_abortutils, only: endrun + + use hetfrz_classnuc, only: hetfrz_classnuc_init, hetfrz_classnuc_calc + use oslo_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius + use aerosoldef, only : MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT + implicit none + private + save + + public :: & + hetfrz_classnuc_oslo_readnl, & + hetfrz_classnuc_oslo_register, & + hetfrz_classnuc_oslo_init, & + hetfrz_classnuc_oslo_calc, & + hetfrz_classnuc_oslo_save_cbaero + + ! Namelist variables + logical :: hist_hetfrz_classnuc = .false. + + ! Vars set via init method. + real(r8) :: mincld ! minimum allowed cloud fraction + + ! constituent indices + integer :: & + cldliq_idx = -1, & + cldice_idx = -1, & + numliq_idx = -1, & + numice_idx = -1 + + ! pbuf indices for fields provided by heterogeneous freezing + integer :: & + frzimm_idx, & + frzcnt_idx, & + frzdep_idx + + ! pbuf indices for fields needed by heterogeneous freezing + integer :: & + ast_idx = -1 + + ! specie properties + real(r8) :: specdens_dust + real(r8) :: specdens_so4 + real(r8) :: specdens_bc + real(r8) :: specdens_soa + real(r8) :: specdens_pom + + ! List all species + integer :: ncnst = 0 ! Total number of constituents (mass and number) needed + ! by the parameterization (depends on aerosol model used) + + integer :: so4_accum ! sulfate in accumulation mode + integer :: bc_accum ! black-c in accumulation mode + integer :: pom_accum ! p-organic in accumulation mode + integer :: soa_accum ! s-organic in accumulation mode + integer :: dst_accum ! dust in accumulation mode + integer :: ncl_accum ! seasalt in accumulation mode + integer :: num_accum ! number in accumulation mode + + integer :: dst_coarse ! dust in coarse mode + integer :: ncl_coarse ! seasalt in coarse mode + integer :: so4_coarse ! sulfate in coarse mode + integer :: num_coarse ! number in coarse mode + + integer :: dst_finedust ! dust in finedust mode + integer :: so4_finedust ! sulfate in finedust mode + integer :: num_finedust ! number in finedust mode + + integer :: dst_coardust ! dust in coardust mode + integer :: so4_coardust ! sulfate in coardust mode + integer :: num_coardust ! number in coardust mode + + integer :: bc_pcarbon ! black-c in primary carbon mode + integer :: pom_pcarbon ! p-organic in primary carbon mode + integer :: num_pcarbon ! number in primary carbon mode + + ! Index arrays for looping over all constituents + integer, allocatable :: mode_idx(:) + integer, allocatable :: spec_idx(:) + + ! Copy of cloud borne aerosols before modification by droplet nucleation + ! The basis is converted from mass to volume. + real(r8), allocatable :: aer_cb(:,:,:,:) + + ! Copy of interstitial aerosols with basis converted from mass to volume. + real(r8), allocatable :: aer(:,:,:,:) + + !=============================================================================== contains -!=============================================================================== + !=============================================================================== -subroutine hetfrz_classnuc_oslo_readnl(nlfile) + subroutine hetfrz_classnuc_oslo_readnl(nlfile) - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use mpishorthand + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use mpishorthand - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'hetfrz_classnuc_cam_readnl' + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'hetfrz_classnuc_cam_readnl' - namelist /hetfrz_classnuc_nl/ hist_hetfrz_classnuc + namelist /hetfrz_classnuc_nl/ hist_hetfrz_classnuc - !----------------------------------------------------------------------------- + !----------------------------------------------------------------------------- - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'hetfrz_classnuc_nl', status=ierr) - if (ierr == 0) then - read(unitn, hetfrz_classnuc_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'hetfrz_classnuc_nl', status=ierr) + if (ierr == 0) then + read(unitn, hetfrz_classnuc_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) - end if + end if #ifdef SPMD - ! Broadcast namelist variables - call mpibcast(hist_hetfrz_classnuc, 1, mpilog, 0, mpicom) + ! Broadcast namelist variables + call mpibcast(hist_hetfrz_classnuc, 1, mpilog, 0, mpicom) #endif -end subroutine hetfrz_classnuc_oslo_readnl + end subroutine hetfrz_classnuc_oslo_readnl + + !================================================================================================ + + subroutine hetfrz_classnuc_oslo_register() + + if (.not. use_hetfrz_classnuc) return + + ! pbuf fields provided by hetfrz_classnuc + call pbuf_add_field('FRZIMM', 'physpkg', dtype_r8, (/pcols,pver/), frzimm_idx) + call pbuf_add_field('FRZCNT', 'physpkg', dtype_r8, (/pcols,pver/), frzcnt_idx) + call pbuf_add_field('FRZDEP', 'physpkg', dtype_r8, (/pcols,pver/), frzdep_idx) + + end subroutine hetfrz_classnuc_oslo_register + + !================================================================================================ + + subroutine hetfrz_classnuc_oslo_init(mincld_in) + + real(r8), intent(in) :: mincld_in + + ! local variables + logical :: prog_modal_aero + integer :: m, n, nspec + integer :: istat + + real(r8) :: sigma_logr_aer + + character(len=32) :: str32 + character(len=*), parameter :: routine = 'hetfrz_classnuc_cam_init' + !-------------------------------------------------------------------------------------------- + + if (.not. use_hetfrz_classnuc) return + + ! This parameterization currently assumes that prognostic modal aerosols are on. Check... + call phys_getopts(prog_modal_aero_out=prog_modal_aero) + + mincld = mincld_in + + call cnst_get_ind('CLDLIQ', cldliq_idx) + call cnst_get_ind('CLDICE', cldice_idx) + call cnst_get_ind('NUMLIQ', numliq_idx) + call cnst_get_ind('NUMICE', numice_idx) + + ! pbuf fields used by hetfrz_classnuc + ast_idx = pbuf_get_index('AST') + + call addfld('bc_num', (/ 'lev' /), 'A', '#/cm3', 'total bc number') + call addfld('dst1_num', (/ 'lev' /), 'A', '#/cm3', 'total dst1 number') + call addfld('dst3_num', (/ 'lev' /), 'A', '#/cm3', 'total dst3 number') + call addfld('bcc_num', (/ 'lev' /), 'A', '#/cm3', 'coated bc number') + call addfld('dst1c_num', (/ 'lev' /), 'A', '#/cm3', 'coated dst1 number') + call addfld('dst3c_num', (/ 'lev' /), 'A', '#/cm3', 'coated dst3 number') + call addfld('bcuc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated bc number') + call addfld('dst1uc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated dst1 number') + call addfld('dst3uc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated dst3 number') + + call addfld('bc_a1_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial bc number') + call addfld('dst_a1_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial dst1 number') + call addfld('dst_a3_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial dst3 number') + call addfld('bc_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne bc number') + call addfld('dst_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst1 number') + call addfld('dst_c3_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst3 number') + + call addfld('fn_bc_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne bc number derived from fn') + call addfld('fn_dst_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst1 number derived from fn') + call addfld('fn_dst_c3_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst3 number derived from fn') + + call addfld('na500', (/ 'lev' /), 'A', '#/cm3', 'interstitial aerosol number with D>500 nm') + call addfld('totna500', (/ 'lev' /), 'A', '#/cm3', 'total aerosol number with D>500 nm') + + call addfld('FREQIMM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of immersion freezing') + call addfld('FREQCNT', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of contact freezing') + call addfld('FREQDEP', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of deposition freezing') + call addfld('FREQMIX', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of mixed-phase clouds' ) + + call addfld('DSTFREZIMM', (/ 'lev' /), 'A', 'm-3s-1', 'dust immersion freezing rate') + call addfld('DSTFREZCNT', (/ 'lev' /), 'A', 'm-3s-1', 'dust contact freezing rate') + call addfld('DSTFREZDEP', (/ 'lev' /), 'A', 'm-3s-1', 'dust deposition freezing rate') + + call addfld('BCFREZIMM', (/ 'lev' /), 'A', 'm-3s-1', 'bc immersion freezing rate') + call addfld('BCFREZCNT', (/ 'lev' /), 'A', 'm-3s-1', 'bc contact freezing rate') + call addfld('BCFREZDEP', (/ 'lev' /), 'A', 'm-3s-1', 'bc deposition freezing rate') + + call addfld('NIMIX_IMM', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to het immersion freezing in Mixed Clouds') + call addfld('NIMIX_CNT', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to het contact freezing in Mixed Clouds') + call addfld('NIMIX_DEP', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to het deposition freezing in Mixed Clouds') + + call addfld('DSTNIDEP', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to dst dep freezing in Mixed Clouds') + call addfld('DSTNICNT', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to dst cnt freezing in Mixed Clouds') + call addfld('DSTNIIMM', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to dst imm freezing in Mixed Clouds') + + call addfld('BCNIDEP', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to bc dep freezing in Mixed Clouds') + call addfld('BCNICNT', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to bc cnt freezing in Mixed Clouds') + call addfld('BCNIIMM', (/ 'lev' /), 'A', '#/m3', & + 'Activated Ice Number Concentration due to bc imm freezing in Mixed Clouds') + + call addfld('NUMICE10s', (/ 'lev' /), 'A', '#/m3', & + 'Ice Number Concentration due to het freezing in Mixed Clouds during 10-s period') + call addfld('NUMIMM10sDST', (/ 'lev' /), 'A', '#/m3', & + 'Ice Number Concentration due to imm freezing by dst in Mixed Clouds during 10-s period') + call addfld('NUMIMM10sBC', (/ 'lev' /), 'A', '#/m3', & + 'Ice Number Concentration due to imm freezing by bc in Mixed Clouds during 10-s period') + + if (hist_hetfrz_classnuc) then + + call add_default('bc_num', 1, ' ') + call add_default('dst1_num', 1, ' ') + call add_default('dst3_num', 1, ' ') + call add_default('bcc_num', 1, ' ') + call add_default('dst1c_num', 1, ' ') + call add_default('dst3c_num', 1, ' ') + call add_default('bcuc_num', 1, ' ') + call add_default('dst1uc_num', 1, ' ') + call add_default('dst3uc_num', 1, ' ') + + call add_default('bc_a1_num', 1, ' ') + call add_default('dst_a1_num', 1, ' ') + call add_default('dst_a3_num', 1, ' ') + call add_default('bc_c1_num', 1, ' ') + call add_default('dst_c1_num', 1, ' ') + call add_default('dst_c3_num', 1, ' ') + + call add_default('fn_bc_c1_num', 1, ' ') + call add_default('fn_dst_c1_num', 1, ' ') + call add_default('fn_dst_c3_num', 1, ' ') + + call add_default('na500', 1, ' ') + call add_default('totna500', 1, ' ') + + call add_default('FREQIMM', 1, ' ') + call add_default('FREQCNT', 1, ' ') + call add_default('FREQDEP', 1, ' ') + call add_default('FREQMIX', 1, ' ') + + call add_default('DSTFREZIMM', 1, ' ') + call add_default('DSTFREZCNT', 1, ' ') + call add_default('DSTFREZDEP', 1, ' ') + + call add_default('BCFREZIMM', 1, ' ') + call add_default('BCFREZCNT', 1, ' ') + call add_default('BCFREZDEP', 1, ' ') + + call add_default('NIMIX_IMM', 1, ' ') + call add_default('NIMIX_CNT', 1, ' ') + call add_default('NIMIX_DEP', 1, ' ') + + call add_default('DSTNIDEP', 1, ' ') + call add_default('DSTNICNT', 1, ' ') + call add_default('DSTNIIMM', 1, ' ') + + call add_default('BCNIDEP', 1, ' ') + call add_default('BCNICNT', 1, ' ') + call add_default('BCNIIMM', 1, ' ') + + call add_default('NUMICE10s', 1, ' ') + call add_default('NUMIMM10sDST', 1, ' ') + call add_default('NUMIMM10sBC', 1, ' ') + + end if + + ! The following code sets indices of the mode specific species used + ! in the module. Having a list of the species needed allows us to + ! allocate temporary space for just those species rather than for all the + ! CAM species (pcnst) which may be considerably more than needed. + ! + ! The indices set below are for use with the CAM rad_constituents + ! interfaces. Using the rad_constituents interfaces isolates the physics + ! parameterization which requires constituent information from the chemistry + ! code which provides that information. + + ! Allocate space for copy of cloud borne aerosols before modification by droplet nucleation. + allocate(aer_cb(pcols,pver,pcnst,begchunk:endchunk), stat=istat) + call alloc_err(istat, routine, 'aer_cb', pcols*pver*ncnst*(endchunk-begchunk+1)) + + ! Allocate space for copy of interstitial aerosols with modified basis + allocate(aer(pcols,pver,pcnst,begchunk:endchunk), stat=istat) + call alloc_err(istat, routine, 'aer', pcols*pver*ncnst*(endchunk-begchunk+1)) + call hetfrz_classnuc_init( & + rair, cpair, rh2o, rhoh2o, mwh2o, & + tmelt, pi, iulog) + + end subroutine hetfrz_classnuc_oslo_init + + !================================================================================================ + + subroutine hetfrz_classnuc_oslo_calc( & + state, deltatin, factnum, pbuf & + ,numberConcentration, volumeConcentration & + ,f_acm, f_bcm, f_aqm, f_so4_condm, f_soam & + ,hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) + + use commondefinitions, only: nmodes_oslo => nmodes + use modal_aero_data, only : qqcw_get_field + use aerosoldef, only : getNumberOfTracersInMode, getTracerIndex + implicit none + + ! arguments + type(physics_state), target, intent(in) :: state + real(r8), intent(in) :: deltatin ! time step (s) + real(r8), intent(in) :: factnum(:,:,:) ! activation fraction for aerosol number + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes_oslo) + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes_oslo) + + real(r8),intent(in) :: f_acm(pcols,pver, nmodes_oslo) + real(r8),intent(in) :: f_bcm(pcols,pver, nmodes_oslo) + real(r8),intent(in) :: f_aqm(pcols, pver, nmodes_oslo) + real(r8),intent(in) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" + real(r8),intent(in) :: f_soam(pcols, pver, nmodes_oslo) + + real(r8),intent(in) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity + real(r8),intent(in) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma + real(r8),intent(in) :: cam(pcols,pver,nmodes_oslo) + real(r8),intent(in) :: volumeCore(pcols,pver,nmodes_oslo) + real(r8),intent(in) :: volumeCoat(pcols,pver,nmodes_oslo) + + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local workspace + + ! outputs shared with the microphysics via the pbuf + real(r8), pointer :: frzimm(:,:) + real(r8), pointer :: frzcnt(:,:) + real(r8), pointer :: frzdep(:,:) + + integer :: itim_old + integer :: i, k + + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + + real(r8), pointer :: ast(:,:) + + real(r8) :: lcldm(pcols,pver) + + real(r8), pointer :: ptr2d(:,:) + + real(r8) :: fn(3) + real(r8) :: awcam(pcols,pver,3) + real(r8) :: awfacm(pcols,pver,3) + real(r8) :: hetraer(pcols,pver,3) + real(r8) :: dstcoat(pcols,pver,3) + real(r8) :: total_interstitial_aer_num(pcols,pver,3) + real(r8) :: total_cloudborne_aer_num(pcols,pver,3) + real(r8) :: total_aer_num(pcols,pver,3) + real(r8) :: coated_aer_num(pcols,pver,3) + real(r8) :: uncoated_aer_num(pcols,pver,3) + + real(r8) :: fn_cloudborne_aer_num(pcols,pver,3) + + + real(r8) :: con1, r3lx, supersatice + + real(r8) :: qcic + real(r8) :: ncic + + real(r8) :: frzbcimm(pcols,pver), frzduimm(pcols,pver) + real(r8) :: frzbccnt(pcols,pver), frzducnt(pcols,pver) + real(r8) :: frzbcdep(pcols,pver), frzdudep(pcols,pver) + + real(r8) :: freqimm(pcols,pver), freqcnt(pcols,pver), freqdep(pcols,pver), freqmix(pcols,pver) + real(r8) :: nnuccc_bc(pcols,pver), nnucct_bc(pcols,pver), nnudep_bc(pcols,pver) + real(r8) :: nnuccc_dst(pcols,pver), nnucct_dst(pcols,pver), nnudep_dst(pcols,pver) + real(r8) :: niimm_bc(pcols,pver), nicnt_bc(pcols,pver), nidep_bc(pcols,pver) + real(r8) :: niimm_dst(pcols,pver), nicnt_dst(pcols,pver), nidep_dst(pcols,pver) + real(r8) :: numice10s(pcols,pver) + real(r8) :: numice10s_imm_dst(pcols,pver) + real(r8) :: numice10s_imm_bc(pcols,pver) + + !++oslo aerosol specific + real(r8) :: qaercwpt(pcols,pver,pcnst) + real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) + real(r8) :: numberMedianRadius(pcols,pver,nmodes_oslo) + !--oslo aerosol specific -!================================================================================================ + real(r8) :: na500(pcols,pver) + real(r8) :: tot_na500(pcols,pver) -subroutine hetfrz_classnuc_oslo_register() + character(128) :: errstring ! Error status - if (.not. use_hetfrz_classnuc) return + integer :: n, m, kk + !------------------------------------------------------------------------------- - ! pbuf fields provided by hetfrz_classnuc - call pbuf_add_field('FRZIMM', 'physpkg', dtype_r8, (/pcols,pver/), frzimm_idx) - call pbuf_add_field('FRZCNT', 'physpkg', dtype_r8, (/pcols,pver/), frzcnt_idx) - call pbuf_add_field('FRZDEP', 'physpkg', dtype_r8, (/pcols,pver/), frzdep_idx) + associate( & + lchnk => state%lchnk, & + ncol => state%ncol, & + t => state%t, & + qc => state%q(:pcols,:pver,cldliq_idx), & + nc => state%q(:pcols,:pver,numliq_idx), & + pmid => state%pmid ) -end subroutine hetfrz_classnuc_oslo_register + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) -!================================================================================================ + rho(:,:) = 0._r8 -subroutine hetfrz_classnuc_oslo_init(mincld_in) - - real(r8), intent(in) :: mincld_in - - ! local variables - logical :: prog_modal_aero - integer :: m, n, nspec - integer :: istat - - real(r8) :: sigma_logr_aer - - character(len=32) :: str32 - character(len=*), parameter :: routine = 'hetfrz_classnuc_cam_init' - !-------------------------------------------------------------------------------------------- - - if (.not. use_hetfrz_classnuc) return - - ! This parameterization currently assumes that prognostic modal aerosols are on. Check... - call phys_getopts(prog_modal_aero_out=prog_modal_aero) - - mincld = mincld_in - - call cnst_get_ind('CLDLIQ', cldliq_idx) - call cnst_get_ind('CLDICE', cldice_idx) - call cnst_get_ind('NUMLIQ', numliq_idx) - call cnst_get_ind('NUMICE', numice_idx) - - ! pbuf fields used by hetfrz_classnuc - ast_idx = pbuf_get_index('AST') - - call addfld('bc_num', (/ 'lev' /), 'A', '#/cm3', 'total bc number') - call addfld('dst1_num', (/ 'lev' /), 'A', '#/cm3', 'total dst1 number') - call addfld('dst3_num', (/ 'lev' /), 'A', '#/cm3', 'total dst3 number') - call addfld('bcc_num', (/ 'lev' /), 'A', '#/cm3', 'coated bc number') - call addfld('dst1c_num', (/ 'lev' /), 'A', '#/cm3', 'coated dst1 number') - call addfld('dst3c_num', (/ 'lev' /), 'A', '#/cm3', 'coated dst3 number') - call addfld('bcuc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated bc number') - call addfld('dst1uc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated dst1 number') - call addfld('dst3uc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated dst3 number') - - call addfld('bc_a1_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial bc number') - call addfld('dst_a1_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial dst1 number') - call addfld('dst_a3_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial dst3 number') - call addfld('bc_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne bc number') - call addfld('dst_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst1 number') - call addfld('dst_c3_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst3 number') - - call addfld('fn_bc_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne bc number derived from fn') - call addfld('fn_dst_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst1 number derived from fn') - call addfld('fn_dst_c3_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst3 number derived from fn') - - call addfld('na500', (/ 'lev' /), 'A', '#/cm3', 'interstitial aerosol number with D>500 nm') - call addfld('totna500', (/ 'lev' /), 'A', '#/cm3', 'total aerosol number with D>500 nm') - - call addfld('FREQIMM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of immersion freezing') - call addfld('FREQCNT', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of contact freezing') - call addfld('FREQDEP', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of deposition freezing') - call addfld('FREQMIX', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of mixed-phase clouds' ) - - call addfld('DSTFREZIMM', (/ 'lev' /), 'A', 'm-3s-1', 'dust immersion freezing rate') - call addfld('DSTFREZCNT', (/ 'lev' /), 'A', 'm-3s-1', 'dust contact freezing rate') - call addfld('DSTFREZDEP', (/ 'lev' /), 'A', 'm-3s-1', 'dust deposition freezing rate') - - call addfld('BCFREZIMM', (/ 'lev' /), 'A', 'm-3s-1', 'bc immersion freezing rate') - call addfld('BCFREZCNT', (/ 'lev' /), 'A', 'm-3s-1', 'bc contact freezing rate') - call addfld('BCFREZDEP', (/ 'lev' /), 'A', 'm-3s-1', 'bc deposition freezing rate') - - call addfld('NIMIX_IMM', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to het immersion freezing in Mixed Clouds') - call addfld('NIMIX_CNT', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to het contact freezing in Mixed Clouds') - call addfld('NIMIX_DEP', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to het deposition freezing in Mixed Clouds') - - call addfld('DSTNIDEP', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to dst dep freezing in Mixed Clouds') - call addfld('DSTNICNT', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to dst cnt freezing in Mixed Clouds') - call addfld('DSTNIIMM', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to dst imm freezing in Mixed Clouds') - - call addfld('BCNIDEP', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to bc dep freezing in Mixed Clouds') - call addfld('BCNICNT', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to bc cnt freezing in Mixed Clouds') - call addfld('BCNIIMM', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to bc imm freezing in Mixed Clouds') - - call addfld('NUMICE10s', (/ 'lev' /), 'A', '#/m3', & - 'Ice Number Concentration due to het freezing in Mixed Clouds during 10-s period') - call addfld('NUMIMM10sDST', (/ 'lev' /), 'A', '#/m3', & - 'Ice Number Concentration due to imm freezing by dst in Mixed Clouds during 10-s period') - call addfld('NUMIMM10sBC', (/ 'lev' /), 'A', '#/m3', & - 'Ice Number Concentration due to imm freezing by bc in Mixed Clouds during 10-s period') - - if (hist_hetfrz_classnuc) then - - call add_default('bc_num', 1, ' ') - call add_default('dst1_num', 1, ' ') - call add_default('dst3_num', 1, ' ') - call add_default('bcc_num', 1, ' ') - call add_default('dst1c_num', 1, ' ') - call add_default('dst3c_num', 1, ' ') - call add_default('bcuc_num', 1, ' ') - call add_default('dst1uc_num', 1, ' ') - call add_default('dst3uc_num', 1, ' ') - - call add_default('bc_a1_num', 1, ' ') - call add_default('dst_a1_num', 1, ' ') - call add_default('dst_a3_num', 1, ' ') - call add_default('bc_c1_num', 1, ' ') - call add_default('dst_c1_num', 1, ' ') - call add_default('dst_c3_num', 1, ' ') - - call add_default('fn_bc_c1_num', 1, ' ') - call add_default('fn_dst_c1_num', 1, ' ') - call add_default('fn_dst_c3_num', 1, ' ') - - call add_default('na500', 1, ' ') - call add_default('totna500', 1, ' ') - - call add_default('FREQIMM', 1, ' ') - call add_default('FREQCNT', 1, ' ') - call add_default('FREQDEP', 1, ' ') - call add_default('FREQMIX', 1, ' ') - - call add_default('DSTFREZIMM', 1, ' ') - call add_default('DSTFREZCNT', 1, ' ') - call add_default('DSTFREZDEP', 1, ' ') - - call add_default('BCFREZIMM', 1, ' ') - call add_default('BCFREZCNT', 1, ' ') - call add_default('BCFREZDEP', 1, ' ') - - call add_default('NIMIX_IMM', 1, ' ') - call add_default('NIMIX_CNT', 1, ' ') - call add_default('NIMIX_DEP', 1, ' ') - - call add_default('DSTNIDEP', 1, ' ') - call add_default('DSTNICNT', 1, ' ') - call add_default('DSTNIIMM', 1, ' ') - - call add_default('BCNIDEP', 1, ' ') - call add_default('BCNICNT', 1, ' ') - call add_default('BCNIIMM', 1, ' ') - - call add_default('NUMICE10s', 1, ' ') - call add_default('NUMIMM10sDST', 1, ' ') - call add_default('NUMIMM10sBC', 1, ' ') - - end if - - ! The following code sets indices of the mode specific species used - ! in the module. Having a list of the species needed allows us to - ! allocate temporary space for just those species rather than for all the - ! CAM species (pcnst) which may be considerably more than needed. - ! - ! The indices set below are for use with the CAM rad_constituents - ! interfaces. Using the rad_constituents interfaces isolates the physics - ! parameterization which requires constituent information from the chemistry - ! code which provides that information. - - ! Allocate space for copy of cloud borne aerosols before modification by droplet nucleation. - allocate(aer_cb(pcols,pver,pcnst,begchunk:endchunk), stat=istat) - call alloc_err(istat, routine, 'aer_cb', pcols*pver*ncnst*(endchunk-begchunk+1)) - - ! Allocate space for copy of interstitial aerosols with modified basis - allocate(aer(pcols,pver,pcnst,begchunk:endchunk), stat=istat) - call alloc_err(istat, routine, 'aer', pcols*pver*ncnst*(endchunk-begchunk+1)) - call hetfrz_classnuc_init( & - rair, cpair, rh2o, rhoh2o, mwh2o, & - tmelt, pi, iulog) - -end subroutine hetfrz_classnuc_oslo_init - -!================================================================================================ - -subroutine hetfrz_classnuc_oslo_calc( & - state, deltatin, factnum, pbuf & - ,numberConcentration, volumeConcentration & - ,f_acm, f_bcm, f_aqm, f_so4_condm, f_soam & - ,hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) - - use commondefinitions, only: nmodes_oslo => nmodes - use modal_aero_data, only : qqcw_get_field - use aerosoldef, only : getNumberOfTracersInMode, getTracerIndex - implicit none - - ! arguments - type(physics_state), target, intent(in) :: state - real(r8), intent(in) :: deltatin ! time step (s) - real(r8), intent(in) :: factnum(:,:,:) ! activation fraction for aerosol number - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes_oslo) - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes_oslo) - - real(r8),intent(in) :: f_acm(pcols,pver, nmodes_oslo) - real(r8),intent(in) :: f_bcm(pcols,pver, nmodes_oslo) - real(r8),intent(in) :: f_aqm(pcols, pver, nmodes_oslo) - real(r8),intent(in) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" - real(r8),intent(in) :: f_soam(pcols, pver, nmodes_oslo) - - real(r8),intent(in) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity - real(r8),intent(in) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma - real(r8),intent(in) :: cam(pcols,pver,nmodes_oslo) - real(r8),intent(in) :: volumeCore(pcols,pver,nmodes_oslo) - real(r8),intent(in) :: volumeCoat(pcols,pver,nmodes_oslo) - - type(physics_buffer_desc), pointer :: pbuf(:) - - ! local workspace - - ! outputs shared with the microphysics via the pbuf - real(r8), pointer :: frzimm(:,:) - real(r8), pointer :: frzcnt(:,:) - real(r8), pointer :: frzdep(:,:) - - integer :: itim_old - integer :: i, k - - real(r8) :: rho(pcols,pver) ! air density (kg m-3) - - real(r8), pointer :: ast(:,:) - - real(r8) :: lcldm(pcols,pver) - - real(r8), pointer :: ptr2d(:,:) - - real(r8) :: fn(3) - real(r8) :: awcam(pcols,pver,3) - real(r8) :: awfacm(pcols,pver,3) - real(r8) :: hetraer(pcols,pver,3) - real(r8) :: dstcoat(pcols,pver,3) - real(r8) :: total_interstitial_aer_num(pcols,pver,3) - real(r8) :: total_cloudborne_aer_num(pcols,pver,3) - real(r8) :: total_aer_num(pcols,pver,3) - real(r8) :: coated_aer_num(pcols,pver,3) - real(r8) :: uncoated_aer_num(pcols,pver,3) - - real(r8) :: fn_cloudborne_aer_num(pcols,pver,3) - - - real(r8) :: con1, r3lx, supersatice - - real(r8) :: qcic - real(r8) :: ncic - - real(r8) :: frzbcimm(pcols,pver), frzduimm(pcols,pver) - real(r8) :: frzbccnt(pcols,pver), frzducnt(pcols,pver) - real(r8) :: frzbcdep(pcols,pver), frzdudep(pcols,pver) - - real(r8) :: freqimm(pcols,pver), freqcnt(pcols,pver), freqdep(pcols,pver), freqmix(pcols,pver) - real(r8) :: nnuccc_bc(pcols,pver), nnucct_bc(pcols,pver), nnudep_bc(pcols,pver) - real(r8) :: nnuccc_dst(pcols,pver), nnucct_dst(pcols,pver), nnudep_dst(pcols,pver) - real(r8) :: niimm_bc(pcols,pver), nicnt_bc(pcols,pver), nidep_bc(pcols,pver) - real(r8) :: niimm_dst(pcols,pver), nicnt_dst(pcols,pver), nidep_dst(pcols,pver) - real(r8) :: numice10s(pcols,pver) - real(r8) :: numice10s_imm_dst(pcols,pver) - real(r8) :: numice10s_imm_bc(pcols,pver) - -!++oslo aerosol specific - real(r8) :: qaercwpt(pcols,pver,pcnst) - real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) - real(r8) :: numberMedianRadius(pcols,pver,nmodes_oslo) -!--oslo aerosol specific - - real(r8) :: na500(pcols,pver) - real(r8) :: tot_na500(pcols,pver) - - character(128) :: errstring ! Error status - - integer :: n, m, kk - !------------------------------------------------------------------------------- - - associate( & - lchnk => state%lchnk, & - ncol => state%ncol, & - t => state%t, & - qc => state%q(:pcols,:pver,cldliq_idx), & - nc => state%q(:pcols,:pver,numliq_idx), & - pmid => state%pmid ) - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - rho(:,:) = 0._r8 - - do k = top_lev, pver - do i = 1, ncol - rho(i,k) = pmid(i,k)/(rair*t(i,k)) - end do - end do - - do k = top_lev, pver - do i = 1, ncol - lcldm(i,k) = max(ast(i,k), mincld) - end do - end do - - ! Convert interstitial and cloud borne aerosols from a mass to a volume basis before - ! being used in get_aer_num - do i = 1, pcnst - aer_cb(:ncol,:,i,lchnk) = aer_cb(:ncol,:,i,lchnk) * rho(:ncol,:) - - ! Check whether constituent is a mass or number mixing ratio - !if (spec_idx(i) == 0) then - ! call rad_cnst_get_mode_num(0, mode_idx(i), 'a', state, pbuf, ptr2d) - !else - ! call rad_cnst_get_aer_mmr(0, mode_idx(i), spec_idx(i), 'a', state, pbuf, ptr2d) - !end if - !aer(:ncol,:,i,lchnk) = ptr2d(:ncol,:) * rho(:ncol,:) - end do - - ! Init top levels of outputs of get_aer_num - total_aer_num = 0._r8 - coated_aer_num = 0._r8 - uncoated_aer_num = 0._r8 - total_interstitial_aer_num = 0._r8 - total_cloudborne_aer_num = 0._r8 - hetraer = 0._r8 - awcam = 0._r8 - awfacm = 0._r8 - dstcoat = 0._r8 - na500 = 0._r8 - tot_na500 = 0._r8 - - - !Get estimate of number of aerosols inside clouds - call calculateNumberConcentration(ncol, aer_cb, rho, CloudnumberConcentration) - call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) - !End estimate of number inside clouds - - ! output aerosols as reference information for heterogeneous freezing - do i = 1, ncol - do k = top_lev, pver - call get_aer_num(numberConcentration(i,k,:), CloudnumberConcentration(i,k,:), rho(i,k), & - !++ MH_2015/04/10 - f_acm(i,k,:), f_so4_condm(i,k,:), cam(i,k,:), volumeCore(i,k,:), volumeCoat(i,k,:), & - !-- MH_2015/04/10 - total_aer_num(i,k,:), coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), & - total_interstitial_aer_num(i,k,:), total_cloudborne_aer_num(i,k,:), & - hetraer(i,k,:), awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), & - na500(i,k), tot_na500(i,k)) - - fn_cloudborne_aer_num(i,k,1) = total_aer_num(i,k,1)*factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc - fn_cloudborne_aer_num(i,k,2) = total_aer_num(i,k,2)*factnum(i,k,MODE_IDX_DST_A2) - fn_cloudborne_aer_num(i,k,3) = total_aer_num(i,k,3)*factnum(i,k,MODE_IDX_DST_A3) - end do - end do - - call outfld('bc_num', total_aer_num(:,:,1), pcols, lchnk) - call outfld('dst1_num', total_aer_num(:,:,2), pcols, lchnk) - call outfld('dst3_num', total_aer_num(:,:,3), pcols, lchnk) - - call outfld('bcc_num', coated_aer_num(:,:,1), pcols, lchnk) - call outfld('dst1c_num', coated_aer_num(:,:,2), pcols, lchnk) - call outfld('dst3c_num', coated_aer_num(:,:,3), pcols, lchnk) - - call outfld('bcuc_num', uncoated_aer_num(:,:,1), pcols, lchnk) - call outfld('dst1uc_num', uncoated_aer_num(:,:,2), pcols, lchnk) - call outfld('dst3uc_num', uncoated_aer_num(:,:,3), pcols, lchnk) - - call outfld('bc_a1_num', total_interstitial_aer_num(:,:,1), pcols, lchnk) - call outfld('dst_a1_num', total_interstitial_aer_num(:,:,2), pcols, lchnk) - call outfld('dst_a3_num', total_interstitial_aer_num(:,:,3), pcols, lchnk) - - call outfld('bc_c1_num', total_cloudborne_aer_num(:,:,1), pcols, lchnk) - call outfld('dst_c1_num', total_cloudborne_aer_num(:,:,2), pcols, lchnk) - call outfld('dst_c3_num', total_cloudborne_aer_num(:,:,3), pcols, lchnk) - - call outfld('fn_bc_c1_num', fn_cloudborne_aer_num(:,:,1), pcols, lchnk) - call outfld('fn_dst_c1_num', fn_cloudborne_aer_num(:,:,2), pcols, lchnk) - call outfld('fn_dst_c3_num', fn_cloudborne_aer_num(:,:,3), pcols, lchnk) - - call outfld('na500', na500, pcols, lchnk) - call outfld('totna500', tot_na500, pcols, lchnk) - - ! frzimm, frzcnt, frzdep are the outputs of this parameterization used by the microphysics - call pbuf_get_field(pbuf, frzimm_idx, frzimm) - call pbuf_get_field(pbuf, frzcnt_idx, frzcnt) - call pbuf_get_field(pbuf, frzdep_idx, frzdep) - - frzimm(:ncol,:) = 0._r8 - frzcnt(:ncol,:) = 0._r8 - frzdep(:ncol,:) = 0._r8 - - frzbcimm(:ncol,:) = 0._r8 - frzduimm(:ncol,:) = 0._r8 - frzbccnt(:ncol,:) = 0._r8 - frzducnt(:ncol,:) = 0._r8 - frzbcdep(:ncol,:) = 0._r8 - frzdudep(:ncol,:) = 0._r8 - - freqimm(:ncol,:) = 0._r8 - freqcnt(:ncol,:) = 0._r8 - freqdep(:ncol,:) = 0._r8 - freqmix(:ncol,:) = 0._r8 - - numice10s(:ncol,:) = 0._r8 - numice10s_imm_dst(:ncol,:) = 0._r8 - numice10s_imm_bc(:ncol,:) = 0._r8 - - nnuccc_bc(:,:) = 0._r8 - nnucct_bc(:,:) = 0._r8 - nnudep_bc(:,:) = 0._r8 - - nnuccc_dst(:,:) = 0._r8 - nnucct_dst(:,:) = 0._r8 - nnudep_dst(:,:) = 0._r8 - - niimm_bc(:,:) = 0._r8 - nicnt_bc(:,:) = 0._r8 - nidep_bc(:,:) = 0._r8 - - niimm_dst(:,:) = 0._r8 - nicnt_dst(:,:) = 0._r8 - nidep_dst(:,:) = 0._r8 - - do i = 1, ncol - do k = top_lev, pver - - if (t(i,k) > 235.15_r8 .and. t(i,k) < 269.15_r8) then - qcic = min(qc(i,k)/lcldm(i,k), 5.e-3_r8) - ncic = max(nc(i,k)/lcldm(i,k), 0._r8) - - con1 = 1._r8/(1.333_r8*pi)**0.333_r8 - r3lx = con1*(rho(i,k)*qcic/(rhoh2o*max(ncic*rho(i,k), 1.0e6_r8)))**0.333_r8 ! in m - r3lx = max(4.e-6_r8, r3lx) - supersatice = svp_water(t(i,k))/svp_ice(t(i,k)) - fn(1) = factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc accumulation mode - fn(2) = factnum(i,k,MODE_IDX_DST_A2) ! dust_a1 accumulation mode - fn(3) = factnum(i,k,MODE_IDX_DST_A3) ! dust_a3 coarse mode - - call hetfrz_classnuc_calc( & - deltatin, t(i,k), pmid(i,k), supersatice, & - fn, r3lx, ncic*rho(i,k)*1.0e-6_r8, frzbcimm(i,k), frzduimm(i,k), & - frzbccnt(i,k), frzducnt(i,k), frzbcdep(i,k), frzdudep(i,k), hetraer(i,k,:), & - awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), total_aer_num(i,k,:), & - coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), total_interstitial_aer_num(i,k,:), & - total_cloudborne_aer_num(i,k,:), errstring) - - call handle_errmsg(errstring, subname="hetfrz_classnuc_calc") - - frzimm(i,k) = frzbcimm(i,k) + frzduimm(i,k) - frzcnt(i,k) = frzbccnt(i,k) + frzducnt(i,k) - frzdep(i,k) = frzbcdep(i,k) + frzdudep(i,k) - - if (frzimm(i,k) > 0._r8) freqimm(i,k) = 1._r8 - if (frzcnt(i,k) > 0._r8) freqcnt(i,k) = 1._r8 - if (frzdep(i,k) > 0._r8) freqdep(i,k) = 1._r8 - if ((frzimm(i,k) + frzcnt(i,k) + frzdep(i,k)) > 0._r8) freqmix(i,k) = 1._r8 - else - frzimm(i,k) = 0._r8 - frzcnt(i,k) = 0._r8 - frzdep(i,k) = 0._r8 - end if - - nnuccc_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*ast(i,k) - nnucct_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*ast(i,k) - nnudep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*ast(i,k) - - nnuccc_dst(i,k) = frzduimm(i,k)*1.0e6_r8*ast(i,k) - nnucct_dst(i,k) = frzducnt(i,k)*1.0e6_r8*ast(i,k) - nnudep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*ast(i,k) - - niimm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin - nicnt_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*deltatin - nidep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*deltatin - - niimm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin - nicnt_dst(i,k) = frzducnt(i,k)*1.0e6_r8*deltatin - nidep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*deltatin - - numice10s(i,k) = (frzimm(i,k)+frzcnt(i,k)+frzdep(i,k))*1.0e6_r8*deltatin*(10._r8/deltatin) - numice10s_imm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) - numice10s_imm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) - end do - end do - - call outfld('FREQIMM', freqimm, pcols, lchnk) - call outfld('FREQCNT', freqcnt, pcols, lchnk) - call outfld('FREQDEP', freqdep, pcols, lchnk) - call outfld('FREQMIX', freqmix, pcols, lchnk) - - call outfld('DSTFREZIMM', nnuccc_dst, pcols, lchnk) - call outfld('DSTFREZCNT', nnucct_dst, pcols, lchnk) - call outfld('DSTFREZDEP', nnudep_dst, pcols, lchnk) - - call outfld('BCFREZIMM', nnuccc_bc, pcols, lchnk) - call outfld('BCFREZCNT', nnucct_bc, pcols, lchnk) - call outfld('BCFREZDEP', nnudep_bc, pcols, lchnk) - - call outfld('NIMIX_IMM', niimm_bc+niimm_dst, pcols, lchnk) - call outfld('NIMIX_CNT', nicnt_bc+nicnt_dst, pcols, lchnk) - call outfld('NIMIX_DEP', nidep_bc+nidep_dst, pcols, lchnk) - - call outfld('DSTNICNT', nicnt_dst, pcols, lchnk) - call outfld('DSTNIDEP', nidep_dst, pcols, lchnk) - call outfld('DSTNIIMM', niimm_dst, pcols, lchnk) - - call outfld('BCNICNT', nicnt_bc, pcols, lchnk) - call outfld('BCNIDEP', nidep_bc, pcols, lchnk) - call outfld('BCNIIMM', niimm_bc, pcols, lchnk) - - call outfld('NUMICE10s', numice10s, pcols, lchnk) - call outfld('NUMIMM10sDST', numice10s_imm_dst, pcols, lchnk) - call outfld('NUMIMM10sBC', numice10s_imm_bc, pcols, lchnk) - - end associate + do k = top_lev, pver + do i = 1, ncol + rho(i,k) = pmid(i,k)/(rair*t(i,k)) + end do + end do + + do k = top_lev, pver + do i = 1, ncol + lcldm(i,k) = max(ast(i,k), mincld) + end do + end do + + ! Convert interstitial and cloud borne aerosols from a mass to a volume basis before + ! being used in get_aer_num + do i = 1, pcnst + aer_cb(:ncol,:,i,lchnk) = aer_cb(:ncol,:,i,lchnk) * rho(:ncol,:) + + ! Check whether constituent is a mass or number mixing ratio + !if (spec_idx(i) == 0) then + ! call rad_cnst_get_mode_num(0, mode_idx(i), 'a', state, pbuf, ptr2d) + !else + ! call rad_cnst_get_aer_mmr(0, mode_idx(i), spec_idx(i), 'a', state, pbuf, ptr2d) + !end if + !aer(:ncol,:,i,lchnk) = ptr2d(:ncol,:) * rho(:ncol,:) + end do + + ! Init top levels of outputs of get_aer_num + total_aer_num = 0._r8 + coated_aer_num = 0._r8 + uncoated_aer_num = 0._r8 + total_interstitial_aer_num = 0._r8 + total_cloudborne_aer_num = 0._r8 + hetraer = 0._r8 + awcam = 0._r8 + awfacm = 0._r8 + dstcoat = 0._r8 + na500 = 0._r8 + tot_na500 = 0._r8 + + + !Get estimate of number of aerosols inside clouds + call calculateNumberConcentration(ncol, aer_cb, rho, CloudnumberConcentration) + call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) + !End estimate of number inside clouds + + ! output aerosols as reference information for heterogeneous freezing + do i = 1, ncol + do k = top_lev, pver + call get_aer_num(numberConcentration(i,k,:), CloudnumberConcentration(i,k,:), rho(i,k), & + !++ MH_2015/04/10 + f_acm(i,k,:), f_so4_condm(i,k,:), cam(i,k,:), volumeCore(i,k,:), volumeCoat(i,k,:), & + !-- MH_2015/04/10 + total_aer_num(i,k,:), coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), & + total_interstitial_aer_num(i,k,:), total_cloudborne_aer_num(i,k,:), & + hetraer(i,k,:), awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), & + na500(i,k), tot_na500(i,k)) + + fn_cloudborne_aer_num(i,k,1) = total_aer_num(i,k,1)*factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc + fn_cloudborne_aer_num(i,k,2) = total_aer_num(i,k,2)*factnum(i,k,MODE_IDX_DST_A2) + fn_cloudborne_aer_num(i,k,3) = total_aer_num(i,k,3)*factnum(i,k,MODE_IDX_DST_A3) + end do + end do + + call outfld('bc_num', total_aer_num(:,:,1), pcols, lchnk) + call outfld('dst1_num', total_aer_num(:,:,2), pcols, lchnk) + call outfld('dst3_num', total_aer_num(:,:,3), pcols, lchnk) + + call outfld('bcc_num', coated_aer_num(:,:,1), pcols, lchnk) + call outfld('dst1c_num', coated_aer_num(:,:,2), pcols, lchnk) + call outfld('dst3c_num', coated_aer_num(:,:,3), pcols, lchnk) + + call outfld('bcuc_num', uncoated_aer_num(:,:,1), pcols, lchnk) + call outfld('dst1uc_num', uncoated_aer_num(:,:,2), pcols, lchnk) + call outfld('dst3uc_num', uncoated_aer_num(:,:,3), pcols, lchnk) + + call outfld('bc_a1_num', total_interstitial_aer_num(:,:,1), pcols, lchnk) + call outfld('dst_a1_num', total_interstitial_aer_num(:,:,2), pcols, lchnk) + call outfld('dst_a3_num', total_interstitial_aer_num(:,:,3), pcols, lchnk) + + call outfld('bc_c1_num', total_cloudborne_aer_num(:,:,1), pcols, lchnk) + call outfld('dst_c1_num', total_cloudborne_aer_num(:,:,2), pcols, lchnk) + call outfld('dst_c3_num', total_cloudborne_aer_num(:,:,3), pcols, lchnk) + + call outfld('fn_bc_c1_num', fn_cloudborne_aer_num(:,:,1), pcols, lchnk) + call outfld('fn_dst_c1_num', fn_cloudborne_aer_num(:,:,2), pcols, lchnk) + call outfld('fn_dst_c3_num', fn_cloudborne_aer_num(:,:,3), pcols, lchnk) + + call outfld('na500', na500, pcols, lchnk) + call outfld('totna500', tot_na500, pcols, lchnk) + + ! frzimm, frzcnt, frzdep are the outputs of this parameterization used by the microphysics + call pbuf_get_field(pbuf, frzimm_idx, frzimm) + call pbuf_get_field(pbuf, frzcnt_idx, frzcnt) + call pbuf_get_field(pbuf, frzdep_idx, frzdep) + + frzimm(:ncol,:) = 0._r8 + frzcnt(:ncol,:) = 0._r8 + frzdep(:ncol,:) = 0._r8 + + frzbcimm(:ncol,:) = 0._r8 + frzduimm(:ncol,:) = 0._r8 + frzbccnt(:ncol,:) = 0._r8 + frzducnt(:ncol,:) = 0._r8 + frzbcdep(:ncol,:) = 0._r8 + frzdudep(:ncol,:) = 0._r8 + + freqimm(:ncol,:) = 0._r8 + freqcnt(:ncol,:) = 0._r8 + freqdep(:ncol,:) = 0._r8 + freqmix(:ncol,:) = 0._r8 + + numice10s(:ncol,:) = 0._r8 + numice10s_imm_dst(:ncol,:) = 0._r8 + numice10s_imm_bc(:ncol,:) = 0._r8 + + nnuccc_bc(:,:) = 0._r8 + nnucct_bc(:,:) = 0._r8 + nnudep_bc(:,:) = 0._r8 + + nnuccc_dst(:,:) = 0._r8 + nnucct_dst(:,:) = 0._r8 + nnudep_dst(:,:) = 0._r8 + + niimm_bc(:,:) = 0._r8 + nicnt_bc(:,:) = 0._r8 + nidep_bc(:,:) = 0._r8 + + niimm_dst(:,:) = 0._r8 + nicnt_dst(:,:) = 0._r8 + nidep_dst(:,:) = 0._r8 + + do i = 1, ncol + do k = top_lev, pver + + if (t(i,k) > 235.15_r8 .and. t(i,k) < 269.15_r8) then + qcic = min(qc(i,k)/lcldm(i,k), 5.e-3_r8) + ncic = max(nc(i,k)/lcldm(i,k), 0._r8) + + con1 = 1._r8/(1.333_r8*pi)**0.333_r8 + r3lx = con1*(rho(i,k)*qcic/(rhoh2o*max(ncic*rho(i,k), 1.0e6_r8)))**0.333_r8 ! in m + r3lx = max(4.e-6_r8, r3lx) + supersatice = svp_water(t(i,k))/svp_ice(t(i,k)) + fn(1) = factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc accumulation mode + fn(2) = factnum(i,k,MODE_IDX_DST_A2) ! dust_a1 accumulation mode + fn(3) = factnum(i,k,MODE_IDX_DST_A3) ! dust_a3 coarse mode + + call hetfrz_classnuc_calc( & + deltatin, t(i,k), pmid(i,k), supersatice, & + fn, r3lx, ncic*rho(i,k)*1.0e-6_r8, frzbcimm(i,k), frzduimm(i,k), & + frzbccnt(i,k), frzducnt(i,k), frzbcdep(i,k), frzdudep(i,k), hetraer(i,k,:), & + awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), total_aer_num(i,k,:), & + coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), total_interstitial_aer_num(i,k,:), & + total_cloudborne_aer_num(i,k,:), errstring) + + call handle_errmsg(errstring, subname="hetfrz_classnuc_calc") + + frzimm(i,k) = frzbcimm(i,k) + frzduimm(i,k) + frzcnt(i,k) = frzbccnt(i,k) + frzducnt(i,k) + frzdep(i,k) = frzbcdep(i,k) + frzdudep(i,k) + + if (frzimm(i,k) > 0._r8) freqimm(i,k) = 1._r8 + if (frzcnt(i,k) > 0._r8) freqcnt(i,k) = 1._r8 + if (frzdep(i,k) > 0._r8) freqdep(i,k) = 1._r8 + if ((frzimm(i,k) + frzcnt(i,k) + frzdep(i,k)) > 0._r8) freqmix(i,k) = 1._r8 + else + frzimm(i,k) = 0._r8 + frzcnt(i,k) = 0._r8 + frzdep(i,k) = 0._r8 + end if + + nnuccc_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*ast(i,k) + nnucct_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*ast(i,k) + nnudep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*ast(i,k) + + nnuccc_dst(i,k) = frzduimm(i,k)*1.0e6_r8*ast(i,k) + nnucct_dst(i,k) = frzducnt(i,k)*1.0e6_r8*ast(i,k) + nnudep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*ast(i,k) + + niimm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin + nicnt_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*deltatin + nidep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*deltatin + + niimm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin + nicnt_dst(i,k) = frzducnt(i,k)*1.0e6_r8*deltatin + nidep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*deltatin + + numice10s(i,k) = (frzimm(i,k)+frzcnt(i,k)+frzdep(i,k))*1.0e6_r8*deltatin*(10._r8/deltatin) + numice10s_imm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) + numice10s_imm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) + end do + end do + + call outfld('FREQIMM', freqimm, pcols, lchnk) + call outfld('FREQCNT', freqcnt, pcols, lchnk) + call outfld('FREQDEP', freqdep, pcols, lchnk) + call outfld('FREQMIX', freqmix, pcols, lchnk) + + call outfld('DSTFREZIMM', nnuccc_dst, pcols, lchnk) + call outfld('DSTFREZCNT', nnucct_dst, pcols, lchnk) + call outfld('DSTFREZDEP', nnudep_dst, pcols, lchnk) + + call outfld('BCFREZIMM', nnuccc_bc, pcols, lchnk) + call outfld('BCFREZCNT', nnucct_bc, pcols, lchnk) + call outfld('BCFREZDEP', nnudep_bc, pcols, lchnk) + + call outfld('NIMIX_IMM', niimm_bc+niimm_dst, pcols, lchnk) + call outfld('NIMIX_CNT', nicnt_bc+nicnt_dst, pcols, lchnk) + call outfld('NIMIX_DEP', nidep_bc+nidep_dst, pcols, lchnk) + + call outfld('DSTNICNT', nicnt_dst, pcols, lchnk) + call outfld('DSTNIDEP', nidep_dst, pcols, lchnk) + call outfld('DSTNIIMM', niimm_dst, pcols, lchnk) + + call outfld('BCNICNT', nicnt_bc, pcols, lchnk) + call outfld('BCNIDEP', nidep_bc, pcols, lchnk) + call outfld('BCNIIMM', niimm_bc, pcols, lchnk) + + call outfld('NUMICE10s', numice10s, pcols, lchnk) + call outfld('NUMIMM10sDST', numice10s_imm_dst, pcols, lchnk) + call outfld('NUMIMM10sBC', numice10s_imm_bc, pcols, lchnk) + + end associate end subroutine hetfrz_classnuc_oslo_calc @@ -682,264 +682,246 @@ end subroutine hetfrz_classnuc_oslo_calc subroutine hetfrz_classnuc_oslo_save_cbaero(state, pbuf) - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only: getTracerIndex, getNumberOfTracersInMode - use modal_aero_data, only: qqcw_get_field + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only: getTracerIndex, getNumberOfTracersInMode + use modal_aero_data, only: qqcw_get_field - ! Save the required cloud borne aerosol constituents. - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) + ! Save the required cloud borne aerosol constituents. + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) - ! local variables - integer :: i, lchnk, kk, ncol, m, n - real(r8), pointer :: ptr2d(:,:) - type qqcw_type + ! local variables + integer :: i, lchnk, kk, ncol, m, n + real(r8), pointer :: ptr2d(:,:) + type qqcw_type real(r8), pointer :: fldcw(:,:) - end type qqcw_type - type(qqcw_type) :: qqcw(pcnst) - !------------------------------------------------------------------------------- + end type qqcw_type + type(qqcw_type) :: qqcw(pcnst) + !------------------------------------------------------------------------------- - lchnk = state%lchnk - ncol = state%ncol + lchnk = state%lchnk + ncol = state%ncol - ! loop over the cloud borne constituents required by this module and save - ! a local copy + ! loop over the cloud borne constituents required by this module and save + ! a local copy - aer_cb(1:ncol,1:pver,:,lchnk) = 0.0_r8 - do m=1,nmodes_oslo - do n=1,getNumberOfTracersInMode(m) + aer_cb(1:ncol,1:pver,:,lchnk) = 0.0_r8 + do m=1,nmodes_oslo + do n=1,getNumberOfTracersInMode(m) kk=getTracerIndex(m,n,.false.)! This gives the tracer index used in the q-array qqcw(kk)%fldcw => qqcw_get_field(pbuf,kk,lchnk,.TRUE.) if(associated(qqcw(kk)%fldcw))then - aer_cb(:,:,kk,lchnk) = qqcw(kk)%fldcw + aer_cb(:,:,kk,lchnk) = qqcw(kk)%fldcw end if - end do - end do + end do + end do end subroutine hetfrz_classnuc_oslo_save_cbaero !==================================================================================================== subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input - f_acm, f_condm, & - cam, volumeCore, volumeCoat, & - total_aer_num, & ! output - coated_aer_num, & - uncoated_aer_num, & - total_interstial_aer_num, & - total_cloudborne_aer_num, & - hetraer, awcam, awfacm, dstcoat, & -!++ wy4.0 - na500, tot_na500) -!-- wy4.0 - - use spmd_utils, only: iam - use shr_kind_mod, only: r8 => shr_kind_r8 -! use ppgrid, only : pcols, pver - use constituents, only: pcnst - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only:MODE_IDX_DST_A2, MODE_IDX_DST_A3, & - l_dst_a2, l_dst_a3, l_bc_ai, & - MODE_IDX_OMBC_INTMIX_COAT_AIT, l_bc_ac, & - lifeCycleNumberMedianRadius, & - lifeCycleSigma + f_acm, f_condm, & + cam, volumeCore, volumeCoat, & + total_aer_num, & ! output + coated_aer_num, & + uncoated_aer_num, & + total_interstial_aer_num, & + total_cloudborne_aer_num, & + hetraer, awcam, awfacm, dstcoat, & + !++ wy4.0 + na500, tot_na500) + !-- wy4.0 + + use spmd_utils, only: iam + use shr_kind_mod, only: r8 => shr_kind_r8 + ! use ppgrid, only : pcols, pver + use constituents, only: pcnst + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only:MODE_IDX_DST_A2, MODE_IDX_DST_A3, & + l_dst_a2, l_dst_a3, l_bc_ai, & + MODE_IDX_OMBC_INTMIX_COAT_AIT, l_bc_ac, & + lifeCycleNumberMedianRadius, & + lifeCycleSigma + + + implicit none + + ! input + real(r8), intent(in) :: qaerpt(0:nmodes_oslo) ! aerosol number and mass mixing ratios(instertitial) + real(r8), intent(in) :: qaercwpt(0:nmodes_oslo) ! cloud borne aerosol number and mass mixing ratios + real(r8), intent(in) :: rhoair ! air density (kg/m3) + real(r8), intent(in) :: f_acm(nmodes_oslo) + real(r8), intent(in) :: f_condm(nmodes_oslo) + real(r8), intent(in) :: cam(nmodes_oslo) + real(r8), intent(in) :: volumeCoat(nmodes_oslo) + real(r8), intent(in) :: volumeCore(nmodes_oslo) + real(r8) :: sigmag_amode(3) + + + ! output + real(r8), intent(out) :: total_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: total_interstial_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: total_cloudborne_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: uncoated_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: hetraer(3) ! BC and Dust mass mean radius [m] + real(r8), intent(out) :: awcam(3) ! modal added mass [mug m-3] + real(r8), intent(out) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) + real(r8), intent(out) :: dstcoat(3) ! coated fraction + real(r8), intent(out) :: na500 ! #/cm^3 interstitial aerosol number with D>500 nm (#/cm^3) + real(r8), intent(out) :: tot_na500 ! #/cm^3 total aerosol number with D>500 nm (#/cm^3) + !local variables + !------------coated variables-------------------- + real(r8), parameter :: n_so4_monolayers_dust = 1.0_r8 ! number of so4(+nh4) monolayers needed to coat a dust particle + real(r8), parameter :: dr_so4_monolayers_dust = n_so4_monolayers_dust * 4.76e-10 + real(r8) :: tmp1, tmp2 + + real(r8) :: bc_num ! bc number in accumulation mode + real(r8) :: dst1_num, dst3_num ! dust number in accumulation and corase mode + real(r8) :: dst1_num_imm, dst3_num_imm, bc_num_imm + real(r8) :: fac_volsfc_bc, fac_volsfc_dust_a1, fac_volsfc_dust_a3 + + real(r8) :: r_bc ! model radii of BC modes [m] + real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] + + integer :: i + + integer :: num_bc_idx, num_dst1_idx, num_dst3_idx ! mode indices + + num_bc_idx = MODE_IDX_OMBC_INTMIX_COAT_AIT + num_dst1_idx = MODE_IDX_DST_A2 + num_dst3_idx = MODE_IDX_DST_A3 + + + !***************************************************************************** + ! calculate intersitial aerosol + !***************************************************************************** + + dst1_num = qaerpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 + dst3_num = qaerpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 + bc_num = qaerpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 + + + !***************************************************************************** + ! calculate cloud borne aerosol + !***************************************************************************** + + dst1_num_imm = qaercwpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 + dst3_num_imm = qaercwpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 + bc_num_imm = qaercwpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 + + ! calculate mass mean radius + r_dust_a1 = lifeCycleNumberMedianRadius(num_dst1_idx) + r_dust_a3 = lifeCycleNumberMedianRadius(num_dst3_idx) + r_bc = lifeCycleNumberMedianRadius(num_bc_idx) + + hetraer(1) = r_bc + hetraer(2) = r_dust_a1 + hetraer(3) = r_dust_a3 + + + !***************************************************************************** + ! calculate coated fraction + !***************************************************************************** + + ! volumeCore and volumeCoat from subroutine calculateHygroscopicity in paramix_progncdnc.f90 + + sigmag_amode(1) = lifeCycleSigma(num_bc_idx) + sigmag_amode(2) = lifeCycleSigma(num_dst1_idx) + sigmag_amode(3) = lifeCycleSigma(num_dst3_idx) + + fac_volsfc_bc = exp(2.5*(log(sigmag_amode(1))**2)) + fac_volsfc_dust_a1 = exp(2.5*(log(sigmag_amode(2))**2)) + fac_volsfc_dust_a3 = exp(2.5*(log(sigmag_amode(3))**2)) + + tmp1 = volumeCoat(num_bc_idx)*(r_bc*2._r8)*fac_volsfc_bc + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_bc_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 + dstcoat(1) = tmp1/tmp2 + + tmp1 = volumeCoat(num_dst1_idx)*(r_dust_a1*2._r8)*fac_volsfc_dust_a1 + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst1_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 + dstcoat(2) = tmp1/tmp2 + + tmp1 = volumeCoat(num_dst3_idx)*(r_dust_a3*2._r8)*fac_volsfc_dust_a3 + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst3_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 + dstcoat(3) = tmp1/tmp2 + + if (dstcoat(1) > 1._r8) dstcoat(1) = 1._r8 + if (dstcoat(1) < 0.001_r8) dstcoat(1) = 0.001_r8 + if (dstcoat(2) > 1._r8) dstcoat(2) = 1._r8 + if (dstcoat(2) < 0.001_r8) dstcoat(2) = 0.001_r8 + if (dstcoat(3) > 1._r8) dstcoat(3) = 1._r8 + if (dstcoat(3) < 0.001_r8) dstcoat(3) = 0.001_r8 + + !***************************************************************************** + ! prepare some variables for water activity + !***************************************************************************** + ! cam ([kg/m3] added mass distributed to modes) from paramix_progncdnc.f90 + + ! accumulation mode for dust_a1 + if (qaerpt(num_dst1_idx) > 0._r8) then + awcam(2) = cam(num_dst1_idx)*1.e9_r8 ! kg/m3 -> ug/m3 + else + awcam(2) = 0._r8 + end if + if (awcam(2) >0._r8) then + awfacm(2) = f_acm(num_dst1_idx) + else + awfacm(2) = 0._r8 + end if + ! accumulation mode for dust_a3 + if (qaerpt(num_dst3_idx) > 0._r8) then + awcam(3) = cam(num_dst3_idx)*1.e9_r8 ! kg/m3 -> ug/m3 + else + awcam(3) = 0._r8 + end if + if (awcam(3) >0._r8) then + awfacm(3) = f_acm(num_dst3_idx) + else + awfacm(3) = 0._r8 + end if - implicit none - ! input - real(r8), intent(in) :: qaerpt(0:nmodes_oslo) ! aerosol number and mass mixing ratios(instertitial) - real(r8), intent(in) :: qaercwpt(0:nmodes_oslo) ! cloud borne aerosol number and mass mixing ratios - real(r8), intent(in) :: rhoair ! air density (kg/m3) - real(r8), intent(in) :: f_acm(nmodes_oslo) - real(r8), intent(in) :: f_condm(nmodes_oslo) - real(r8), intent(in) :: cam(nmodes_oslo) - real(r8), intent(in) :: volumeCoat(nmodes_oslo) - real(r8), intent(in) :: volumeCore(nmodes_oslo) - real(r8) :: sigmag_amode(3) - - - ! output - real(r8), intent(out) :: total_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: total_interstial_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: total_cloudborne_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: uncoated_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: hetraer(3) ! BC and Dust mass mean radius [m] - real(r8), intent(out) :: awcam(3) ! modal added mass [mug m-3] - real(r8), intent(out) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) - real(r8), intent(out) :: dstcoat(3) ! coated fraction - real(r8), intent(out) :: na500 ! #/cm^3 interstitial aerosol number with D>500 nm (#/cm^3) - real(r8), intent(out) :: tot_na500 ! #/cm^3 total aerosol number with D>500 nm (#/cm^3) - !local variables - !------------coated variables-------------------- - real(r8), parameter :: n_so4_monolayers_dust = 1.0_r8 ! number of so4(+nh4) monolayers needed to coat a dust particle - real(r8), parameter :: dr_so4_monolayers_dust = n_so4_monolayers_dust * 4.76e-10 - real(r8) :: tmp1, tmp2 - - real(r8) :: bc_num ! bc number in accumulation mode - real(r8) :: dst1_num, dst3_num ! dust number in accumulation and corase mode - real(r8) :: dst1_num_imm, dst3_num_imm, bc_num_imm - real(r8) :: fac_volsfc_bc, fac_volsfc_dust_a1, fac_volsfc_dust_a3 - - real(r8) :: r_bc ! model radii of BC modes [m] - real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] - - integer :: i - - integer :: num_bc_idx, num_dst1_idx, num_dst3_idx ! mode indices - - num_bc_idx = MODE_IDX_OMBC_INTMIX_COAT_AIT - num_dst1_idx = MODE_IDX_DST_A2 - num_dst3_idx = MODE_IDX_DST_A3 - - -!***************************************************************************** -! calculate intersitial aerosol -!***************************************************************************** - - dst1_num = qaerpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 - dst3_num = qaerpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 - bc_num = qaerpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - - -!***************************************************************************** -! calculate cloud borne aerosol -!***************************************************************************** - - dst1_num_imm = qaercwpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 - dst3_num_imm = qaercwpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 - bc_num_imm = qaercwpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - -! calculate mass mean radius - r_dust_a1 = lifeCycleNumberMedianRadius(num_dst1_idx) - r_dust_a3 = lifeCycleNumberMedianRadius(num_dst3_idx) - r_bc = lifeCycleNumberMedianRadius(num_bc_idx) - - hetraer(1) = r_bc - hetraer(2) = r_dust_a1 - hetraer(3) = r_dust_a3 - - -!***************************************************************************** -! calculate coated fraction -!***************************************************************************** - -! volumeCore and volumeCoat from subroutine calculateHygroscopicity in paramix_progncdnc.f90 - - sigmag_amode(1) = lifeCycleSigma(num_bc_idx) - sigmag_amode(2) = lifeCycleSigma(num_dst1_idx) - sigmag_amode(3) = lifeCycleSigma(num_dst3_idx) - - fac_volsfc_bc = exp(2.5*(log(sigmag_amode(1))**2)) - fac_volsfc_dust_a1 = exp(2.5*(log(sigmag_amode(2))**2)) - fac_volsfc_dust_a3 = exp(2.5*(log(sigmag_amode(3))**2)) - - tmp1 = volumeCoat(num_bc_idx)*(r_bc*2._r8)*fac_volsfc_bc - tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_bc_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 - dstcoat(1) = tmp1/tmp2 - - tmp1 = volumeCoat(num_dst1_idx)*(r_dust_a1*2._r8)*fac_volsfc_dust_a1 - tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst1_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 - dstcoat(2) = tmp1/tmp2 - - tmp1 = volumeCoat(num_dst3_idx)*(r_dust_a3*2._r8)*fac_volsfc_dust_a3 - tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst3_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 - dstcoat(3) = tmp1/tmp2 - - if (dstcoat(1) > 1._r8) dstcoat(1) = 1._r8 - if (dstcoat(1) < 0.001_r8) dstcoat(1) = 0.001_r8 - if (dstcoat(2) > 1._r8) dstcoat(2) = 1._r8 - if (dstcoat(2) < 0.001_r8) dstcoat(2) = 0.001_r8 - if (dstcoat(3) > 1._r8) dstcoat(3) = 1._r8 - if (dstcoat(3) < 0.001_r8) dstcoat(3) = 0.001_r8 - -!***************************************************************************** -! prepare some variables for water activity -!***************************************************************************** -! cam ([kg/m3] added mass distributed to modes) from paramix_progncdnc.f90 - - ! accumulation mode for dust_a1 - if (qaerpt(num_dst1_idx) > 0._r8) then - awcam(2) = cam(num_dst1_idx)*1.e9_r8 ! kg/m3 -> ug/m3 - else - awcam(2) = 0._r8 - end if - if (awcam(2) >0._r8) then - awfacm(2) = f_acm(num_dst1_idx) - else - awfacm(2) = 0._r8 - end if - - ! accumulation mode for dust_a3 - if (qaerpt(num_dst3_idx) > 0._r8) then - awcam(3) = cam(num_dst3_idx)*1.e9_r8 ! kg/m3 -> ug/m3 - else - awcam(3) = 0._r8 - end if - if (awcam(3) >0._r8) then - awfacm(3) = f_acm(num_dst3_idx) - else - awfacm(3) = 0._r8 - end if - - - ! accumulation mode for bc - if (qaerpt(num_bc_idx) > 0._r8) then - awcam(1) = cam(num_bc_idx)*1.e9_r8 ! kg/m3 -> ug/m3 - else - awcam(1) = 0._r8 - end if - if (awcam(1) >0._r8) then - awfacm(1) = f_acm(num_bc_idx) - else - awfacm(1) = 0._r8 - end if + ! accumulation mode for bc + if (qaerpt(num_bc_idx) > 0._r8) then + awcam(1) = cam(num_bc_idx)*1.e9_r8 ! kg/m3 -> ug/m3 + else + awcam(1) = 0._r8 + end if + if (awcam(1) >0._r8) then + awfacm(1) = f_acm(num_bc_idx) + else + awfacm(1) = 0._r8 + end if -!***************************************************************************** -! prepare output -!***************************************************************************** + !***************************************************************************** + ! prepare output + !***************************************************************************** - total_interstial_aer_num(1) = bc_num - total_interstial_aer_num(2) = dst1_num - total_interstial_aer_num(3) = dst3_num + total_interstial_aer_num(1) = bc_num + total_interstial_aer_num(2) = dst1_num + total_interstial_aer_num(3) = dst3_num - total_cloudborne_aer_num(1) = bc_num_imm - total_cloudborne_aer_num(2) = dst1_num_imm - total_cloudborne_aer_num(3) = dst3_num_imm - - do i = 1, 3 - total_aer_num(i) = total_interstial_aer_num(i)+total_cloudborne_aer_num(i) - coated_aer_num(i) = total_interstial_aer_num(i)*dstcoat(i) - uncoated_aer_num(i) = total_interstial_aer_num(i)*(1._r8-dstcoat(i)) - end do + total_cloudborne_aer_num(1) = bc_num_imm + total_cloudborne_aer_num(2) = dst1_num_imm + total_cloudborne_aer_num(3) = dst3_num_imm + do i = 1, 3 + total_aer_num(i) = total_interstial_aer_num(i)+total_cloudborne_aer_num(i) + coated_aer_num(i) = total_interstial_aer_num(i)*dstcoat(i) + uncoated_aer_num(i) = total_interstial_aer_num(i)*(1._r8-dstcoat(i)) + end do - tot_na500 = total_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 -!#ifdef MODAL_AERO -!#if (defined MODAL_AERO_3MODE) - +total_aer_num(2)*0.488_r8 & ! scaled for D>0.5-1 um from 0.1-1 um -!#elif (defined MODAL_AERO_7MODE) -! +total_aer_num(2)*0.566_r8 & ! scaled for D>0.5-2 um from 0.1-2 um -!#endif - +total_aer_num(3) -!#endif - - na500 = total_interstial_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 -!#ifdef MODAL_AERO -!#if (defined MODAL_AERO_3MODE) - +total_interstial_aer_num(2)*0.488_r8 & ! scaled for D>0.5-1 um from 0.1-1 um -!#elif (defined MODAL_AERO_7MODE) -! +total_interstial_aer_num(2)*0.566_r8 & ! scaled for D>0.5-2 um from 0.1-2 um -!#endif - +total_interstial_aer_num(3) -!#endif - -!-- wy4.0 - -end subroutine get_aer_num -!==================================================================================================== + tot_na500 = total_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 + +total_aer_num(3) + + na500 = total_interstial_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 + +total_interstial_aer_num(3) + +end subroutine get_aer_num end module hetfrz_classnuc_oslo diff --git a/src/chemistry/oslo_aero/initlogn.F90 b/src/chemistry/oslo_aero/initlogn.F90 index 0fff53e2fd..3f328050d8 100644 --- a/src/chemistry/oslo_aero/initlogn.F90 +++ b/src/chemistry/oslo_aero/initlogn.F90 @@ -1,284 +1,238 @@ subroutine initlogn -! Created for CAM3 by Trude Storelvmo, Fall 2007. -! This subroutine reads the tabulated parameters for "best lognormal fits" -! of the aerosol size distribution wrt CCN activation as calculated by Alf Kirkevaag. -! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013 -! Updated for reading inout files with extra header info - Alf Kirkevaag, May 2015, -! and for new tables including SOA September 2015. -! Modified for optimized added masses and mass fractions for concentrations from -! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - - use shr_kind_mod, only: r8 => shr_kind_r8 - use aerosoldef - use opttab, only: cat,fac,fbc,faq,cate - use const - use cam_logfile, only: iulog - use oslo_control, only: oslo_getopts,dir_string_length - - implicit none - - integer kcomp, ictot, ifac, ifbc, ifaq, irk, istdv - integer ic, ifil, lin - character(len=dir_string_length) :: aerotab_table_dir - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - - write(iulog,*)'b4 nlog open ok' - - !Where are the tables stored?? - call oslo_getopts(aerotab_table_dir_out=aerotab_table_dir) - - open(20,file=trim(aerotab_table_dir)//'/logntilp1.out' & ! SO4&SOA(n/Ait) - ,form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/logntilp2.out' & ! BC(n/Ait) - ,form='formatted',status='old') - open(22,file=trim(aerotab_table_dir)//'/logntilp3.out' & ! OC(n/Ait) - ,form='formatted',status='old') - open(23,file=trim(aerotab_table_dir)//'/logntilp4.out' & ! BC&OC(n/Ait) - ,form='formatted',status='old') - open(24,file=trim(aerotab_table_dir)//'/logntilp5.out' & ! SO4(Ait75) - ,form='formatted',status='old') - open(25,file=trim(aerotab_table_dir)//'/logntilp6.out' & ! MINACC - ,form='formatted',status='old') - open(26,file=trim(aerotab_table_dir)//'/logntilp7.out' & ! MINCOA - ,form='formatted',status='old') - open(27,file=trim(aerotab_table_dir)//'/logntilp8.out' & ! SEASF - ,form='formatted',status='old') - open(28,file=trim(aerotab_table_dir)//'/logntilp9.out' & ! SEASACC - ,form='formatted',status='old') - open(29,file=trim(aerotab_table_dir)//'/logntilp10.out' & ! SEASCOA - ,form='formatted',status='old') - - write(iulog,*)'nlog open ok' - -! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 20,29 - call checkTableHeader (ifil) - enddo - -! ************************************************************************ -! Mode 1 (SO4&SOA + condesate from H2SO4 and SOA) -! Modes 2 to 3 (BC/OC + condesate from H2SO4 and SOA) -! -! These two are treated the same way since there is no dependence on -! fombg (SOA fraction in the background) for mode 1. -! ************************************************************************ - -! do ifil = 1,3 - do ifil = 1,2 - do lin = 1,96 ! 16*6 entries - read(19+ifil,993) kcomp, calog1to3(ifil,lin), fraclog1to3 (ifil, lin), & + ! This subroutine reads the tabulated parameters for "best lognormal fits" + ! of the aerosol size distribution wrt CCN activation as calculated by Alf Kirkevaag. + + ! Created for CAM3 by Trude Storelvmo, Fall 2007. + ! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013 + ! Updated for reading inout files with extra header info - Alf Kirkevaag, May 2015, + ! and for new tables including SOA September 2015. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + + use shr_kind_mod, only: r8 => shr_kind_r8 + use aerosoldef + use opttab, only: cat,fac,fbc,faq,cate + use const + use cam_logfile, only: iulog + use oslo_control, only: oslo_getopts,dir_string_length + + implicit none + + integer kcomp, ictot, ifac, ifbc, ifaq, irk, istdv + integer ic, ifil, lin + character(len=dir_string_length) :: aerotab_table_dir + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + + write(iulog,*)'b4 nlog open ok' + + ! Where are the tables stored?? + call oslo_getopts(aerotab_table_dir_out=aerotab_table_dir) + + open(20,file=trim(aerotab_table_dir)//'/logntilp1.out' ,form='formatted',status='old') ! SO4&SOA(n/Ait) + open(21,file=trim(aerotab_table_dir)//'/logntilp2.out' ,form='formatted',status='old') ! BC(n/Ait) + open(22,file=trim(aerotab_table_dir)//'/logntilp3.out' ,form='formatted',status='old') ! OC(n/Ait) + open(23,file=trim(aerotab_table_dir)//'/logntilp4.out' ,form='formatted',status='old') ! BC&OC(n/Ait) + open(24,file=trim(aerotab_table_dir)//'/logntilp5.out' ,form='formatted',status='old') ! SO4(Ait75) + open(25,file=trim(aerotab_table_dir)//'/logntilp6.out' ,form='formatted',status='old') ! MINACC + open(26,file=trim(aerotab_table_dir)//'/logntilp7.out' ,form='formatted',status='old') ! MINCOA + open(27,file=trim(aerotab_table_dir)//'/logntilp8.out' ,form='formatted',status='old') ! SEASF + open(28,file=trim(aerotab_table_dir)//'/logntilp9.out' ,form='formatted',status='old') ! SEASACC + open(29,file=trim(aerotab_table_dir)//'/logntilp10.out',form='formatted',status='old') ! SEASCOA + + write(iulog,*)'nlog open ok' + + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 20,29 + call checkTableHeader (ifil) + enddo + + ! ************************************************************************ + ! Mode 1 (SO4&SOA + condesate from H2SO4 and SOA) + ! Modes 2 to 3 (BC/OC + condesate from H2SO4 and SOA) + ! + ! These two are treated the same way since there is no dependence on + ! fombg (SOA fraction in the background) for mode 1. + ! ************************************************************************ + + do ifil = 1,2 + do lin = 1,96 ! 16*6 entries + read(19+ifil,993) kcomp, calog1to3(ifil,lin), fraclog1to3 (ifil, lin), & rk1to3(ifil,lin), stdv1to3(ifil,lin) do ic=1,16 -! if(calog1to3(ifil,lin).eq.cate(kcomp,ic)) then - if(abs((calog1to3(ifil,lin)-cate(kcomp,ic))/cate(kcomp,ic)) 0 inv_oh = get_inv_ndx('OH') > 0 inv_no3 = get_inv_ndx('NO3') > 0 @@ -95,7 +91,6 @@ subroutine gas_phase_chemdr_inti() if (inv_ho2) then id_ho2 = get_inv_ndx('HO2') endif -#endif ndx_h2so4 = get_spc_ndx('H2SO4') ! @@ -334,9 +329,7 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & use mo_chm_diags, only : chm_diags, het_diags use perf_mod, only : t_startf, t_stopf use gas_wetdep_opts, only : gas_wetdep_method -#if (defined OSLO_AERO) use oxi_diurnal_var, only : set_diurnal_invariants -#endif use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx use infnan, only : nan, assignment(=) use rate_diags, only : rate_diags_calc @@ -665,7 +658,6 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & call setinv( invariants, tfld, h2ovmr, vmr, pmid, ncol, lchnk, pbuf ) !----------------------------------------------------------------------- -#if defined (OSLO_AERO) ! ... Set the "day/night cycle for prescribed oxidants" !----------------------------------------------------------------------- @@ -684,7 +676,6 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & call outfld('NO3_aft', invariants(:,:,id_no3), ncol, lchnk) !--IH -#endif ! ... stratosphere aerosol surface area !----------------------------------------------------------------------- if (sad_pbf_ndx>0) then diff --git a/src/chemistry/oslo_aero/mo_neu_wetdep.F90 b/src/chemistry/oslo_aero/mo_neu_wetdep.F90 index eae583761a..5762cb0e71 100644 --- a/src/chemistry/oslo_aero/mo_neu_wetdep.F90 +++ b/src/chemistry/oslo_aero/mo_neu_wetdep.F90 @@ -14,19 +14,15 @@ module mo_neu_wetdep use cam_abortutils, only : endrun use seq_drydep_mod, only : n_species_table, species_name_table, dheff use gas_wetdep_opts, only : gas_wetdep_method, gas_wetdep_list, gas_wetdep_cnt -#ifdef OSLO_AERO use phys_control, only: phys_getopts use mo_constants, only: rgrav use phys_control, only: phys_getopts -#endif ! implicit none ! private public :: neu_wetdep_init public :: neu_wetdep_tend -! - save ! integer, allocatable, dimension(:) :: mapping_to_heff,mapping_to_mmr real(r8),allocatable, dimension(:) :: mol_weight @@ -282,10 +278,8 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & real(r8) :: pi real(r8) :: lats(pcols) -#ifdef OSLO_AERO real(r8) :: wrk_wd(pcols) logical history_aerosol -#endif call phys_getopts( history_aerosol_out = history_aerosol) ! @@ -486,7 +480,6 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & !This is output normally in mo_chm_diags, but !if neu wetdep, we have to output it here! -#ifdef OSLO_AERO if(history_aerosol)then do m=1,gas_wetdep_cnt wrk_wd(:ncol) = 0.0_r8 @@ -498,7 +491,6 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & call outfld('WD_A_'//trim(gas_wetdep_list(m)),wrk_wd(:ncol),ncol,lchnk) end do end if -#endif ! if ( do_diag ) then call outfld('QT_RAIN_HNO3', qt_rain, ncol, lchnk ) From 9c4123cffeea38db22d114fd9a98411324c9f4b4 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 16 Aug 2023 20:56:24 +0200 Subject: [PATCH 10/71] updated intlog module that contains initlogn as well as new module constants from const.F90 --- src/chemistry/oslo_aero/aero_model.F90 | 93 ++++----- src/chemistry/oslo_aero/const.F90 | 105 +++------- src/chemistry/oslo_aero/initlogn.F90 | 243 ---------------------- src/chemistry/oslo_aero/intlog.F90 | 267 +++++++++++++++++++++++-- 4 files changed, 328 insertions(+), 380 deletions(-) delete mode 100644 src/chemistry/oslo_aero/initlogn.F90 diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 6c91b077e5..a77bbb8736 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -25,8 +25,9 @@ module aero_model use mo_tracname, only: solsym use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub - use koagsub, only: coagtend, clcoag + use koagsub, only: coagtend, clcoag use sox_cldaero_mod, only: sox_cldaero_init + use intlog, only: initlogn !use modal_aero_data,only: cnst_name_cw, lptr_so4_cw_amode !use modal_aero_data,only: ntot_amode, modename_amode, nspec_max @@ -50,24 +51,24 @@ module aero_model public :: aero_model_surfarea ! tropopspheric aerosol wet surface area for chemistry public :: aero_model_strat_surfarea ! stratospheric aerosol wet surface area for chemistry - ! Misc private data + ! Misc private data ! number of modes integer :: nmodes integer :: pblh_idx = 0 integer :: dgnum_idx = 0 integer :: dgnumwet_idx = 0 - integer :: rate1_cw2pr_st_idx = 0 + integer :: rate1_cw2pr_st_idx = 0 integer :: wetdens_ap_idx = 0 integer :: qaerwat_idx = 0 integer :: fracis_idx = 0 integer :: prain_idx = 0 - integer :: rprddp_idx = 0 - integer :: rprdsh_idx = 0 - integer :: nevapr_shcu_idx = 0 - integer :: nevapr_dpcu_idx = 0 + integer :: rprddp_idx = 0 + integer :: rprdsh_idx = 0 + integer :: nevapr_shcu_idx = 0 + integer :: nevapr_dpcu_idx = 0 integer :: sulfeq_idx = -1 @@ -77,7 +78,7 @@ module aero_model real(r8),allocatable :: scavimptblnum(:,:) real(r8),allocatable :: scavimptblvol(:,:) - ! for surf_area_dens + ! for surf_area_dens integer,allocatable :: num_idx(:) integer,allocatable :: index_tot_mass(:,:) integer,allocatable :: index_chm_mass(:,:) @@ -90,7 +91,7 @@ module aero_model real(r8) :: sol_facti_cloud_borne = 1._r8 real(r8) :: sol_factb_interstitial = 0.1_r8 real(r8) :: sol_factic_interstitial = 0.4_r8 - real(r8) :: seasalt_emis_scale + real(r8) :: seasalt_emis_scale integer :: ndrydep = 0 integer,allocatable :: drydep_indices(:) @@ -109,7 +110,7 @@ module aero_model #endif contains - + !============================================================================= ! reads aerosol namelist options !============================================================================= @@ -130,7 +131,7 @@ subroutine aero_model_readnl(nlfile) character(len=16) :: aer_drydep_list(pcnst) = ' ' namelist /aerosol_nl/ aer_wetdep_list, aer_drydep_list, sol_facti_cloud_borne, & - sol_factb_interstitial, sol_factic_interstitial + sol_factb_interstitial, sol_factic_interstitial !----------------------------------------------------------------------------- @@ -185,13 +186,13 @@ subroutine aero_model_init( pbuf2d ) !use modal_aero_data, only: cnst_name_cw !use modal_aero_data, only: modal_aero_data_init !use rad_constituents,only: rad_cnst_get_info - use dust_model, only: dust_init, dust_active + use dust_model, only: dust_init, dust_active use seasalt_model, only: seasalt_init, seasalt_active use drydep_mod, only: inidrydep use wetdep, only: wetdep_init use condtend, only: initializeCondensation - use oslo_ocean_intr, only: oslo_ocean_init + use oslo_ocean_intr, only: oslo_ocean_init use oslo_aerosols_intr, only: oslo_aero_initialize use opttab, only : initopt @@ -205,7 +206,7 @@ subroutine aero_model_init( pbuf2d ) !use modal_aero_gasaerexch, only: modal_aero_gasaerexch_init !use modal_aero_newnuc, only: modal_aero_newnuc_init !use modal_aero_rename, only: modal_aero_rename_init - !use modal_aero_convproc, only: ma_convproc_init + !use modal_aero_convproc, only: ma_convproc_init ! args type(physics_buffer_desc), pointer :: pbuf2d(:,:) @@ -221,7 +222,7 @@ subroutine aero_model_init( pbuf2d ) character(len=6) :: test_name character(len=64) :: errmes - character(len=2) :: unit_basename ! Units 'kg' or '1' + character(len=2) :: unit_basename ! Units 'kg' or '1' integer :: errcode character(len=fieldname_len) :: field_name @@ -258,12 +259,12 @@ subroutine aero_model_init( pbuf2d ) call inidrydep(rair, gravit) dummy = 'RAM1' call addfld (dummy,horiz_only, 'A','frac','RAM1') - if ( history_aerosol ) then + if ( history_aerosol ) then call add_default (dummy, 1, ' ') endif dummy = 'airFV' call addfld (dummy,horiz_only, 'A','frac','FV') - if ( history_aerosol ) then + if ( history_aerosol ) then call add_default (dummy, 1, ' ') endif @@ -280,7 +281,7 @@ subroutine aero_model_init( pbuf2d ) do m = 1,gas_pcnst - unit_basename = 'kg' ! Units 'kg' or '1' + unit_basename = 'kg' ! Units 'kg' or '1' call addfld( 'GS_'//trim(solsym(m)),horiz_only, 'A', unit_basename//'/m2/s ', & trim(solsym(m))//' gas chemistry/wet removal (for gas species)') @@ -293,7 +294,7 @@ subroutine aero_model_init( pbuf2d ) end if end if - if ( history_aerosol ) then + if ( history_aerosol ) then call add_default( 'GS_'//trim(solsym(m)), 1, ' ') call add_default( 'AQ_'//trim(solsym(m)), 1, ' ') if(physicsIndex(m).le.pcnst) then @@ -334,7 +335,7 @@ subroutine aero_model_init( pbuf2d ) call add_default ('AQSO4_O3', 1, ' ') endif - + end subroutine aero_model_init @@ -347,9 +348,9 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, use aerosoldef , only : numberOfProcessModeTracers use commondefinitions, only: oslo_nmodes=>nmodes - ! args + ! args type(physics_state), intent(in) :: state ! Physics state variables - real(r8), intent(in) :: obklen(:) + real(r8), intent(in) :: obklen(:) real(r8), intent(in) :: ustar(:) ! sfc fric vel type(cam_in_t), target, intent(in) :: cam_in ! import state real(r8), intent(in) :: dt ! time step @@ -404,7 +405,7 @@ subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) subroutine aero_model_surfarea( & mmr, radmean, relhum, pmid, temp, strato_sad, sulfate, rho, ltrop, & dlat, het1_ndx, pbuf, ncol, sfc, dm_aer, sad_trop, reff_trop ) - + use commondefinitions, only: nmodes_oslo => nmodes use const , only: numberToSurface use aerosoldef , only: lifeCycleNumberMedianRadius @@ -444,10 +445,10 @@ subroutine aero_model_surfarea( & rho_air(i,k) = pmid(i,k)/(temp(i,k)*287.04_r8) end do end do - ! + ! !Get number concentrations - call calculateNumberConcentration(ncol, mmr, rho_air, numberConcentration) - + call calculateNumberConcentration(ncol, mmr, rho_air, numberConcentration) + !Convert to area using lifecycle-radius sad_mode = 0._r8 sad_trop = 0._r8 @@ -527,19 +528,19 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ real(r8), intent(in) :: relhum(:,:) ! relative humidity real(r8), intent(in) :: airdens(:,:) ! total atms density (molec/cm**3) real(r8), intent(in) :: invariants(:,:,:) - real(r8), intent(inout) :: del_h2so4_gasprod(:,:) ![molec/molec/sec] - real(r8), intent(in) :: zm(:,:) - real(r8), intent(in) :: qh2o(:,:) + real(r8), intent(inout) :: del_h2so4_gasprod(:,:) ![molec/molec/sec] + real(r8), intent(in) :: zm(:,:) + real(r8), intent(in) :: qh2o(:,:) real(r8), intent(in) :: cwat(:,:) ! cloud liquid water content (kg/kg) - real(r8), intent(in) :: cldfr(:,:) + real(r8), intent(in) :: cldfr(:,:) real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) real(r8), intent(in) :: vmr0(:,:,:) ! initial mixing ratios (before gas-phase chem changes) real(r8), intent(inout) :: vmr(:,:,:) ! mixing ratios ( vmr ) type(physics_buffer_desc), pointer :: pbuf(:) - - ! local vars - + + ! local vars + integer :: n, m integer :: i,k,l integer :: nstep @@ -574,7 +575,7 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ real(r8), pointer :: pblh(:) logical :: is_spcam_m2005 - + nstep = get_nstep() @@ -670,15 +671,15 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ name = 'AQ_'//trim(solsym(m)) call outfld( name, wrk(:ncol), ncol, lchnk ) - !In oslo aero also write out the tendencies for the - !cloud borne aerosols... - n = physicsIndex(m) + !In oslo aero also write out the tendencies for the + !cloud borne aerosols... + n = physicsIndex(m) if (n.le.pcnst) then if(getCloudTracerIndexDirect(n) .gt. 0)then name = 'AQ_'//trim(getCloudTracerName(n)) wrk(:ncol)=0.0_r8 do k=1,pver - wrk(:ncol) = wrk(:ncol) + dvmrcwdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + wrk(:ncol) = wrk(:ncol) + dvmrcwdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit end do call outfld( name, wrk(:ncol), ncol, lchnk ) end if @@ -702,7 +703,7 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ mmr_cond_vap_gasprod(:ncol,k,COND_VAP_ORG_SV) = adv_mass(ndx_soa_sv) * del_soa_sv_gasprod(:ncol,k) / mbar(:ncol,k)/delt !cka end do - !This should not happen since there are only + !This should not happen since there are only !production terms for these gases!! do cond_vap_idx=1,N_COND_VAP where(mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx).lt. 0.0_r8) @@ -713,9 +714,9 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ mmr_tend_ncols(:ncol,:,ndx_soa_lv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) mmr_tend_ncols(:ncol,:,ndx_soa_sv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) - !Rest of microphysics have pcols dimension - mmr_tend_pcols(:ncol,:,:) = mmr_tend_ncols(:ncol,:,:) - !Note use of "zm" here. In CAM5.3-implementation "zi" was used.. + !Rest of microphysics have pcols dimension + mmr_tend_pcols(:ncol,:,:) = mmr_tend_ncols(:ncol,:,:) + !Note use of "zm" here. In CAM5.3-implementation "zi" was used.. !zm is passed through the generic interface, and it should not change much !to check if "zm" is below boundary layer height instead of zi call condtend_sub( lchnk, mmr_tend_pcols, mmr_cond_vap_gasprod,tfld, pmid, & @@ -727,7 +728,7 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ ! temporary variable (vmrcw) Coagulation between aerosol and cloud ! droplets moved to after vmrcw is moved into qqcw (in mmr spac) - call coagtend( mmr_tend_pcols, pmid, pdel, tfld, delt_inverse, ncol, lchnk) + call coagtend( mmr_tend_pcols, pmid, pdel, tfld, delt_inverse, ncol, lchnk) !Convert cloud water to mmr again ==> values in buffer call vmr2qqcw( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) @@ -832,7 +833,7 @@ subroutine modal_aero_bcscavcoef_init ! Authors: R. Easter ! !----------------------------------------------------------------------- - + use shr_kind_mod, only: r8 => shr_kind_r8 use modal_aero_data use cam_abortutils, only: endrun @@ -912,7 +913,7 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl ! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & ! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & ! 0.50d+00/ - data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & + data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & 0.54e+00_r8/ save gamma @@ -996,7 +997,7 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl stk_nbr = vlc_grv(i,k) * fv(i) * fv(i) / (gravit*vsc_knm_atm(i,k)) ![frc] SeP97 p.965 interception = 0.0_r8 endif - impaction = (stk_nbr/(alpha(lt)+stk_nbr))**2.0_r8 + impaction = (stk_nbr/(alpha(lt)+stk_nbr))**2.0_r8 if (iwet(lt) > 0) then stickfrac = 1.0_r8 diff --git a/src/chemistry/oslo_aero/const.F90 b/src/chemistry/oslo_aero/const.F90 index 4a6ed3ec8f..c20326140b 100644 --- a/src/chemistry/oslo_aero/const.F90 +++ b/src/chemistry/oslo_aero/const.F90 @@ -1,80 +1,35 @@ module const -!----------------------------------------------------------------------------- -!Module containing subroutines constants, koagsub and parmix and declaration -!of the variables required by them. Updated with one internally mixed and one -!externally mixed OC mode November 2004. -!Updated with extra variables for SOA by Alf Kirkevåg May 2013, and -!with explicit equations for diffusion variables for SOA and H2SO4 in July 2015 -!(moved to condtend.F90). -!----------------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 -! use aerosoldef, only: nmodes - use commondefinitions, only: nmodes - use physconst, only: pi -! -implicit none -! -public -save - - real(r8), parameter:: smallNumber = 1.e-100_r8 - - !Essential size distribution parameters - real(r8), parameter :: rTabMin = 1.e-9_r8 ![m] smallest lookup table size - real(r8), parameter :: rTabMax = 20.e-6_r8 ![m] largest lookup table size - integer, parameter :: nBinsTab = 44 ![nbr] number of tabulated bins - - -!cak: diff, th and mfv for H2SO4 and SOA are now calculated in condtend.F90 - - - !Smallest particle which can receive aquous chemistry mass - real(r8), parameter :: rMinAquousChemistry = 0.05e-6_r8 - real(r8) nk(0:nmodes,nbinsTab) !dN/dlogr for modes - real(r8) normnk(0:nmodes,nbinsTab) !dN for modes (sums to one over size range) - - real(r8) rBinEdge(nBinsTab+1) - real(r8) rBinMidpoint(nBinsTab) - -!soa -! real(r8) :: rrr1to3 (3,16) !TS: Modal radius array, mode 1 - 3 -! real(r8) :: sss1to3 (3,16) !TS: Standard deviation array, Mode 1 -3 -! real(r8) :: calog1to3(3,16) !TS: Array for reading catot from file -! real(r8) :: rk1to3 (3,16) !TS: Array for reading modal radius from file -! real(r8) :: stdv1to3 (3,16) !TS: Array for reading std. dev. from file -!soa - real(r8) :: rrr1to3 (3,16,6) !TS: Modal radius array, mode 1 - 3 - real(r8) :: sss1to3 (3,16,6) !TS: Standard deviation array, Mode 1 -3 - real(r8) :: calog1to3(3,96) !TS: Array for reading catot from file - real(r8) :: rk1to3 (3,96) !TS: Array for reading modal radius from file - real(r8) :: stdv1to3 (3,96) !TS: Array for reading std. dev. from file - real(r8) :: fraclog1to3 (3,96) !TS: Same as frac4, but for initlogn.F90 -!soa - - real(r8) :: rrr4 (16,6,6) !TS: Modal radius array, mode 4 - real(r8) :: sss4 (16,6,6) !TS: Modal radius array, mode 4 - real(r8) :: calog4(576) !TS: Same as catot4, but for initlogn.F90 - real(r8) :: fraclog4 (576) !TS: Same as frac4, but for initlogn.F90 - real(r8) :: fraqlog4 (576) !TS: Same as fraq4, but for initlogn.F90 - real(r8) :: rk4 (576) !TS: Array for reading modal radius from file - real(r8) :: stdv4 (576) !TS: Array for reading std. dev. from file - - real(r8) :: rrr (5:10,6,6,6,6) !TS: Modal radius array, mode 5 - 10 - real(r8) :: sss (5:10,6,6,6,6) !TS: Standard deviation array, mode 5 - 10 - real(r8) :: calog (5:10,1296) !TS: Same as catot, but for initlogn.F90 - real(r8) :: fraclog5to10 (5:10,1296) !TS: Same as frac5to10, but for initlogn.F90 - real(r8) :: fabclog5to10 (5:10,1296) !TS: Same as fabc5to10, but for initlogn.F90 - real(r8) :: fraqlog5to10 (5:10,1296) !TS: Same as fraq5to10, but for initlogn.F90 - real(r8) :: rk5to10 (5:10,1296) !TS: Array for reading modal radius from file - real(r8) :: stdv5to10 (5:10,1296) !TS: Array for reading std. dev. from file - - - real(r8), parameter :: sq2pi = 1._r8/sqrt(2.0_r8*pi) - real(r8), dimension(0:nmodes) :: volumeToNumber !m3 ==> # - real(r8), dimension(0:nmodes) :: numberToSurface !# ==> m2 - + !----------------------------------------------------------------------------- + !Module containing subroutines constants, koagsub and parmix and declaration + !of the variables required by them. + !----------------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + use commondefinitions, only: nmodes + use physconst, only: pi + ! + implicit none + public + + real(r8), parameter:: smallNumber = 1.e-100_r8 + + !Essential size distribution parameters + real(r8), parameter :: rTabMin = 1.e-9_r8 ![m] smallest lookup table size + real(r8), parameter :: rTabMax = 20.e-6_r8 ![m] largest lookup table size + integer, parameter :: nBinsTab = 44 ![nbr] number of tabulated bins + + !Smallest particle which can receive aquous chemistry mass + real(r8), parameter :: rMinAquousChemistry = 0.05e-6_r8 + real(r8) :: nk(0:nmodes,nbinsTab) !dN/dlogr for modes + real(r8) :: normnk(0:nmodes,nbinsTab) !dN for modes (sums to one over size range) + + real(r8) :: rBinEdge(nBinsTab+1) + real(r8) :: rBinMidpoint(nBinsTab) + + real(r8), parameter :: sq2pi = 1._r8/sqrt(2.0_r8*pi) + real(r8) :: volumeToNumber(0:nmodes) !m3 ==> # + real(r8) :: numberToSurface(0:nmodes) !# ==> m2 end module const diff --git a/src/chemistry/oslo_aero/initlogn.F90 b/src/chemistry/oslo_aero/initlogn.F90 deleted file mode 100644 index 3f328050d8..0000000000 --- a/src/chemistry/oslo_aero/initlogn.F90 +++ /dev/null @@ -1,243 +0,0 @@ -subroutine initlogn - - ! This subroutine reads the tabulated parameters for "best lognormal fits" - ! of the aerosol size distribution wrt CCN activation as calculated by Alf Kirkevaag. - - ! Created for CAM3 by Trude Storelvmo, Fall 2007. - ! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013 - ! Updated for reading inout files with extra header info - Alf Kirkevaag, May 2015, - ! and for new tables including SOA September 2015. - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - - use shr_kind_mod, only: r8 => shr_kind_r8 - use aerosoldef - use opttab, only: cat,fac,fbc,faq,cate - use const - use cam_logfile, only: iulog - use oslo_control, only: oslo_getopts,dir_string_length - - implicit none - - integer kcomp, ictot, ifac, ifbc, ifaq, irk, istdv - integer ic, ifil, lin - character(len=dir_string_length) :: aerotab_table_dir - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - - write(iulog,*)'b4 nlog open ok' - - ! Where are the tables stored?? - call oslo_getopts(aerotab_table_dir_out=aerotab_table_dir) - - open(20,file=trim(aerotab_table_dir)//'/logntilp1.out' ,form='formatted',status='old') ! SO4&SOA(n/Ait) - open(21,file=trim(aerotab_table_dir)//'/logntilp2.out' ,form='formatted',status='old') ! BC(n/Ait) - open(22,file=trim(aerotab_table_dir)//'/logntilp3.out' ,form='formatted',status='old') ! OC(n/Ait) - open(23,file=trim(aerotab_table_dir)//'/logntilp4.out' ,form='formatted',status='old') ! BC&OC(n/Ait) - open(24,file=trim(aerotab_table_dir)//'/logntilp5.out' ,form='formatted',status='old') ! SO4(Ait75) - open(25,file=trim(aerotab_table_dir)//'/logntilp6.out' ,form='formatted',status='old') ! MINACC - open(26,file=trim(aerotab_table_dir)//'/logntilp7.out' ,form='formatted',status='old') ! MINCOA - open(27,file=trim(aerotab_table_dir)//'/logntilp8.out' ,form='formatted',status='old') ! SEASF - open(28,file=trim(aerotab_table_dir)//'/logntilp9.out' ,form='formatted',status='old') ! SEASACC - open(29,file=trim(aerotab_table_dir)//'/logntilp10.out',form='formatted',status='old') ! SEASCOA - - write(iulog,*)'nlog open ok' - - ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 20,29 - call checkTableHeader (ifil) - enddo - - ! ************************************************************************ - ! Mode 1 (SO4&SOA + condesate from H2SO4 and SOA) - ! Modes 2 to 3 (BC/OC + condesate from H2SO4 and SOA) - ! - ! These two are treated the same way since there is no dependence on - ! fombg (SOA fraction in the background) for mode 1. - ! ************************************************************************ - - do ifil = 1,2 - do lin = 1,96 ! 16*6 entries - read(19+ifil,993) kcomp, calog1to3(ifil,lin), fraclog1to3 (ifil, lin), & - rk1to3(ifil,lin), stdv1to3(ifil,lin) - - do ic=1,16 - if(abs((calog1to3(ifil,lin)-cate(kcomp,ic))/cate(kcomp,ic)) shr_kind_r8 use ppgrid, only: pcols - use commondefinitions, only : nmodes, nbmodes - use const, only: sss1to3, rrr1to3 - use const, only: sss4, rrr4 - use const, only: sss, rrr + use commondefinitions, only: nmodes, nbmodes use opttab, only: nbmp1, cate, fac, faq, fbc, cat use lininterpol_mod, only: lininterpol3dim, lininterpol4dim + use aerosoldef + + use cam_logfile, only: iulog + use oslo_control, only: oslo_getopts,dir_string_length implicit none private + public :: initlogn public :: intlog1to3_sub public :: intlog4_sub public :: intlog5to10_sub + real(r8) :: rrr1to3 (3,16,6) ! Modal radius array, mode 1 - 3 + real(r8) :: sss1to3 (3,16,6) ! Standard deviation array, Mode 1 -3 + real(r8) :: rrr4 (16,6,6) ! Modal radius array, mode 4 + real(r8) :: sss4 (16,6,6) ! Modal radius array, mode 4 + real(r8) :: rrr (5:10,6,6,6,6) ! Modal radius array, mode 5 - 10 + real(r8) :: sss (5:10,6,6,6,6) ! Standard deviation array, mode 5 - 10 + + real(r8) :: calog1to3(3,96) ! Array for reading catot from file + real(r8) :: rk1to3 (3,96) ! Array for reading modal radius from file + real(r8) :: stdv1to3 (3,96) ! Array for reading std. dev. from file + real(r8) :: fraclog1to3 (3,96) ! Same as frac4, but for initlogn.F90 + + real(r8) :: calog4(576) ! Same as catot4, but for initlogn.F90 + real(r8) :: fraclog4 (576) ! Same as frac4, but for initlogn.F90 + real(r8) :: fraqlog4 (576) ! Same as fraq4, but for initlogn.F90 + real(r8) :: rk4 (576) ! Array for reading modal radius from file + real(r8) :: stdv4 (576) ! Array for reading std. dev. from file + + real(r8) :: calog (5:10,1296) ! Same as catot, but for initlogn.F90 + real(r8) :: fraclog5to10 (5:10,1296) ! Same as frac5to10, but for initlogn.F90 + real(r8) :: fabclog5to10 (5:10,1296) ! Same as fabc5to10, but for initlogn.F90 + real(r8) :: fraqlog5to10 (5:10,1296) ! Same as fraq5to10, but for initlogn.F90 + real(r8) :: rk5to10 (5:10,1296) ! Array for reading modal radius from file + real(r8) :: stdv5to10 (5:10,1296) ! Array for reading std. dev. from file + +!======================================================= contains +!======================================================= + + subroutine initlogn() + + ! Reads the tabulated parameters for "best lognormal fits" of the + ! aerosol size distribution wrt CCN activation as calculated by Alf Kirkevaag. + + integer kcomp, ictot, ifac, ifbc, ifaq, irk, istdv + integer ic, ifil, lin + character(len=dir_string_length) :: aerotab_table_dir + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps4 = 1.e-4_r8 + + ! Where are the tables stored?? + call oslo_getopts(aerotab_table_dir_out=aerotab_table_dir) + + open(20,file=trim(aerotab_table_dir)//'/logntilp1.out' ,form='formatted',status='old') ! SO4&SOA(n/Ait) + open(21,file=trim(aerotab_table_dir)//'/logntilp2.out' ,form='formatted',status='old') ! BC(n/Ait) + open(22,file=trim(aerotab_table_dir)//'/logntilp3.out' ,form='formatted',status='old') ! OC(n/Ait) + open(23,file=trim(aerotab_table_dir)//'/logntilp4.out' ,form='formatted',status='old') ! BC&OC(n/Ait) + open(24,file=trim(aerotab_table_dir)//'/logntilp5.out' ,form='formatted',status='old') ! SO4(Ait75) + open(25,file=trim(aerotab_table_dir)//'/logntilp6.out' ,form='formatted',status='old') ! MINACC + open(26,file=trim(aerotab_table_dir)//'/logntilp7.out' ,form='formatted',status='old') ! MINCOA + open(27,file=trim(aerotab_table_dir)//'/logntilp8.out' ,form='formatted',status='old') ! SEASF + open(28,file=trim(aerotab_table_dir)//'/logntilp9.out' ,form='formatted',status='old') ! SEASACC + open(29,file=trim(aerotab_table_dir)//'/logntilp10.out',form='formatted',status='old') ! SEASCOA + write(iulog,*)'nlog open ok' + + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 20,29 + call checkTableHeader (ifil) + enddo + + ! ************************************************************************ + ! Mode 1 (SO4&SOA + condesate from H2SO4 and SOA) + ! Modes 2 to 3 (BC/OC + condesate from H2SO4 and SOA) + ! + ! These two are treated the same way since there is no dependence on + ! fombg (SOA fraction in the background) for mode 1. + ! ************************************************************************ + + do ifil = 1,2 + do lin = 1,96 ! 16*6 entries + read(19+ifil,993) kcomp, calog1to3(ifil,lin), fraclog1to3 (ifil, lin), & + rk1to3(ifil,lin), stdv1to3(ifil,lin) + + do ic=1,16 + if(abs((calog1to3(ifil,lin)-cate(kcomp,ic))/cate(kcomp,ic)) Date: Thu, 17 Aug 2023 11:34:16 +0200 Subject: [PATCH 11/71] removed opttab_lw and put functionality in opttab.F90 --- src/chemistry/oslo_aero/aero_model.F90 | 3 +- src/physics/cam_oslo/optinterpol.F90 | 2 +- src/physics/cam_oslo/opttab.F90 | 406 ++++++++++++++++++++++ src/physics/cam_oslo/opttab_lw.F90 | 445 ------------------------- src/physics/cam_oslo/pmxsub.F90 | 1 - 5 files changed, 408 insertions(+), 449 deletions(-) delete mode 100644 src/physics/cam_oslo/opttab_lw.F90 diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index a77bbb8736..825937ff0a 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -195,8 +195,7 @@ subroutine aero_model_init( pbuf2d ) use oslo_ocean_intr, only: oslo_ocean_init use oslo_aerosols_intr, only: oslo_aero_initialize - use opttab, only : initopt - use opttab_lw, only: initopt_lw + use opttab, only : initopt, initopt_lw use modal_aero_deposition , only: modal_aero_deposition_init diff --git a/src/physics/cam_oslo/optinterpol.F90 b/src/physics/cam_oslo/optinterpol.F90 index 723a4074b9..1d28c8ba8c 100644 --- a/src/physics/cam_oslo/optinterpol.F90 +++ b/src/physics/cam_oslo/optinterpol.F90 @@ -12,7 +12,7 @@ module optinterpol use shr_kind_mod , only : r8 => shr_kind_r8 use ppgrid , only : pcols, pver use commondefinitions , only : nmodes, nbmodes - use opttab_lw , only : ka0, ka1, ka2to3, ka4, ka5to10, nlwbands + use opttab , only : ka0, ka1, ka2to3, ka4, ka5to10, nlwbands use opttab , only : nbands, e use opttab , only : fombg, fbcbg, cate, cat, fac, faq, fbc, rh, eps use opttab , only : om0, g0, be0, ke0 diff --git a/src/physics/cam_oslo/opttab.F90 b/src/physics/cam_oslo/opttab.F90 index fe1f7c41ed..0e7ba25336 100644 --- a/src/physics/cam_oslo/opttab.F90 +++ b/src/physics/cam_oslo/opttab.F90 @@ -16,12 +16,14 @@ module opttab use shr_kind_mod, only: r8 => shr_kind_r8 use cam_logfile, only: iulog + use oslo_control, only: oslo_getopts, dir_string_length implicit none private ! Interfaces public :: initopt + public :: initopt_lw integer, public, parameter :: nbands=14 ! number of aerosol spectral bands in SW integer, public, parameter :: nbmp1=11 ! number of first non-background mode @@ -66,6 +68,15 @@ module opttab real(r8), public :: e, eps parameter (e=2.718281828_r8, eps=1.0e-30_r8) + ! Array bounds in the tabulated optical parameters + integer, public, parameter :: nlwbands=16 ! number of aerosol spectral bands in LW + + real(r8), public :: ka0(nlwbands) + real(r8), public :: ka1(nlwbands,10,6,16,6) + real(r8), public :: ka2to3(nlwbands,10,16,6,2:3) + real(r8), public :: ka4(nlwbands,10,6,16,6,6) + real(r8), public :: ka5to10(nlwbands,10,6,6,6,6,5:10) + contains subroutine initopt() @@ -506,5 +517,400 @@ subroutine initopt() end subroutine initopt + subroutine initopt_lw + + !--------------------------------------------------------------- + ! Modified by Egil Storen/NoSerC July 2002. + ! The sequence of the indices in arrays om1, g1, be1 and ke1 + ! (common block /tab1/) has been rearranged to avoid cache + ! problems while running subroutine interpol1. Files also + ! involved by this modification: interpol1.F and opttab.h. + ! Modified for new aerosol schemes by Alf Kirkevaag in January + ! 2006. Based on opttab.F90 and modified for new wavelength + ! bands and look-up tables by Alf Kirkevaag in January 2014, + ! and for SOA in August 2015. + !--------------------------------------------------------------- + + integer kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq + integer ifombg, ifbcbg + integer ic, ifil, lin, linmax + real(r8) catot, relh, frac, fabc, fraq, frombg, frbcbg + real(r8) spabs + real(r8) rh2(10) + real(r8) :: eps2 = 1.e-2_r8 + real(r8) :: eps3 = 1.e-3_r8 + real(r8) :: eps4 = 1.e-4_r8 + real(r8) :: eps6 = 1.e-6_r8 + real(r8) :: eps7 = 1.e-7_r8 + character(len=dir_string_length) :: aerotab_table_dir + + call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + + open(40,file=trim(aerotab_table_dir)//'/lwkcomp1.out' & + ,form="formatted",status="old") + open(41,file=trim(aerotab_table_dir)//'/lwkcomp2.out' & + ,form="formatted",status="old") + open(42,file=trim(aerotab_table_dir)//'/lwkcomp3.out' & + ,form="formatted",status="old") + open(43,file=trim(aerotab_table_dir)//'/lwkcomp4.out' & + ,form="formatted",status="old") + open(44,file=trim(aerotab_table_dir)//'/lwkcomp5.out' & + ,form="formatted",status="old") + open(45,file=trim(aerotab_table_dir)//'/lwkcomp6.out' & + ,form="formatted",status="old") + open(46,file=trim(aerotab_table_dir)//'/lwkcomp7.out' & + ,form="formatted",status="old") + open(47,file=trim(aerotab_table_dir)//'/lwkcomp8.out' & + ,form="formatted",status="old") + open(48,file=trim(aerotab_table_dir)//'/lwkcomp9.out' & + ,form="formatted",status="old") + open(49,file=trim(aerotab_table_dir)//'/lwkcomp10.out'& + ,form="formatted",status="old") + open(50,file=trim(aerotab_table_dir)//'/lwkcomp0.out'& + ,form="formatted",status="old") + + ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) + do ifil = 40,50 + call checkTableHeader (ifil) + enddo + + ! Then reading in the look-up table entries for each file (lwkcomp*.out) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! Mode 0, BC(ax) + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 11 + linmax=nlwbands + do lin = 1,linmax + + read(39+ifil,996) kcomp, iwl, relh, spabs + + ka0(iwl)=spabs ! unit m^2/g + + ! write(*,*) 'kcomp, ka =', kcomp, ka0(iwl) + + end do + + do iwl=1,nlwbands + if(ka0(iwl)<=0.0_r8) then + write(iulog,*) 'ka0 =', iwl, ka0(iwl) + write(iulog,*) 'Error in initialization of ka0' + stop + endif + enddo + + write(iulog,*)'lw mode 0 ok' + + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! Mode 1 (H2SO4 + condesate from H2SO4 and SOA) + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + + ifil = 1 + linmax=nlwbands*10*6*16*6 + do lin = 1,linmax + + read(39+ifil,997) kcomp, iwl, relh, frombg, catot, frac, spabs + + do ic=1,10 + if(abs(relh-rh(ic)) shr_kind_r8 - use cam_logfile, only: iulog - use opttab - implicit none - - private - save - - - ! Interfaces - public initopt_lw - - -! Array bounds in the tabulated optical parameters - integer, public, parameter :: nlwbands=16 ! number of aerosol spectral bands in LW - - real(r8), public :: ka0(nlwbands) - real(r8), public :: ka1(nlwbands,10,6,16,6) - real(r8), public :: ka2to3(nlwbands,10,16,6,2:3) - real(r8), public :: ka4(nlwbands,10,6,16,6,6) - real(r8), public :: ka5to10(nlwbands,10,6,6,6,6,5:10) - - - contains - -subroutine initopt_lw - -!--------------------------------------------------------------- -! Modified by Egil Storen/NoSerC July 2002. -! The sequence of the indices in arrays om1, g1, be1 and ke1 -! (common block /tab1/) has been rearranged to avoid cache -! problems while running subroutine interpol1. Files also -! involved by this modification: interpol1.F and opttab.h. -! Modified for new aerosol schemes by Alf Kirkevaag in January -! 2006. Based on opttab.F90 and modified for new wavelength -! bands and look-up tables by Alf Kirkevaag in January 2014, -! and for SOA in August 2015. -!--------------------------------------------------------------- - - use oslo_control, only: oslo_getopts, dir_string_length - - -! implicit none - - integer kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq - integer ifombg, ifbcbg - integer ic, ifil, lin, linmax - real(r8) catot, relh, frac, fabc, fraq, frombg, frbcbg - real(r8) spabs - real(r8) rh2(10) - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps3 = 1.e-3_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - real(r8) :: eps7 = 1.e-7_r8 - character(len=dir_string_length) :: aerotab_table_dir - - call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) - -! Opening the 'lwkcomp'-files: - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - open(40,file=trim(aerotab_table_dir)//'/lwkcomp1.out' & - ,form="formatted",status="old") - open(41,file=trim(aerotab_table_dir)//'/lwkcomp2.out' & - ,form="formatted",status="old") - open(42,file=trim(aerotab_table_dir)//'/lwkcomp3.out' & - ,form="formatted",status="old") - open(43,file=trim(aerotab_table_dir)//'/lwkcomp4.out' & - ,form="formatted",status="old") - open(44,file=trim(aerotab_table_dir)//'/lwkcomp5.out' & - ,form="formatted",status="old") - open(45,file=trim(aerotab_table_dir)//'/lwkcomp6.out' & - ,form="formatted",status="old") - open(46,file=trim(aerotab_table_dir)//'/lwkcomp7.out' & - ,form="formatted",status="old") - open(47,file=trim(aerotab_table_dir)//'/lwkcomp8.out' & - ,form="formatted",status="old") - open(48,file=trim(aerotab_table_dir)//'/lwkcomp9.out' & - ,form="formatted",status="old") - open(49,file=trim(aerotab_table_dir)//'/lwkcomp10.out'& - ,form="formatted",status="old") - open(50,file=trim(aerotab_table_dir)//'/lwkcomp0.out'& - ,form="formatted",status="old") - -! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 40,50 - call checkTableHeader (ifil) - enddo - -! Then reading in the look-up table entries for each file (lwkcomp*.out) - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! Mode 0, BC(ax) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 11 - linmax=nlwbands - do lin = 1,linmax - - read(39+ifil,996) kcomp, iwl, relh, spabs - - ka0(iwl)=spabs ! unit m^2/g - -! write(*,*) 'kcomp, ka =', kcomp, ka0(iwl) - - end do - - do iwl=1,nlwbands - if(ka0(iwl)<=0.0_r8) then - write(iulog,*) 'ka0 =', iwl, ka0(iwl) - write(iulog,*) 'Error in initialization of ka0' - stop - endif - enddo - - write(iulog,*)'lw mode 0 ok' - - -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc -! Mode 1 (H2SO4 + condesate from H2SO4 and SOA) -!ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 1 - linmax=nlwbands*10*6*16*6 - do lin = 1,linmax - - read(39+ifil,997) kcomp, iwl, relh, frombg, catot, frac, spabs - - do ic=1,10 - if(abs(relh-rh(ic)) Date: Thu, 17 Aug 2023 12:59:28 +0200 Subject: [PATCH 12/71] moved optinterpol to opttab --- src/physics/cam_oslo/optinterpol.F90 | 1882 -------------------------- src/physics/cam_oslo/opttab.F90 | 1875 ++++++++++++++++++++++++- src/physics/cam_oslo/pmxsub.F90 | 2 - 3 files changed, 1866 insertions(+), 1893 deletions(-) delete mode 100644 src/physics/cam_oslo/optinterpol.F90 diff --git a/src/physics/cam_oslo/optinterpol.F90 b/src/physics/cam_oslo/optinterpol.F90 deleted file mode 100644 index 1d28c8ba8c..0000000000 --- a/src/physics/cam_oslo/optinterpol.F90 +++ /dev/null @@ -1,1882 +0,0 @@ -module optinterpol - - !-------------------------------------------------------------------------------- - ! Purpose: To interpolate between look-up table entries for SW optical aerosol properties. - ! Optimized for speed by Arild Burud and Egil Storen (NoSerC), June-July 2002 - ! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013. - ! Extended for new SOA treatment for kcomp1-4.out and treating SOA as coagulated OC - ! for kcomp5-10 - Alf Kirkevaag, August 2015, and also rewritten to a more generalized - ! for for interpolations using common subroutines interpol*dim. - !-------------------------------------------------------------------------------- - - use shr_kind_mod , only : r8 => shr_kind_r8 - use ppgrid , only : pcols, pver - use commondefinitions , only : nmodes, nbmodes - use opttab , only : ka0, ka1, ka2to3, ka4, ka5to10, nlwbands - use opttab , only : nbands, e - use opttab , only : fombg, fbcbg, cate, cat, fac, faq, fbc, rh, eps - use opttab , only : om0, g0, be0, ke0 - use opttab , only : om1, g1, be1, ke1 - use opttab , only : om2to3, g2to3, be2to3, ke2to3 - use opttab , only : om4, g4, be4, ke4 - use opttab , only : om5to10, g5to10, be5to10, ke5to10 - use lininterpol_mod , only : lininterpol3dim, lininterpol4dim, lininterpol5dim - - implicit none - private - - public :: inputForInterpol - public :: interpol0 - public :: interpol1 - public :: interpol2to3 - public :: interpol4 - public :: interpol5to10 - -!******************************************************************************************** -contains -!******************************************************************************************** - - subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & - f_soana, xfombg, ifombg1, faitbc, xfbcbg, ifbcbg1, & - fnbc, xfbcbgn, ifbcbgn1, Nnatk, Cam, xct, ict1, & - focm, fcm, xfac, ifac1, fbcm, xfbc, ifbc1, faqm, xfaq, ifaq1) - - ! - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: rhum(pcols,pver) ! level relative humidity (fraction) - real(r8), intent(in) :: f_soana(pcols,pver) ! SOA/(SOA+H2SO4) mass fraction for the background in mode 1 - real(r8), intent(in) :: faitbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 4 - real(r8), intent(in) :: fnbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 14 - real(r8), intent(in) :: focm(pcols,pver,4) ! fraction of added mass which is either SOA condensate or OC coagulate - real(r8), intent(in) :: Cam(pcols,pver,nbmodes) ! added internally mixed SO4+BC+OC concentration for a normalized mode - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration - real(r8), intent(in) :: fcm(pcols,pver,nbmodes) ! fraction of added mass which is either BC or OC/SOA (carbonaceous) - real(r8), intent(in) :: fbcm(pcols,pver,nbmodes) ! fraction of added mass as BC/(BC+OC) - real(r8), intent(in) :: faqm(pcols,pver,nbmodes) ! fraction of added sulfate which is from aqueous phase (ammonium sulfate) - ! - ! Output arguments - real(r8), intent(out) :: xrh(pcols,pver) ! rhum for use in the interpolations - integer, intent(out) :: irh1(pcols,pver) - real(r8), intent(out) :: xfombg(pcols,pver) ! f_soana for use in the interpolations (mode 1) - integer, intent(out) :: ifombg1(pcols,pver) - real(r8), intent(out) :: xfbcbg(pcols,pver) ! faitbc for use in the interpolations (mode 4) - integer, intent(out) :: ifbcbg1(pcols,pver) - real(r8), intent(out) :: xfbcbgn(pcols,pver) ! fnbc for use in the interpolations (mode 14) - integer, intent(out) :: ifbcbgn1(pcols,pver) - real(r8), intent(out) :: xct(pcols,pver,nmodes) ! Cam/Nnatk for use in the interpolations - integer, intent(out) :: ict1(pcols,pver,nmodes) - real(r8), intent(out) :: xfac(pcols,pver,nbmodes) ! focm (1-4) or fcm (5-10) for use in the interpolations - integer, intent(out) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(out) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations - integer, intent(out) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(out) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations - integer, intent(out) :: ifaq1(pcols,pver,nbmodes) - ! - ! Local variables - integer k, icol, i, irelh - real(r8) :: eps10 = 1.e-10_r8 - !------------------------------------------------------------------------ - ! - ! write(*,*) 'Before xrh-loop' - do k=1,pver - do icol=1,ncol - xrh(icol,k) = min(max(rhum(icol,k),rh(1)),rh(10)) - end do - end do - - ! write(*,*) 'Before rh-loop' - do irelh=1,9 - do k=1,pver - do icol=1,ncol - if(xrh(icol,k) >= rh(irelh) .and. xrh(icol,k)<=rh(irelh+1)) then - irh1(icol,k)=irelh - endif - end do - end do - end do - ! write(*,*) 'xrh, irh1, irh2 =', xrh(1,26), irh1(1,26), irh2(1,26) - - do k=1,pver - do icol=1,ncol - ! find common xfombg, ifombg1 and ifombg2 for use in the interpolation routines - xfombg(icol,k) =min(max(f_soana(icol,k),fombg(1)),fombg(6)) - ifombg1(icol,k)=int(5.0_r8*xfombg(icol,k)-eps10)+1 ! Boer linkes til def. i opttab.F90 - end do - enddo - - do k=1,pver - do icol=1,ncol - ! find common xfbcbg, ifbcbg1 and ifbcbg2 for use in the interpolation routines - xfbcbg(icol,k) =min(max(faitbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 - ifbcbg1(icol,k)=min(max(int(4*log10(xfbcbg(icol,k))+6),1),5) - - ! find common xfbcbgn, ifbcbgn1 and ifbcbgn2 for use in the interpolation routines - xfbcbgn(icol,k) =min(max(fnbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 - ifbcbgn1(icol,k)=min(max(int(4*log10(xfbcbgn(icol,k))+6),1),5) - end do - enddo - - do i=1,4 - do k=1,pver - do icol=1,ncol - ! find common xfac, ifac1 and ifac2 for use in the interpolation routines - xfac(icol,k,i) =min(max(focm(icol,k,i),fac(1)),fac(6)) - ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 - end do - enddo - enddo - do i=5,nbmodes - do k=1,pver - do icol=1,ncol - ! find common xfac, ifac1 and ifac2 for use in the interpolation routines - xfac(icol,k,i) =min(max(fcm(icol,k,i),fac(1)),fac(6)) - ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 - end do - enddo - enddo - - do i=1,nbmodes - do k=1,pver - do icol=1,ncol - ! find common xfbc, ifbc1 and ifbc2 for use in the interpolation routines - xfbc(icol,k,i) =min(max(fbcm(icol,k,i),fbc(1)),fbc(6)) ! Boer linkes til def. i opttab.F90 - ifbc1(icol,k,i)=min(max(int(4*log10(xfbc(icol,k,i))+6),1),5) - end do - enddo - enddo - - do i=1,nbmodes - do k=1,pver - do icol=1,ncol - ! find common xfaq, ifaq1 and ifaq2 for use in the interpolation routines - xfaq(icol,k,i) =min(max(faqm(icol,k,i),faq(1)),faq(6)) - ifaq1(icol,k,i)=int(5.0_r8*xfaq(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 - end do - enddo - enddo - - ! find common xct, ict1 and ict2 for use in the interpolation routines ! Boer linkes til def. i opttab.F90 - do i=1,4 - do k=1,pver - do icol=1,ncol - xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cate(i,1)),cate(i,16)) - if(i.le.2) then - ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+19.666_r8),1),15) - elseif(i.eq.3) then ! mode not used - xct(icol,k,i)=cate(i,1) - ict1(icol,k,i)=1 - else - ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+13.903_r8),1),15) - endif - end do - end do - end do - - do i=5,10 - do k=1,pver - do icol=1,ncol - xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cat(i,1)),cat(i,6)) - if(i.eq.5) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.824_r8),1),5) - elseif(i.eq.6) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.523_r8),1),5) - elseif(i.eq.7) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) - elseif(i.eq.8) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+5.921_r8),1),5) - elseif(i.eq.9) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.301_r8),1),5) - else - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) - endif - end do - end do - end do - - do i=11,nmodes ! for the externally mixed modes 11-14 (now only 12 and 14) - do k=1,pver - do icol=1,ncol - xct(icol,k,i)=cate(i-10,1) - ict1(icol,k,i)=1 - end do - end do - end do - - return - - end subroutine inputForInterpol - - !******************************************************************************************** - subroutine interpol0 (lchnk, ncol, daylight, Nnatk, omega, gass, bex, ske, lw_on, kabs) - ! - ! Arguments - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - logical , intent(in) :: daylight(pcols) ! calculations also at (polar) night if daylight=.true. - logical , intent(in) :: lw_on ! LW calculations are performed if true - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8) , intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8) , intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8) , intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8) , intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands) ! LW spectral modal specific absorption coefficient - ! - ! Local variables - integer i, kcomp, k, icol - !--------------------------------------- - - kcomp=0 - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kcomp,i)=0.0_r8 - gass(icol,k,kcomp,i)=0.0_r8 - bex(icol,k,kcomp,i)=0.0_r8 - ske(icol,k,kcomp,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kcomp,i)=0.0_r8 - end do - end do - end do - - ! SW optical parameters - - do k=1,pver - do icol=1,ncol - ! if(Nnatk(icol,k,kcomp)>0.0_r8) then - if(daylight(icol)) then - do i=1,nbands ! i = wavelength index - omega(icol,k,kcomp,i)=om0(i) - gass(icol,k,kcomp,i)=g0(i) - bex(icol,k,kcomp,i)=be0(i) - ske(icol,k,kcomp,i)=ke0(i) - end do ! i - else ! daylight - ! Need be and ke in nband=4 for lw calculation - bex(icol,k,kcomp,4)=be0(4) - ske(icol,k,kcomp,4)=ke0(4) - end if ! daylight - end do ! icol - end do ! k - - ! LW optical parameters - - if(lw_on) then - do k=1,pver - do icol=1,ncol - do i=1,nlwbands ! i = wavelength index - kabs(icol,k,kcomp,i)=ka0(i) - end do ! i - end do ! icol - end do ! k - - endif ! lw_on - - end subroutine interpol0 - - !******************************************************************************************** - subroutine interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfombg, ifombg1, & - xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) - - ! - ! Arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode - integer, intent(in) :: ifombg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absoption coefficient - ! - ! Local variables - integer i, kcomp, k, icol, kc10 - real(r8) a, b - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifo1, t_ifo2 - real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2 - real(r8) t_cat1, t_cat2, t_fombg1, t_fombg2, t_xfombg - real(r8) d2mx(4), dxm1(4), invd(4) - real(r8) opt4d(2,2,2,2) - real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) kabs1, kabs2 - !--------------------------------------- - - ! write(*,*) 'Before kcomp-loop' - do kcomp=1,1 - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - ! write(*,*) 'Before init-loop', kc10 - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kc10,i)=0.0_r8 - gass(icol,k,kc10,i)=0.0_r8 - bex(icol,k,kc10,i)=0.0_r8 - ske(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifo1 = ifombg1(icol,k) - t_ifo2 = t_ifo1+1 - - t_rh1 = rh(t_irh1) - !x t_rh2 = t_rh1+1 - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fombg1 = fombg(t_ifo1) - t_fombg2 = fombg(t_ifo2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfombg = xfombg(icol,k) - - ! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fombg2-t_xfombg) - dxm1(2) = (t_xfombg-t_fombg1) - invd(2) = 1.0_r8/(t_fombg2-t_fombg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - - - ! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! single scattering albedo: - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, ome1, ome2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before omega' - omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) /(t_rh2-t_rh1) - !alt omega(icol,k,kc10,i)=(d2mx(1)*ome1+dxm1(1)*ome2)*invd(1) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! asymmetry factor - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, ge1, ge2) - - ! finally, interpolation in the rh dimension (dim. 1) - ! write(*,*) 'Before gass' - gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) /(t_rh2-t_rh1) - !alt gass(icol,k,kc10,i)=(d2mx(1)*ge1+dxm1(1)*ge2)*invd(1) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) /(t_rh2-t_rh1) - !alt bex(icol,k,kc10,i)=(d2mx(1)*bex1+dxm1(1)*bex2)*invd(1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - !alt a=(log(bex2)-log(bex1))*invd(1) - !alt b=(t_rh2*log(bex1)-t_rh1*log(bex2))*invd(1) - !alt bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - ! if(bex(icol,k,kc10,8)<1.e-20_r8) then - ! write(*,995) 'bex(8)=', kc10, t_xrh, t_xct, t_xfac, t_xfombg, bex(icol,k,kc10,8) - ! endif - else ! daylight - - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction used for size information in LW - - i=4 - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - do i=4,4 ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific extinction - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, ske1, ske2) - - ske1=max(ske1,1.e-30_r8) - ske2=max(ske2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before ske' - if(t_xrh <= 0.37_r8) then - ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - !alt ske(icol,k,kc10,i)=(d2mx(1)*ske1+dxm1(1)*ske2)*invd(1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kc10,i)=e**(a*t_xrh+b) - !alt a=(log(ske2)-log(ske1))*invd(1) - !alt b=(t_rh2*log(ske1)-t_rh1*log(ske2))*invd(1) - !alt ske(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - if (lw_on) then - - ! LW optical parameters - do i=1,nlwbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific absorption in LW - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30) - kabs2=max(kabs2,1.e-30) - - ! write(*,*) 'Before kabs' - if(t_xrh <= 0.37) then - kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - - ! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) - ! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) - ! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) - ! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) - - end do ! kcomp - - return - end subroutine interpol1 - - - !******************************************************************************************** - subroutine interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, & - xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) - - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - - ! Output arguments - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient - ! - ! Local variables - integer i, kcomp, k, icol, kc10 - real(r8) a, b - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 - real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2,t_cat1, t_cat2 - real(r8) d2mx(3), dxm1(3), invd(3) - real(r8) opt3d(2,2,2) - real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) kabs1, kabs2 - !--------------------------------------- - - ! write(*,*) 'Before kcomp-loop' - ! do kcomp=2,3 - do kcomp=2,2 - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - ! write(*,*) 'Before init-loop', kc10 - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kc10,i)=0.0_r8 - gass(icol,k,kc10,i)=0.0_r8 - bex(icol,k,kc10,i)=0.0_r8 - ske(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - ! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 - ! write(*,*) 't_ict1,t_ict2=',t_ict1,t_ict2 - ! write(*,*) 't_ifc1,t_ifc2=',t_ifc1,t_ifc2 - ! write(*,*) 't_ifa1,t_ifa2=',t_ifa1,t_ifa2 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - - ! write(*,*) 't_rh1,t_rh2,t_cat1,t_cat2=',t_rh1,t_rh2,t_cat1,t_cat2 - ! write(*,*) 't_fac1,t_fac2=',t_fac1,t_fac2 - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - - ! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - - - ! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! single scattering albedo: - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=om2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=om2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=om2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=om2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=om2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=om2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=om2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=om2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, ome1, ome2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before omega' - omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & - /(t_rh2-t_rh1) - ! write(*,*) omega(icol,k,kc10,i) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! asymmetry factor - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=g2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=g2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=g2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=g2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=g2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=g2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=g2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=g2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, ge1, ge2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before gass' - gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) - ! write(*,*) gass(icol,k,kc10,i) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) - - bex1=max(bex1,1.e-30) - bex2=max(bex2,1.e-30) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - else ! daylight - - - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction used for LW size information - - i=4 - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) - - bex1=max(bex1,1.e-30) - bex2=max(bex2,1.e-30) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - - - do i=4,4 ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific extinction - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=ke2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=ke2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=ke2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=ke2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=ke2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=ke2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=ke2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=ke2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, ske1, ske2) - - ske1=max(ske1,1.e-30) - ske2=max(ske2,1.e-30) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before ske' - if(t_xrh <= 0.37) then - ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - - ! LW optical parameters - do i=1,nlwbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific absorption in LW - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=ka2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=ka2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=ka2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=ka2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=ka2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=ka2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=ka2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=ka2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30_r8) - kabs2=max(kabs2,1.e-30_r8) - - ! write(*,*) 'Before kabs' - if(t_xrh <= 0.37_r8) then - kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - - ! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) - ! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) - ! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) - ! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) - - end do ! kcomp - - return - end subroutine interpol2to3 - - !******************************************************************************************** - - subroutine interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfbcbg, ifbcbg1, & - xct, ict1, xfac, ifac1, xfaq, ifaq1, & - omega, gass, bex, ske, lw_on, kabs) - - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode - integer, intent(in) :: ifbcbg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - - ! Output arguments - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient - ! - ! Local variables - integer :: i, kcomp, k, kc10, icol - real(r8) :: a, b - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2, t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) :: t_faq1, t_faq2, t_xfaq, t_fbcbg1, t_fbcbg2, t_xfbcbg, t_fac1 - real(r8) :: t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) :: kabs1, kabs2 - !--------------------------------------- - - ! write(*,*) 'Before kcomp-loop' - do kcomp=4,4 - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - ! write(*,*) 'Before init-loop', kc10 - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kc10,i)=0.0_r8 - gass(icol,k,kc10,i)=0.0_r8 - bex(icol,k,kc10,i)=0.0_r8 - ske(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifb1 = ifbcbg1(icol,k) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - t_xfbcbg = xfbcbg(icol,k) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fbcbg2-t_xfbcbg) - dxm1(2) = (t_xfbcbg-t_fbcbg1) - invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - ! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! single scattering albedo: - - opt5d(1,1,1,1,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before omega' - omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) /(t_rh2-t_rh1) - ! write(*,*) omega(icol,k,kc10,i) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! asymmetry factor - - opt5d(1,1,1,1,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before gass' - gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction - - opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - else ! daylight - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction called for use in size estimate for use in LW - i=4 - - opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - do i=4,4 ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific extinction - - opt5d(1,1,1,1,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) - - ske1=max(ske1,1.e-30_r8) - ske2=max(ske2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before ske' - if(t_xrh <= 0.37_r8) then - ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - - ! LW optical parameters - - do i=1,nlwbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific absorption - - opt5d(1,1,1,1,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30_r8) - kabs2=max(kabs2,1.e-30_r8) - - ! write(*,*) 'Before kabs' - if(t_xrh <= 0.37_r8) then - kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - - ! write(*,*) 'kcomp, omega(1,26,kc10,4)=', kcomp, omega(1,26,kc10,4) - ! write(*,*) 'kcomp, gass(1,26,kc10,4)=', kcomp, gass(1,26,kc10,4) - ! write(*,*) 'kcomp, bex(1,26,kc10,4)=', kcomp, bex(1,26,kc10,4) - ! write(*,*) 'kcomp, ske(1,26,kc10,4)=', kcomp, ske(1,26,kc10,4) - - end do ! kcomp - - end subroutine interpol4 - - !******************************************************************************************** - subroutine interpol5to10 (lchnk, ncol, daylight, xrh, irh1, Nnatk, xct, ict1, & - xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - omega, gass, bex, ske, lw_on, kabs) - - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) - integer, intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - - ! Output arguments - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient - - ! Local variables - integer :: i, kcomp, k, icol - real(r8) :: a, b - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 - integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) :: t_faq1, t_faq2, t_xfaq, t_fbc1, t_fbc2, t_xfbc, t_fac1 - real(r8) :: t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) :: kabs1, kabs2 - !--------------------------------------- - - ! write(*,*) 'Before kcomp-loop' - do kcomp=5,10 - - ! write(*,*) 'Before init-loop', kcomp - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kcomp,i)=0.0_r8 - gass(icol,k,kcomp,i)=0.0_r8 - bex(icol,k,kcomp,i)=0.0_r8 - ske(icol,k,kcomp,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kcomp,i)=0.0_r8 - end do - end do - end do - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - t_ifb1 = ifbc1(icol,k,kcomp) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cat(kcomp,t_ict1) - t_cat2 = cat(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbc1 = fbc(t_ifb1) - t_fbc2 = fbc(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfbc = xfbc(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - d2mx(4) = (t_fbc2-t_xfbc) - dxm1(4) = (t_xfbc-t_fbc1) - invd(4) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - ! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! single scattering albedo: - - opt5d(1,1,1,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before omega' - omega(icol,k,kcomp,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & - /(t_rh2-t_rh1) - ! write(*,*) omega(icol,k,kcomp,i) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! asymmetry factor - - opt5d(1,1,1,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before gass' - gass(icol,k,kcomp,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction - - opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - end do ! i - else ! daylight - - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction used for aerosol size estimate needed for LW calculations - i=4 - opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - - - do i=4,4 ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific extinction - - opt5d(1,1,1,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) - - ske1=max(ske1,1.e-30_r8) - ske2=max(ske2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before ske' - if(t_xrh <= 0.37_r8) then - ske(icol,k,kcomp,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - - ! LW optical parameters - - do i=1,nlwbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific absorption - - opt5d(1,1,1,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30_r8) - kabs2=max(kabs2,1.e-30_r8) - - ! write(*,*) 'Before kabs' - if(t_xrh <= 0.37_r8) then - kabs(icol,k,kcomp,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - end do ! kcomp - - end subroutine interpol5to10 - -end module optinterpol diff --git a/src/physics/cam_oslo/opttab.F90 b/src/physics/cam_oslo/opttab.F90 index 0e7ba25336..3b588cf978 100644 --- a/src/physics/cam_oslo/opttab.F90 +++ b/src/physics/cam_oslo/opttab.F90 @@ -1,8 +1,15 @@ module opttab - !Purpose: To read in SW look-up tables for calculation of aerosol optical properties, + ! Purpose: To read in SW look-up tables for calculation of aerosol optical properties, ! and to define the grid for discrete input-values in these look-up tables. + ! Purpose: To interpolate between look-up table entries for SW optical aerosol properties. + ! Optimized for speed by Arild Burud and Egil Storen (NoSerC), June-July 2002 + ! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013. + ! Extended for new SOA treatment for kcomp1-4.out and treating SOA as coagulated OC + ! for kcomp5-10 - Alf Kirkevaag, August 2015, and also rewritten to a more generalized + ! for for interpolations using common subroutines interpol*dim. + ! Modified for new wavelength bands and look-up tables - Alf Kirkevaag Dec. 2013. ! Updated for reading input files with extra header info - Alf Kirkevaag, May 2015. ! Extended for new SOA treatment - Alf Kirkevaag, August 2015. @@ -14,9 +21,13 @@ module opttab ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. ! Modified cate values for kcomp=2 (as in AeroTab) - Alf Kirkevaag October 2016. - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_logfile, only: iulog - use oslo_control, only: oslo_getopts, dir_string_length + use shr_kind_mod , only: r8 => shr_kind_r8 + use ppgrid , only: pcols, pver + use cam_logfile , only: iulog + use oslo_control , only: oslo_getopts, dir_string_length + use commondefinitions , only: nmodes, nbmodes + use lininterpol_mod , only: lininterpol3dim, lininterpol4dim, lininterpol5dim + implicit none private @@ -24,6 +35,12 @@ module opttab ! Interfaces public :: initopt public :: initopt_lw + public :: inputForInterpol + public :: interpol0 + public :: interpol1 + public :: interpol2to3 + public :: interpol4 + public :: interpol5to10 integer, public, parameter :: nbands=14 ! number of aerosol spectral bands in SW integer, public, parameter :: nbmp1=11 ! number of first non-background mode @@ -322,11 +339,6 @@ subroutine initopt() be2to3(iwl,irelh,ictot,ifac,kcomp)=ext ! unit km^-1 ke2to3(iwl,irelh,ictot,ifac,kcomp)=spext ! unit m^2/g - ! write(iulog,*) 'kcomp, om =', kcomp, om2to3(iwl,irelh,ictot,ifac,kcomp) - ! write(iulog,*) 'kcomp, g =', kcomp, g2to3(iwl,irelh,ictot,ifac,kcomp) - ! write(iulog,*) 'kcomp, be =', kcomp, be2to3(iwl,irelh,ictot,ifac,kcomp) - ! write(iulog,*) 'kcomp, ke =', kcomp, ke2to3(iwl,irelh,ictot,ifac,kcomp) - end do ! lin ! Prescribed dummy values for kcomp=3 @@ -517,6 +529,7 @@ subroutine initopt() end subroutine initopt + !******************************************************************************************** subroutine initopt_lw !--------------------------------------------------------------- @@ -912,5 +925,1849 @@ subroutine initopt_lw end subroutine initopt_lw + !******************************************************************************************** + subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & + f_soana, xfombg, ifombg1, faitbc, xfbcbg, ifbcbg1, & + fnbc, xfbcbgn, ifbcbgn1, Nnatk, Cam, xct, ict1, & + focm, fcm, xfac, ifac1, fbcm, xfbc, ifbc1, faqm, xfaq, ifaq1) + + ! + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: rhum(pcols,pver) ! level relative humidity (fraction) + real(r8), intent(in) :: f_soana(pcols,pver) ! SOA/(SOA+H2SO4) mass fraction for the background in mode 1 + real(r8), intent(in) :: faitbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 4 + real(r8), intent(in) :: fnbc(pcols,pver) ! BC/(BC + OC) mass fraction for the background in mode 14 + real(r8), intent(in) :: focm(pcols,pver,4) ! fraction of added mass which is either SOA condensate or OC coagulate + real(r8), intent(in) :: Cam(pcols,pver,nbmodes) ! added internally mixed SO4+BC+OC concentration for a normalized mode + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration + real(r8), intent(in) :: fcm(pcols,pver,nbmodes) ! fraction of added mass which is either BC or OC/SOA (carbonaceous) + real(r8), intent(in) :: fbcm(pcols,pver,nbmodes) ! fraction of added mass as BC/(BC+OC) + real(r8), intent(in) :: faqm(pcols,pver,nbmodes) ! fraction of added sulfate which is from aqueous phase (ammonium sulfate) + ! + ! Output arguments + real(r8), intent(out) :: xrh(pcols,pver) ! rhum for use in the interpolations + integer, intent(out) :: irh1(pcols,pver) + real(r8), intent(out) :: xfombg(pcols,pver) ! f_soana for use in the interpolations (mode 1) + integer, intent(out) :: ifombg1(pcols,pver) + real(r8), intent(out) :: xfbcbg(pcols,pver) ! faitbc for use in the interpolations (mode 4) + integer, intent(out) :: ifbcbg1(pcols,pver) + real(r8), intent(out) :: xfbcbgn(pcols,pver) ! fnbc for use in the interpolations (mode 14) + integer, intent(out) :: ifbcbgn1(pcols,pver) + real(r8), intent(out) :: xct(pcols,pver,nmodes) ! Cam/Nnatk for use in the interpolations + integer, intent(out) :: ict1(pcols,pver,nmodes) + real(r8), intent(out) :: xfac(pcols,pver,nbmodes) ! focm (1-4) or fcm (5-10) for use in the interpolations + integer, intent(out) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(out) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations + integer, intent(out) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(out) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations + integer, intent(out) :: ifaq1(pcols,pver,nbmodes) + ! + ! Local variables + integer k, icol, i, irelh + real(r8) :: eps10 = 1.e-10_r8 + !------------------------------------------------------------------------ + ! + ! write(*,*) 'Before xrh-loop' + do k=1,pver + do icol=1,ncol + xrh(icol,k) = min(max(rhum(icol,k),rh(1)),rh(10)) + end do + end do + + ! write(*,*) 'Before rh-loop' + do irelh=1,9 + do k=1,pver + do icol=1,ncol + if(xrh(icol,k) >= rh(irelh) .and. xrh(icol,k)<=rh(irelh+1)) then + irh1(icol,k)=irelh + endif + end do + end do + end do + ! write(*,*) 'xrh, irh1, irh2 =', xrh(1,26), irh1(1,26), irh2(1,26) + + do k=1,pver + do icol=1,ncol + ! find common xfombg, ifombg1 and ifombg2 for use in the interpolation routines + xfombg(icol,k) =min(max(f_soana(icol,k),fombg(1)),fombg(6)) + ifombg1(icol,k)=int(5.0_r8*xfombg(icol,k)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + + do k=1,pver + do icol=1,ncol + ! find common xfbcbg, ifbcbg1 and ifbcbg2 for use in the interpolation routines + xfbcbg(icol,k) =min(max(faitbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 + ifbcbg1(icol,k)=min(max(int(4*log10(xfbcbg(icol,k))+6),1),5) + + ! find common xfbcbgn, ifbcbgn1 and ifbcbgn2 for use in the interpolation routines + xfbcbgn(icol,k) =min(max(fnbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 + ifbcbgn1(icol,k)=min(max(int(4*log10(xfbcbgn(icol,k))+6),1),5) + end do + enddo + + do i=1,4 + do k=1,pver + do icol=1,ncol + ! find common xfac, ifac1 and ifac2 for use in the interpolation routines + xfac(icol,k,i) =min(max(focm(icol,k,i),fac(1)),fac(6)) + ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + enddo + do i=5,nbmodes + do k=1,pver + do icol=1,ncol + ! find common xfac, ifac1 and ifac2 for use in the interpolation routines + xfac(icol,k,i) =min(max(fcm(icol,k,i),fac(1)),fac(6)) + ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + enddo + + do i=1,nbmodes + do k=1,pver + do icol=1,ncol + ! find common xfbc, ifbc1 and ifbc2 for use in the interpolation routines + xfbc(icol,k,i) =min(max(fbcm(icol,k,i),fbc(1)),fbc(6)) ! Boer linkes til def. i opttab.F90 + ifbc1(icol,k,i)=min(max(int(4*log10(xfbc(icol,k,i))+6),1),5) + end do + enddo + enddo + + do i=1,nbmodes + do k=1,pver + do icol=1,ncol + ! find common xfaq, ifaq1 and ifaq2 for use in the interpolation routines + xfaq(icol,k,i) =min(max(faqm(icol,k,i),faq(1)),faq(6)) + ifaq1(icol,k,i)=int(5.0_r8*xfaq(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + end do + enddo + enddo + + ! find common xct, ict1 and ict2 for use in the interpolation routines ! Boer linkes til def. i opttab.F90 + do i=1,4 + do k=1,pver + do icol=1,ncol + xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cate(i,1)),cate(i,16)) + if(i.le.2) then + ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+19.666_r8),1),15) + elseif(i.eq.3) then ! mode not used + xct(icol,k,i)=cate(i,1) + ict1(icol,k,i)=1 + else + ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+13.903_r8),1),15) + endif + end do + end do + end do + + do i=5,10 + do k=1,pver + do icol=1,ncol + xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cat(i,1)),cat(i,6)) + if(i.eq.5) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.824_r8),1),5) + elseif(i.eq.6) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.523_r8),1),5) + elseif(i.eq.7) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) + elseif(i.eq.8) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+5.921_r8),1),5) + elseif(i.eq.9) then + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.301_r8),1),5) + else + ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) + endif + end do + end do + end do + + do i=11,nmodes ! for the externally mixed modes 11-14 (now only 12 and 14) + do k=1,pver + do icol=1,ncol + xct(icol,k,i)=cate(i-10,1) + ict1(icol,k,i)=1 + end do + end do + end do + + return + + end subroutine inputForInterpol + + !******************************************************************************************** + subroutine interpol0 (lchnk, ncol, daylight, Nnatk, omega, gass, bex, ske, lw_on, kabs) + ! + ! Arguments + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns + logical , intent(in) :: daylight(pcols) ! calculations also at (polar) night if daylight=.true. + logical , intent(in) :: lw_on ! LW calculations are performed if true + real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8) , intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8) , intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8) , intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8) , intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8) , intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands) ! LW spectral modal specific absorption coefficient + ! + ! Local variables + integer i, kcomp, k, icol + !--------------------------------------- + + kcomp=0 + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kcomp,i)=0.0_r8 + gass(icol,k,kcomp,i)=0.0_r8 + bex(icol,k,kcomp,i)=0.0_r8 + ske(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do + + ! SW optical parameters + + do k=1,pver + do icol=1,ncol + ! if(Nnatk(icol,k,kcomp)>0.0_r8) then + if(daylight(icol)) then + do i=1,nbands ! i = wavelength index + omega(icol,k,kcomp,i)=om0(i) + gass(icol,k,kcomp,i)=g0(i) + bex(icol,k,kcomp,i)=be0(i) + ske(icol,k,kcomp,i)=ke0(i) + end do ! i + else ! daylight + ! Need be and ke in nband=4 for lw calculation + bex(icol,k,kcomp,4)=be0(4) + ske(icol,k,kcomp,4)=ke0(4) + end if ! daylight + end do ! icol + end do ! k + + ! LW optical parameters + + if(lw_on) then + do k=1,pver + do icol=1,ncol + do i=1,nlwbands ! i = wavelength index + kabs(icol,k,kcomp,i)=ka0(i) + end do ! i + end do ! icol + end do ! k + + endif ! lw_on + + end subroutine interpol0 + + !******************************************************************************************** + subroutine interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfombg, ifombg1, & + xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) + + ! + ! Arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absoption coefficient + ! + ! Local variables + integer i, kcomp, k, icol, kc10 + real(r8) a, b + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifo1, t_ifo2 + real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2 + real(r8) t_cat1, t_cat2, t_fombg1, t_fombg2, t_xfombg + real(r8) d2mx(4), dxm1(4), invd(4) + real(r8) opt4d(2,2,2,2) + real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) kabs1, kabs2 + !--------------------------------------- + + ! write(*,*) 'Before kcomp-loop' + do kcomp=1,1 + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + ! write(*,*) 'Before init-loop', kc10 + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kc10,i)=0.0_r8 + gass(icol,k,kc10,i)=0.0_r8 + bex(icol,k,kc10,i)=0.0_r8 + ske(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + + do k=1,pver + do icol=1,ncol + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifo1 = ifombg1(icol,k) + t_ifo2 = t_ifo1+1 + + t_rh1 = rh(t_irh1) + !x t_rh2 = t_rh1+1 + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fombg1 = fombg(t_ifo1) + t_fombg2 = fombg(t_ifo2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfombg = xfombg(icol,k) + + ! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fombg2-t_xfombg) + dxm1(2) = (t_xfombg-t_fombg1) + invd(2) = 1.0_r8/(t_fombg2-t_fombg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + + + ! SW optical parameters + if(daylight(icol)) then + + do i=1,nbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! single scattering albedo: + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, ome1, ome2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before omega' + omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) /(t_rh2-t_rh1) + !alt omega(icol,k,kc10,i)=(d2mx(1)*ome1+dxm1(1)*ome2)*invd(1) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! asymmetry factor + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, ge1, ge2) + + ! finally, interpolation in the rh dimension (dim. 1) + ! write(*,*) 'Before gass' + gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) /(t_rh2-t_rh1) + !alt gass(icol,k,kc10,i)=(d2mx(1)*ge1+dxm1(1)*ge2)*invd(1) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) /(t_rh2-t_rh1) + !alt bex(icol,k,kc10,i)=(d2mx(1)*bex1+dxm1(1)*bex2)*invd(1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + !alt a=(log(bex2)-log(bex1))*invd(1) + !alt b=(t_rh2*log(bex1)-t_rh1*log(bex2))*invd(1) + !alt bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + ! if(bex(icol,k,kc10,8)<1.e-20_r8) then + ! write(*,995) 'bex(8)=', kc10, t_xrh, t_xct, t_xfac, t_xfombg, bex(icol,k,kc10,8) + ! endif + else ! daylight + + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction used for size information in LW + + i=4 + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + do i=4,4 ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific extinction + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, ske1, ske2) + + ske1=max(ske1,1.e-30_r8) + ske2=max(ske2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before ske' + if(t_xrh <= 0.37_r8) then + ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + !alt ske(icol,k,kc10,i)=(d2mx(1)*ske1+dxm1(1)*ske2)*invd(1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kc10,i)=e**(a*t_xrh+b) + !alt a=(log(ske2)-log(ske1))*invd(1) + !alt b=(t_rh2*log(ske1)-t_rh1*log(ske2))*invd(1) + !alt ske(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + if (lw_on) then + + ! LW optical parameters + do i=1,nlwbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific absorption in LW + + ! end points as basis for multidimentional linear interpolation + opt4d(1,1,1,1)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) + opt4d(1,1,1,2)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) + opt4d(1,1,2,1)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) + opt4d(1,1,2,2)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) + opt4d(1,2,1,1)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) + opt4d(1,2,1,2)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) + opt4d(1,2,2,1)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) + opt4d(1,2,2,2)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) + opt4d(2,1,1,1)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) + opt4d(2,1,1,2)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) + opt4d(2,1,2,1)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) + opt4d(2,1,2,2)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) + opt4d(2,2,1,1)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) + opt4d(2,2,1,2)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) + opt4d(2,2,2,1)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) + opt4d(2,2,2,2)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) + + ! interpolation in the fac, cat and fombg dimensions + call lininterpol4dim (d2mx, dxm1, invd, opt4d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30) + kabs2=max(kabs2,1.e-30) + + ! write(*,*) 'Before kabs' + if(t_xrh <= 0.37) then + kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on + + end do ! icol + end do ! k + + ! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) + ! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) + ! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) + ! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) + + end do ! kcomp + + return + end subroutine interpol1 + + + !******************************************************************************************** + subroutine interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, & + xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) + + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + + ! Output arguments + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient + ! + ! Local variables + integer i, kcomp, k, icol, kc10 + real(r8) a, b + integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 + real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2,t_cat1, t_cat2 + real(r8) d2mx(3), dxm1(3), invd(3) + real(r8) opt3d(2,2,2) + real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) kabs1, kabs2 + !--------------------------------------- + + ! write(*,*) 'Before kcomp-loop' + ! do kcomp=2,3 + do kcomp=2,2 + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + ! write(*,*) 'Before init-loop', kc10 + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kc10,i)=0.0_r8 + gass(icol,k,kc10,i)=0.0_r8 + bex(icol,k,kc10,i)=0.0_r8 + ske(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + + do k=1,pver + do icol=1,ncol + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + ! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 + ! write(*,*) 't_ict1,t_ict2=',t_ict1,t_ict2 + ! write(*,*) 't_ifc1,t_ifc2=',t_ifc1,t_ifc2 + ! write(*,*) 't_ifa1,t_ifa2=',t_ifa1,t_ifa2 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + + ! write(*,*) 't_rh1,t_rh2,t_cat1,t_cat2=',t_rh1,t_rh2,t_cat1,t_cat2 + ! write(*,*) 't_fac1,t_fac2=',t_fac1,t_fac2 + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + + ! partial lengths along each dimension (1-4) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + + + ! SW optical parameters + if(daylight(icol)) then + + do i=1,nbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! single scattering albedo: + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=om2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=om2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=om2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=om2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=om2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=om2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=om2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=om2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, ome1, ome2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before omega' + omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & + /(t_rh2-t_rh1) + ! write(*,*) omega(icol,k,kc10,i) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! asymmetry factor + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=g2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=g2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=g2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=g2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=g2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=g2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=g2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=g2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, ge1, ge2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before gass' + gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) + ! write(*,*) gass(icol,k,kc10,i) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) + + bex1=max(bex1,1.e-30) + bex2=max(bex2,1.e-30) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + else ! daylight + + + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction used for LW size information + + i=4 + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) + + bex1=max(bex1,1.e-30) + bex2=max(bex2,1.e-30) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + + + do i=4,4 ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific extinction + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=ke2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=ke2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=ke2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=ke2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=ke2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=ke2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=ke2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=ke2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, ske1, ske2) + + ske1=max(ske1,1.e-30) + ske2=max(ske2,1.e-30) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before ske' + if(t_xrh <= 0.37) then + ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + + ! LW optical parameters + do i=1,nlwbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific absorption in LW + + ! end points as basis for multidimentional linear interpolation + opt3d(1,1,1)=ka2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) + opt3d(1,1,2)=ka2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) + opt3d(1,2,1)=ka2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) + opt3d(1,2,2)=ka2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) + opt3d(2,1,1)=ka2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) + opt3d(2,1,2)=ka2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) + opt3d(2,2,1)=ka2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) + opt3d(2,2,2)=ka2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) + + ! interpolation in the (fac and) cat dimension + call lininterpol3dim (d2mx, dxm1, invd, opt3d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30_r8) + kabs2=max(kabs2,1.e-30_r8) + + ! write(*,*) 'Before kabs' + if(t_xrh <= 0.37_r8) then + kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on + + end do ! icol + end do ! k + + ! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) + ! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) + ! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) + ! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) + + end do ! kcomp + + return + end subroutine interpol2to3 + + !******************************************************************************************** + + subroutine interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfbcbg, ifbcbg1, & + xct, ict1, xfac, ifac1, xfaq, ifaq1, & + omega, gass, bex, ske, lw_on, kabs) + + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode + integer, intent(in) :: ifbcbg1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + + ! Output arguments + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient + ! + ! Local variables + integer :: i, kcomp, k, kc10, icol + real(r8) :: a, b + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2, t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) :: t_faq1, t_faq2, t_xfaq, t_fbcbg1, t_fbcbg2, t_xfbcbg, t_fac1 + real(r8) :: t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) :: kabs1, kabs2 + !--------------------------------------- + + ! write(*,*) 'Before kcomp-loop' + do kcomp=4,4 + + if(mplus10==0) then + kc10=kcomp + else + kc10=kcomp+10 + endif + + ! write(*,*) 'Before init-loop', kc10 + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kc10,i)=0.0_r8 + gass(icol,k,kc10,i)=0.0_r8 + bex(icol,k,kc10,i)=0.0_r8 + ske(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kc10,i)=0.0_r8 + end do + end do + end do + + do k=1,pver + do icol=1,ncol + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kc10) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + t_ifb1 = ifbcbg1(icol,k) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cate(kcomp,t_ict1) + t_cat2 = cate(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbcbg1 = fbcbg(t_ifb1) + t_fbcbg2 = fbcbg(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kc10) + t_xfac = xfac(icol,k,kcomp) + t_xfbcbg = xfbcbg(icol,k) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_fbcbg2-t_xfbcbg) + dxm1(2) = (t_xfbcbg-t_fbcbg1) + invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) + d2mx(3) = (t_cat2-t_xct) + dxm1(3) = (t_xct-t_cat1) + invd(3) = 1.0_r8/(t_cat2-t_cat1) + d2mx(4) = (t_fac2-t_xfac) + dxm1(4) = (t_xfac-t_fac1) + invd(4) = 1.0_r8/(t_fac2-t_fac1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + ! SW optical parameters + if(daylight(icol)) then + + do i=1,nbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! single scattering albedo: + + opt5d(1,1,1,1,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before omega' + omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) /(t_rh2-t_rh1) + ! write(*,*) omega(icol,k,kc10,i) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! asymmetry factor + + opt5d(1,1,1,1,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before gass' + gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction + + opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + else ! daylight + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction called for use in size estimate for use in LW + i=4 + + opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + do i=4,4 ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific extinction + + opt5d(1,1,1,1,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) + + ske1=max(ske1,1.e-30_r8) + ske2=max(ske2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before ske' + if(t_xrh <= 0.37_r8) then + ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + + ! LW optical parameters + + do i=1,nlwbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific absorption + + opt5d(1,1,1,1,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(1,1,1,1,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(1,1,1,2,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(1,1,1,2,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(1,1,2,1,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(1,1,2,1,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(1,1,2,2,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(1,1,2,2,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(1,2,1,1,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(1,2,1,1,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(1,2,1,2,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(1,2,1,2,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(1,2,2,1,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(1,2,2,1,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(1,2,2,2,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(1,2,2,2,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) + opt5d(2,1,1,1,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) + opt5d(2,1,1,1,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) + opt5d(2,1,1,2,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) + opt5d(2,1,1,2,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) + opt5d(2,1,2,1,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) + opt5d(2,1,2,1,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) + opt5d(2,1,2,2,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) + opt5d(2,1,2,2,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) + opt5d(2,2,1,1,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) + opt5d(2,2,1,1,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) + opt5d(2,2,1,2,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) + opt5d(2,2,1,2,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) + opt5d(2,2,2,1,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) + opt5d(2,2,2,1,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) + opt5d(2,2,2,2,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) + opt5d(2,2,2,2,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) + + ! interpolation in the faq, fac, cat and fbcbg dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30_r8) + kabs2=max(kabs2,1.e-30_r8) + + ! write(*,*) 'Before kabs' + if(t_xrh <= 0.37_r8) then + kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kc10,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on + + end do ! icol + end do ! k + + ! write(*,*) 'kcomp, omega(1,26,kc10,4)=', kcomp, omega(1,26,kc10,4) + ! write(*,*) 'kcomp, gass(1,26,kc10,4)=', kcomp, gass(1,26,kc10,4) + ! write(*,*) 'kcomp, bex(1,26,kc10,4)=', kcomp, bex(1,26,kc10,4) + ! write(*,*) 'kcomp, ske(1,26,kc10,4)=', kcomp, ske(1,26,kc10,4) + + end do ! kcomp + + end subroutine interpol4 + + !******************************************************************************************** + subroutine interpol5to10 (lchnk, ncol, daylight, xrh, irh1, Nnatk, xct, ict1, & + xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & + omega, gass, bex, ske, lw_on, kabs) + + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. + logical, intent(in) :: lw_on ! LW calculations are performed if true + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) + integer, intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + + ! Output arguments + real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo + real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor + real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient + real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient + real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient + + ! Local variables + integer :: i, kcomp, k, icol + real(r8) :: a, b + integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 + integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 + real(r8) :: t_faq1, t_faq2, t_xfaq, t_fbc1, t_fbc2, t_xfbc, t_fac1 + real(r8) :: t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 + real(r8) :: d2mx(5), dxm1(5), invd(5) + real(r8) :: opt5d(2,2,2,2,2) + real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 + real(r8) :: kabs1, kabs2 + !--------------------------------------- + + ! write(*,*) 'Before kcomp-loop' + do kcomp=5,10 + + ! write(*,*) 'Before init-loop', kcomp + do i=1,nbands + do icol=1,ncol + do k=1,pver + omega(icol,k,kcomp,i)=0.0_r8 + gass(icol,k,kcomp,i)=0.0_r8 + bex(icol,k,kcomp,i)=0.0_r8 + ske(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do + do i=1,nlwbands + do icol=1,ncol + do k=1,pver + kabs(icol,k,kcomp,i)=0.0_r8 + end do + end do + end do + + do k=1,pver + do icol=1,ncol + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = t_irh1+1 + t_ict1 = ict1(icol,k,kcomp) + t_ict2 = t_ict1+1 + t_ifc1 = ifac1(icol,k,kcomp) + t_ifc2 = t_ifc1+1 + + t_ifb1 = ifbc1(icol,k,kcomp) + t_ifb2 = t_ifb1+1 + t_ifa1 = ifaq1(icol,k,kcomp) + t_ifa2 = t_ifa1+1 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + t_cat1 = cat(kcomp,t_ict1) + t_cat2 = cat(kcomp,t_ict2) + t_fac1 = fac(t_ifc1) + t_fac2 = fac(t_ifc2) + t_fbc1 = fbc(t_ifb1) + t_fbc2 = fbc(t_ifb2) + t_faq1 = faq(t_ifa1) + t_faq2 = faq(t_ifa2) + + t_xrh = xrh(icol,k) + t_xct = xct(icol,k,kcomp) + t_xfac = xfac(icol,k,kcomp) + t_xfbc = xfbc(icol,k,kcomp) + t_xfaq = xfaq(icol,k,kcomp) + + ! partial lengths along each dimension (1-5) for interpolation + d2mx(1) = (t_rh2-t_xrh) + dxm1(1) = (t_xrh-t_rh1) + invd(1) = 1.0_r8/(t_rh2-t_rh1) + d2mx(2) = (t_cat2-t_xct) + dxm1(2) = (t_xct-t_cat1) + invd(2) = 1.0_r8/(t_cat2-t_cat1) + d2mx(3) = (t_fac2-t_xfac) + dxm1(3) = (t_xfac-t_fac1) + invd(3) = 1.0_r8/(t_fac2-t_fac1) + d2mx(4) = (t_fbc2-t_xfbc) + dxm1(4) = (t_xfbc-t_fbc1) + invd(4) = 1.0_r8/(t_fbc2-t_fbc1) + d2mx(5) = (t_faq2-t_xfaq) + dxm1(5) = (t_xfaq-t_faq1) + invd(5) = 1.0_r8/(t_faq2-t_faq1) + + + ! SW optical parameters + if(daylight(icol)) then + + do i=1,nbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! single scattering albedo: + + opt5d(1,1,1,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before omega' + omega(icol,k,kcomp,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & + /(t_rh2-t_rh1) + ! write(*,*) omega(icol,k,kcomp,i) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! asymmetry factor + + opt5d(1,1,1,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before gass' + gass(icol,k,kcomp,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & + /(t_rh2-t_rh1) + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction + + opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + end do ! i + else ! daylight + + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol extinction used for aerosol size estimate needed for LW calculations + i=4 + opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) + + bex1=max(bex1,1.e-30_r8) + bex2=max(bex2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before bex' + if(t_xrh <= 0.37_r8) then + bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & + /(t_rh2-t_rh1) + else + a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) + b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) + bex(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + endif ! daylight + + + + do i=4,4 ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific extinction + + opt5d(1,1,1,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) + + ske1=max(ske1,1.e-30_r8) + ske2=max(ske2,1.e-30_r8) + + ! finally, interpolation in the rh dimension + ! write(*,*) 'Before ske' + if(t_xrh <= 0.37_r8) then + ske(icol,k,kcomp,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & + /(t_rh2-t_rh1) + else + a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) + b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) + ske(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + end do ! i + + + + if (lw_on) then + + ! LW optical parameters + + do i=1,nlwbands ! i = wavelength index + + !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc + ! aerosol specific absorption + + opt5d(1,1,1,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,1,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,1,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,1,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,1,2,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,1,2,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,1,2,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,1,2,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,1,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,1,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,1,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,1,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(1,2,2,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(1,2,2,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(1,2,2,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(1,2,2,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,1,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,1,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,1,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,1,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,1,2,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,1,2,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,1,2,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,1,2,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,1,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,1,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,1,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,1,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) + opt5d(2,2,2,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) + opt5d(2,2,2,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) + opt5d(2,2,2,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) + opt5d(2,2,2,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) + + ! interpolation in the faq, fbc, fac and cat dimensions + call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) + + kabs1=max(kabs1,1.e-30_r8) + kabs2=max(kabs2,1.e-30_r8) + + ! write(*,*) 'Before kabs' + if(t_xrh <= 0.37_r8) then + kabs(icol,k,kcomp,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & + /(t_rh2-t_rh1) + else + a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) + b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) + kabs(icol,k,kcomp,i)=e**(a*t_xrh+b) + endif + + end do ! i + + endif ! lw_on + + end do ! icol + end do ! k + end do ! kcomp + + end subroutine interpol5to10 + end module opttab diff --git a/src/physics/cam_oslo/pmxsub.F90 b/src/physics/cam_oslo/pmxsub.F90 index 9d6b40d27b..b049619e2b 100644 --- a/src/physics/cam_oslo/pmxsub.F90 +++ b/src/physics/cam_oslo/pmxsub.F90 @@ -42,12 +42,10 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & use const use aerosoldef use commondefinitions - use optinterpol, only: interpol0,interpol1,interpol2to3,interpol4,interpol5to10 use physics_types, only: physics_state use wv_saturation, only: qsat_water use aeroopt_mod, only: extinction_coeffs, extinction_coeffsn use aerodry_mod, only: aerodry_prop - use optinterpol, only: inputForInterpol ! ! Input arguments From 836f2f7242edbd4119993b7caeaf0e27b05ec62b Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 17 Aug 2023 13:18:20 +0200 Subject: [PATCH 13/71] updates for creating new aerocom module --- src/chemistry/oslo_aero/aero_model.F90 | 10 +- src/physics/cam_oslo/opticsAtConstRh.F90 | 324 --- src/physics/cam_oslo/pmxsub.F90 | 1919 ++------------ src/physics/cam_oslo/radiation.F90 | 2979 +++++++++++----------- 4 files changed, 1662 insertions(+), 3570 deletions(-) delete mode 100644 src/physics/cam_oslo/opticsAtConstRh.F90 diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 825937ff0a..aa22b36f69 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -103,12 +103,6 @@ module aero_model logical :: convproc_do_aer -#ifdef AEROCOM - logical :: do_aerocom = .true. -#else - logical :: do_aerocom = .false. -#endif - contains !============================================================================= @@ -237,10 +231,10 @@ subroutine aero_model_init( pbuf2d ) call initopt call initlogn call initopt_lw - if (do_aerocom) then +#ifdef AEROCOM call initaeropt() call initdryp() - end if +#endif call initializeCondensation() call oslo_ocean_init() diff --git a/src/physics/cam_oslo/opticsAtConstRh.F90 b/src/physics/cam_oslo/opticsAtConstRh.F90 deleted file mode 100644 index 1ed207c2be..0000000000 --- a/src/physics/cam_oslo/opticsAtConstRh.F90 +++ /dev/null @@ -1,324 +0,0 @@ - -subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbc, vaitbc, v_soana) - - ! Extra AeroCom diagnostics requiring table look-ups with constant/fixed RH, - ! i.e. for RH = (/"00","40","55","65","75","85" /) (see opttab.F90) - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_history, only: outfld - use constituents, only: pcnst - use opttab - use const - use aerosoldef - use commondefinitions - use physics_types, only: physics_state - use aeroopt_mod, only : extinction_coeffs, extinction_coeffsn - - implicit none - ! - ! Input arguments - ! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) - real(r8), intent(in) :: rhoda(pcols,pver) ! Density of dry air (kg/m^3) - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - integer, intent(in) :: irf - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbcbg(pcols,pver) - integer, intent(in) :: ifbcbg1(pcols,pver) - real(r8), intent(in) :: xfbcbgn(pcols,pver) - integer, intent(in) :: ifbcbgn1(pcols,pver) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! facm for use in the interpolations - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations - integer, intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfombg(pcols,pver) - integer, intent(in) :: ifombg1(pcols,pver) - real(r8), intent(in) :: vnbc(pcols,pver) - real(r8), intent(in) :: vaitbc(pcols,pver) - real(r8), intent(in) :: v_soana(pcols,pver) - ! - ! Local variables - ! - integer :: i, k, icol, mplus10, irh - integer :: iloop - real(r8) :: deltah - real(r8) :: dod550rh(pcols), abs550rh(pcols) - real(r8) :: ec550rh_aer(pcols,pver) - real(r8) :: abs550rh_aer(pcols,pver) - real(r8) :: bebglt1t(pcols,pver) - real(r8) :: bebclt1t(pcols,pver) - real(r8) :: beoclt1t(pcols,pver) - real(r8) :: bes4lt1t(pcols,pver) - real(r8) :: basu550tot(pcols,pver) - real(r8) :: babc550tot(pcols,pver) - real(r8) :: baoc550tot(pcols,pver) - real(r8) :: babc550xt(pcols,pver) - real(r8) :: baoc550xt(pcols,pver) - real(r8) :: ba550x(pcols,pver,nbmp1:nmodes) - real(r8) :: belt1x(pcols,pver,nbmp1:nmodes) - - ! Additionl AeroCom Phase III output: - real(r8) :: ec440rh_aer(pcols,pver) - real(r8) :: abs440rh_aer(pcols,pver) - real(r8) :: ec870rh_aer(pcols,pver) - real(r8) :: abs870rh_aer(pcols,pver) - real(r8) :: be550lt1_aer(pcols,pver,0:nbmodes) - real(r8) :: ec550rhlt1_aer(pcols,pver) - real(r8) :: abs550rh_bc(pcols,pver) - real(r8) :: abs550rh_oc(pcols,pver) - real(r8) :: abs550rh_su(pcols,pver) - real(r8) :: abs550rh_ss(pcols,pver) - real(r8) :: abs550rh_du(pcols,pver) - real(r8) :: ec550rhlt1_bc(pcols,pver) - real(r8) :: ec550rhlt1_oc(pcols,pver) - real(r8) :: ec550rhlt1_su(pcols,pver) - real(r8) :: ec550rhlt1_ss(pcols,pver) - real(r8) :: ec550rhlt1_du(pcols,pver) - real(r8) :: bedustlt1(pcols,pver) - real(r8) :: bedustgt1(pcols,pver) - real(r8) :: besslt1(pcols,pver) - real(r8) :: bessgt1(pcols,pver) - real(r8) :: bbclt1xt(pcols,pver) - real(r8) :: boclt1xt(pcols,pver) - real(r8) :: bocgt1xt(pcols,pver) - - character(len=10) :: modeString - character(len=20) :: varname - !-------------------------------------------------- - - belt1x(:,:,:) = 0._r8 - - do iloop=1,1 - - ! BC(ax) mode (hydrophobic, so no rhum needed here): - call extinction_coeffs%intaeropt0(lchnk, ncol, Nnatk) - - ! SO4(Ait), BC(Ait) and OC(Ait) modes: - mplus10=0 - call extinction_coeffs%intaeropt1(lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) - - mplus10=0 - call extinction_coeffs%intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1) - - ! BC&OC(Ait) (4), OC&BC(Ait) mode - mplus10=0 - call extinction_coeffs%intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1) - - ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call extinction_coeffs%intaeropt5to10(lchnk, ncol, xrh, irh1, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) - - ! then to the externally mixed SO4(n), BC(n) and OC(n) modes: - mplus10=1 - call extinction_coeffsn%intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1) - - ! and finally the BC&OC(n) mode: - mplus10=1 - call extinction_coeffsn%intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbgn, ifbcbgn1, xct, ict1, xfac, ifac1, xfaq, ifaq1) - - end do ! iloop - - - ! Initialization - do k=1,pver - do icol=1,ncol - ec550rh_aer(icol,k) = 0.0_r8 - abs550rh_aer(icol,k) = 0.0_r8 - ec550rhlt1_aer(icol,k) = 0.0_r8 - abs550rh_bc(icol,k) = 0.0_r8 - abs550rh_oc(icol,k) = 0.0_r8 - abs550rh_su(icol,k) = 0.0_r8 - abs550rh_ss(icol,k) = 0.0_r8 - abs550rh_du(icol,k) = 0.0_r8 - ec440rh_aer(icol,k) = 0.0_r8 - abs440rh_aer(icol,k) = 0.0_r8 - ec870rh_aer(icol,k) = 0.0_r8 - abs870rh_aer(icol,k) = 0.0_r8 - basu550tot(icol,k) = 0.0_r8 - babc550tot(icol,k) = 0.0_r8 - baoc550tot(icol,k) = 0.0_r8 - bebglt1t(icol,k) = 0.0_r8 - bebclt1t(icol,k) = 0.0_r8 - beoclt1t(icol,k) = 0.0_r8 - bes4lt1t(icol,k) = 0.0_r8 - bedustlt1(icol,k) = 0.0_r8 - besslt1(icol,k) = 0.0_r8 - end do - end do - do icol=1,ncol - dod550rh(icol) = 0.0_r8 - abs550rh(icol) = 0.0_r8 - end do - - ! Calculation of extinction at given RH and absorption for all r and for r<0.5um - do k=1,pver - do icol=1,ncol - - do i=0,10 - ec550rh_aer(icol,k) = ec550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext550(icol,k,i) - abs550rh_aer(icol,k) = abs550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i) - ec440rh_aer(icol,k) = ec440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext440(icol,k,i) - abs440rh_aer(icol,k) = abs440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i) - ec870rh_aer(icol,k) = ec870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext870(icol,k,i) - abs870rh_aer(icol,k) = abs870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i) - basu550tot(icol,k) = basu550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%basu550(icol,k,i) - babc550tot(icol,k) = babc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babc550(icol,k,i) - baoc550tot(icol,k) = baoc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%baoc550(icol,k,i) - bes4lt1t(icol,k) = bes4lt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%besu550lt1(icol,k,i) - bebclt1t(icol,k) = bebclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebc550lt1(icol,k,i) - beoclt1t(icol,k) = beoclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%beoc550lt1(icol,k,i) - enddo - do i=11,14 - ec550rh_aer(icol,k) = ec550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext550(icol,k,i-10) - abs550rh_aer(icol,k) = abs550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs550(icol,k,i-10) - ec440rh_aer(icol,k) = ec440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext440(icol,k,i-10) - abs440rh_aer(icol,k) = abs440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs440(icol,k,i-10) - ec870rh_aer(icol,k) = ec870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext870(icol,k,i-10) - abs870rh_aer(icol,k) = abs870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs870(icol,k,i-10) - ba550x(icol,k,i) = extinction_coeffsn%babs550(icol,k,i-10) - belt1x(icol,k,i) = extinction_coeffs%bebg550lt1(icol,k,i-10) !??? - enddo - do i=6,7 - bedustlt1(icol,k) = bedustlt1(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebg550lt1(icol,k,i) - enddo - do i=8,10 - besslt1(icol,k) = besslt1(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebg550lt1(icol,k,i) - enddo - ec550rhlt1_du(icol,k) = bedustlt1(icol,k) - ec550rhlt1_ss(icol,k) = besslt1(icol,k) - - !soa: *(1-v_soan) for the sulfate volume fraction of mode 11 - bbclt1xt(icol,k) = Nnatk(icol,k,12)*belt1x(icol,k,12) & - + Nnatk(icol,k,14)*belt1x(icol,k,14)*vnbc(icol,k) - !soa + v_soan part of mode 11 for the OC volume fraction of that mode - boclt1xt(icol,k) = Nnatk(icol,k,13)*belt1x(icol,k,13) & - + Nnatk(icol,k,14)*belt1x(icol,k,14)*(1.0_r8-vnbc(icol,k)) - - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - ec550rhlt1_su(icol,k) = bes4lt1t(icol,k) & ! condensate - + Nnatk(icol,k,1)*extinction_coeffs%bebg550lt1(icol,k,1)*(1.0_r8-v_soana(icol,k))& ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg550lt1(icol,k,5) ! background, SO4(Ait75) mode (5) - ec550rhlt1_bc(icol,k) = bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg550lt1(icol,k,2) & ! background, BC(Ait) mode (2) - + Nnatk(icol,k,4)*extinction_coeffs%bebg550lt1(icol,k,4)*vaitbc(icol,k) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg550lt1(icol,k,0) ! background, BC(ax) mode (0) - - !soa + v_soan part of mode 11 for the OC volume fraction of that mode - ec550rhlt1_oc(icol,k) = beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC (13) - + Nnatk(icol,k,3)*extinction_coeffs%bebg550lt1(icol,k,3) & ! background, OC(Ait) mode (3) - + Nnatk(icol,k,4)*extinction_coeffs%bebg550lt1(icol,k,4)*(1.0_r8-vaitbc(icol,k))& ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,1)*extinction_coeffs%bebg550lt1(icol,k,1)*v_soana(icol,k) - - ec550rhlt1_aer(icol,k) = ec550rhlt1_su(icol,k)+ec550rhlt1_bc(icol,k) & - + ec550rhlt1_oc(icol,k) + ec550rhlt1_ss(icol,k)+ec550rhlt1_du(icol,k) - ec550rhlt1_aer(icol,k) = 1.e-3_r8*ec550rhlt1_aer(icol,k) - - abs550rh_du(icol,k) = Nnatk(icol,k,6)*extinction_coeffs%babg550(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%babg550(icol,k,7) - abs550rh_ss(icol,k) = Nnatk(icol,k,8)*extinction_coeffs%babg550(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%babg550(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%babg550(icol,k,10) - - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - abs550rh_su(icol,k) = basu550tot(icol,k) & ! condensate:w - + (1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%babg550(icol,k,5) ! background, SO4(Ait75) mode (5) - - !soa: *(1-v_soan) for the sulfate volume fraction - babc550xt(icol,k) = Nnatk(icol,k,12)*ba550x(icol,k,12) & - + Nnatk(icol,k,14)*ba550x(icol,k,14)*vnbc(icol,k) - - baoc550xt(icol,k) = Nnatk(icol,k,13)*ba550x(icol,k,13) & - + Nnatk(icol,k,14)*ba550x(icol,k,14)*(1.0_r8-vnbc(icol,k)) - - abs550rh_bc(icol,k) = babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%babg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc(icol,k)*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%babg550(icol,k,0) ! background, BC(ax) mode (0) - - abs550rh_oc(icol,k) = baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC (13) - + v_soana(icol,k)*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! SOA fraction of mode 1 - + Nnatk(icol,k,3)*extinction_coeffs%babg550(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc(icol,k))*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) ! background in OC&BC(Ait) mode (4) - - deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) - dod550rh(icol) = dod550rh(icol)+ec550rh_aer(icol,k)*deltah - abs550rh(icol) = abs550rh(icol)+abs550rh_aer(icol,k)*deltah - - ec550rh_aer(icol,k) = 1.e-3_r8*ec550rh_aer(icol,k) - abs550rh_aer(icol,k) = 1.e-3_r8*abs550rh_aer(icol,k) - ec440rh_aer(icol,k) = 1.e-3_r8*ec440rh_aer(icol,k) - abs440rh_aer(icol,k) = 1.e-3_r8*abs440rh_aer(icol,k) - ec870rh_aer(icol,k) = 1.e-3_r8*ec870rh_aer(icol,k) - abs870rh_aer(icol,k) = 1.e-3_r8*abs870rh_aer(icol,k) - - abs550rh_bc(icol,k) = 1.e-3_r8*abs550rh_bc(icol,k) - abs550rh_oc(icol,k) = 1.e-3_r8*abs550rh_oc(icol,k) - abs550rh_su(icol,k) = 1.e-3_r8*abs550rh_su(icol,k) - abs550rh_ss(icol,k) = 1.e-3_r8*abs550rh_ss(icol,k) - abs550rh_du(icol,k) = 1.e-3_r8*abs550rh_du(icol,k) - - enddo - enddo - - if(irf.eq.1) then - - call outfld('ECDRYAER',ec550rh_aer,pcols,lchnk) - call outfld('ABSDRYAE',abs550rh_aer,pcols,lchnk) - call outfld('OD550DRY',dod550rh,pcols,lchnk) ! 2D variable - call outfld('AB550DRY',abs550rh,pcols,lchnk) ! 2D variable - call outfld('ECDRY440',ec440rh_aer,pcols,lchnk) - call outfld('ABSDR440',abs440rh_aer,pcols,lchnk) - call outfld('ECDRY870',ec870rh_aer,pcols,lchnk) - call outfld('ABSDR870',abs870rh_aer,pcols,lchnk) - call outfld('ECDRYLT1',ec550rhlt1_aer,pcols,lchnk) - ! Since we do not have enough look-up table info to take abs550rhlt1_aer, - ! instead take out abs550rh for each constituent: - call outfld('ABSDRYBC',abs550rh_bc,pcols,lchnk) - call outfld('ABSDRYOC',abs550rh_oc,pcols,lchnk) - call outfld('ABSDRYSU',abs550rh_su,pcols,lchnk) - call outfld('ABSDRYSS',abs550rh_ss,pcols,lchnk) - call outfld('ABSDRYDU',abs550rh_du,pcols,lchnk) - - elseif(irf.ge.2) then ! only happens for AEROCOM_INSITU - - irh=RF(irf) - - modeString=" " - write(modeString,"(I2)"),irh - if(RF(irf).eq.0) modeString="00" - - !- varName = "EC44RH"//trim(modeString) - !- call outfld(varName,ec440rh_aer(:,:),pcols,lchnk) - varName = "EC55RH"//trim(modeString) - call outfld(varName,ec550rh_aer(:,:),pcols,lchnk) - !- varName = "EC87RH"//trim(modeString) - !- call outfld(varName,ec870rh_aer(:,:),pcols,lchnk) - - !- varName = "AB44RH"//trim(modeString) - !- call outfld(varName,abs440rh_aer(:,:),pcols,lchnk) - varName = "AB55RH"//trim(modeString) - call outfld(varName,abs550rh_aer(:,:),pcols,lchnk) - !- varName = "AB87RH"//trim(modeString) - !- call outfld(varName,abs870rh_aer(:,:),pcols,lchnk) - - end if ! irf - -end subroutine opticsAtConstRh - diff --git a/src/physics/cam_oslo/pmxsub.F90 b/src/physics/cam_oslo/pmxsub.F90 index b049619e2b..878ca43d2f 100644 --- a/src/physics/cam_oslo/pmxsub.F90 +++ b/src/physics/cam_oslo/pmxsub.F90 @@ -1,53 +1,36 @@ module pmxsub_mod - implicit none + implicit none -#ifdef AEROCOM - logical :: do_aerocom = .true. -#else - logical :: do_aerocom = .false. -#endif - -!=============================================================================== + !=============================================================================== contains -!=============================================================================== + !=============================================================================== subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, & - volc_ext_earth, volc_omega_earth, & - aodvis, absvis, dod440, dod550, dod870, abs550, abs550alt) + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & + volc_ext_sun, volc_omega_sun, volc_g_sun, & + volc_ext_earth, volc_omega_earth, & + aodvis, absvis) - ! Optical parameters for a composite aerosol is calculated by interpolation + ! Optical parameters for a composite aerosol is calculated by interpolation ! from the tables kcomp1.out-kcomp14.out. - ! Optimized June 2002 byrild Burud/NoSerC - ! Optimized July 2002 by Egil Storen/NoSerC (ces) - ! Revised for inclusion of OC and modified aerosol backgeound aerosol - ! by Alf Kirkevaag in 2003, and finally rewritten for CAM3 February 2005. - ! Modified for new aerosol schemes by Alf Kirkevaag in January 2006. - ! Updated by Alf Kirkevåg, May 2013: The SO4(Ait) mode now takes into - ! account condensed SOA in addition to H2SO4. - ! Updated for CAM5-Oslo with RRTMG by Alf Kirkevåg, 2014-2015, for new - ! SOA treatment August/September 2015, and for cleanig up and optimizing - ! the code around interpolations in November 2016. use ppgrid use shr_kind_mod, only: r8 => shr_kind_r8 use cam_history, only: outfld use constituents, only: pcnst use physconst, only: rair,pi - use opttab use oslo_utils, only: calculateNumberConcentration use parmix_progncdnc, only: calculateBulkProperties, partitionMass + use opttab use const use aerosoldef use commondefinitions use physics_types, only: physics_state use wv_saturation, only: qsat_water use aeroopt_mod, only: extinction_coeffs, extinction_coeffsn - use aerodry_mod, only: aerodry_prop - - ! + use aerodry_mod, only: aerodry_prop + ! Input arguments integer, intent(in) :: lchnk ! chunk identifier integer, intent(in) :: ncol ! number of atmospheric columns @@ -62,311 +45,88 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & real(r8), intent(in) :: volc_g_sun(pcols,pver,nbands) ! volcanic aerosol g for solar bands, CMIP6 real(r8), intent(in) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 real(r8), intent(in) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 - ! + type(physics_state), intent(in), target :: state + ! Input-output arguments - real(r8), intent(inout) :: Nnatk(pcols,pver,0:nmodes)! aerosol mode number concentration + real(r8), intent(inout) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration ! Output arguments - ! - real(r8), intent(out) :: per_tau (pcols,0:pver,nbands) ! aerosol extinction optical depth - real(r8), intent(out) :: per_tau_w (pcols,0:pver,nbands) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: per_tau_w_g(pcols,0:pver,nbands) ! aerosol assymetry parameter * w * tau - real(r8), intent(out) :: per_tau_w_f(pcols,0:pver,nbands) ! aerosol forward scattered fraction * w * tau - real(r8), intent(out) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optical depth (LW) - ! AOD and absorptive AOD for visible wavelength closest to 0.55 um (0.442-0.625) - ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values - real(r8), intent(out) :: aodvis(pcols) ! AOD vis - real(r8), intent(out) :: absvis(pcols) ! AAOD vis - ! AEROCOM - real(r8), intent(out) :: dod440(pcols) - real(r8), intent(out) :: dod550(pcols) - real(r8), intent(out) :: dod870(pcols) - real(r8), intent(out) :: abs550(pcols) - real(r8), intent(out) :: abs550alt(pcols) - !---------------------------Local variables----------------------------- - ! - integer i, k, ib, icol, mplus10 - integer iloop - logical daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. - - real(r8) aodvisvolc(pcols) ! AOD vis for CMIP6 volcanic aerosol - real(r8) absvisvolc(pcols) ! AAOD vis for CMIP6 volcanic aerosol - !akc6+ - real(r8) bevisvolc(pcols,pver) ! Extinction in vis wavelength band for CMIP6 volcanic aerosol - !akc6- - real(r8) rhum(pcols,pver) ! (trimmed) relative humidity for the aerosol calculations - !tst - ! real(r8) aodvis3d(pcols,pver) ! 3D AOD in VIS - !tst - - real(r8) deltah_km(pcols,pver) ! Layer thickness, unit km - - !akc6 real(r8) deltah, airmass(pcols,pver) - real(r8) deltah, airmassl(pcols,pver), airmass(pcols) !akc6 - real(r8) Ca(pcols,pver), f_c(pcols,pver), f_bc(pcols,pver), f_aq(pcols,pver) - real(r8) fnbc(pcols,pver), faitbc(pcols,pver), f_so4_cond(pcols,pver), & - f_soa(pcols,pver),f_soana(pcols,pver), vnbc, vaitbc - real(r8) v_soana(pcols,pver), vnbcarr(pcols,pver), vaitbcarr(pcols,pver) - real(r8) dCtot(pcols,pver), Ctot(pcols,pver) - real(r8) Cam(pcols,pver,nbmodes), fbcm(pcols,pver,nbmodes), fcm(pcols,pver,nbmodes), & - faqm(pcols,pver,nbmodes), f_condm(pcols,pver,nbmodes), & - f_soam(pcols, pver,nbmodes), faqm4(pcols,pver) - real(r8) xrh(pcols,pver), xrhnull(pcols,pver) - integer irh1(pcols,pver), irh2(pcols,pver), irh1null(pcols,pver), irh2null(pcols,pver) - real(r8) focm(pcols,pver,4) - ! real(r8) akso4c(pcols), akbcc(pcols), akocc(pcols) - real(r8) ssa(pcols,pver,0:nmodes,nbands), asym(pcols,pver,0:nmodes,nbands), & - be(pcols,pver,0:nmodes,nbands), ke(pcols,pver,0:nmodes,nbands), & - betotvis(pcols,pver), batotvis(pcols,pver) - real(r8) ssatot(pcols,pver,nbands) ! spectral aerosol single scattering albedo - real(r8) asymtot(pcols,pver,nbands) ! spectral aerosol asymmetry factor - real(r8) betot(pcols,pver,nbands) ! spectral aerosol extinction coefficient - real(r8) batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW - real(r8) kalw(pcols,pver,0:nmodes,nlwbands) - real(r8) balw(pcols,pver,0:nmodes,nlwbands) - logical lw_on ! LW calculations are performed in interpol* if true - real(r8) volc_balw(pcols,0:pver,nlwbands) ! volcanic aerosol absorption coefficient for terrestrial bands, CMIP6 - - real(r8) rh0(pcols,pver), rhoda(pcols,pver) - real(r8) ssavis(pcols,pver), asymmvis(pcols,pver), extvis(pcols,pver), dayfoc(pcols,pver) - real(r8) n_aerorig(pcols,pver), n_aer(pcols,pver) - type(physics_state), intent(in), target :: state + ! AOD and absorptive AOD for visible wavelength closest to 0.55 um (0.442-0.625) + ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values + real(r8), intent(out) :: per_tau (pcols,0:pver,nbands) ! aerosol extinction optical depth + real(r8), intent(out) :: per_tau_w (pcols,0:pver,nbands) ! aerosol single scattering albedo * tau + real(r8), intent(out) :: per_tau_w_g(pcols,0:pver,nbands) ! aerosol assymetry parameter * w * tau + real(r8), intent(out) :: per_tau_w_f(pcols,0:pver,nbands) ! aerosol forward scattered fraction * w * tau + real(r8), intent(out) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optical depth (LW) + real(r8), intent(out) :: aodvis(pcols) ! AOD vis + real(r8), intent(out) :: absvis(pcols) ! AAOD vis + + ! Local variables + integer :: i, k, ib, icol, mplus10 + integer :: iloop + logical :: daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. + real(r8) :: aodvisvolc(pcols) ! AOD vis for CMIP6 volcanic aerosol + real(r8) :: absvisvolc(pcols) ! AAOD vis for CMIP6 volcanic aerosol + real(r8) :: bevisvolc(pcols,pver) ! Extinction in vis wavelength band for CMIP6 volcanic aerosol + real(r8) :: rhum(pcols,pver) ! (trimmed) relative humidity for the aerosol calculations + real(r8) :: deltah_km(pcols,pver) ! Layer thickness, unit km + real(r8) :: deltah, airmassl(pcols,pver), airmass(pcols) !akc6 + real(r8) :: Ca(pcols,pver), f_c(pcols,pver), f_bc(pcols,pver), f_aq(pcols,pver) + real(r8) :: fnbc(pcols,pver), faitbc(pcols,pver), f_so4_cond(pcols,pver) + real(r8) :: f_soa(pcols,pver),f_soana(pcols,pver) + real(r8) :: v_soana(pcols,pver) + real(r8) :: dCtot(pcols,pver), Ctot(pcols,pver) + real(r8) :: Cam(pcols,pver,nbmodes), fbcm(pcols,pver,nbmodes), fcm(pcols,pver,nbmodes) + real(r8) :: faqm(pcols,pver,nbmodes), f_condm(pcols,pver,nbmodes) + real(r8) :: f_soam(pcols, pver,nbmodes), faqm4(pcols,pver) + real(r8) :: xrh(pcols,pver) + integer :: irh1(pcols,pver) + real(r8) :: focm(pcols,pver,4) + real(r8) :: ssa(pcols,pver,0:nmodes,nbands), asym(pcols,pver,0:nmodes,nbands) + real(r8) :: be(pcols,pver,0:nmodes,nbands), ke(pcols,pver,0:nmodes,nbands) + real(r8) :: betotvis(pcols,pver), batotvis(pcols,pver) + real(r8) :: ssatot(pcols,pver,nbands) ! spectral aerosol single scattering albedo + real(r8) :: asymtot(pcols,pver,nbands) ! spectral aerosol asymmetry factor + real(r8) :: betot(pcols,pver,nbands) ! spectral aerosol extinction coefficient + real(r8) :: batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW + real(r8) :: kalw(pcols,pver,0:nmodes,nlwbands) + real(r8) :: balw(pcols,pver,0:nmodes,nlwbands) + real(r8) :: volc_balw(pcols,0:pver,nlwbands) ! volcanic aerosol absorption coefficient for terrestrial bands, CMIP6 + real(r8) :: rh0(pcols,pver), rhoda(pcols,pver) + real(r8) :: ssavis(pcols,pver), asymmvis(pcols,pver), extvis(pcols,pver), dayfoc(pcols,pver) + real(r8) :: n_aerorig(pcols,pver), n_aer(pcols,pver) real(r8) :: es(pcols,pver) ! saturation vapor pressure real(r8) :: qs(pcols,pver) ! saturation specific humidity real(r8) :: rht(pcols,pver) ! relative humidity (fraction) (rh is already used in opptab) real(r8) :: rh_temp(pcols,pver) ! relative humidity (fraction) for input to LUT - real(r8) xfombg(pcols,pver) - integer ifombg1(pcols,pver), ifombg2(pcols,pver) - real(r8) xct(pcols,pver,nmodes) - integer ict1(pcols,pver,nmodes) - real(r8) xfac(pcols,pver,nbmodes) - integer ifac1(pcols,pver,nbmodes) - real(r8) xfbc(pcols,pver,nbmodes) - integer ifbc1(pcols,pver,nbmodes) - real(r8) xfaq(pcols,pver,nbmodes) - integer ifaq1(pcols,pver,nbmodes) - real(r8) xfbcbg(pcols,pver) - integer ifbcbg1(pcols,pver) - real(r8) xfbcbgn(pcols,pver) - integer ifbcbgn1(pcols,pver) - - ! -------begin do_aerocom----------- - real(r8) Ctotdry(pcols,pver), Cwater(pcols,pver), mmr_aerh2o(pcols,pver), & - dod550dry(pcols), abs550dry(pcols) - real(r8) daerh2o(pcols), dload(pcols,0:nmodes), dload3d(pcols,pver,0:nmodes), & - dload_mi(pcols), dload_ss(pcols), & - dload_s4(pcols), dload_oc(pcols), dload_bc(pcols), & - dload_s4_a(pcols), dload_s4_1(pcols), dload_s4_5(pcols) - real(r8) dload_bc_0(pcols), dload_bc_ac(pcols), dload_oc_ac(pcols), & - dload_bc_2(pcols), dload_bc_4(pcols), dload_bc_12(pcols), dload_bc_14(pcols), & - dload_oc_4(pcols), dload_oc_14(pcols) - real(r8) cmin(pcols,pver), cseas(pcols,pver) - real(r8) nnat_1(pcols,pver), nnat_2(pcols,pver), nnat_3(pcols,pver), & - nnat_4(pcols,pver), nnat_5(pcols,pver), nnat_6(pcols,pver), & - nnat_7(pcols,pver), nnat_8(pcols,pver), nnat_9(pcols,pver), & - nnat_10(pcols,pver), nnat_12(pcols,pver), & - nnat_14(pcols,pver), nnat_0(pcols,pver) - real(r8) ck(pcols,pver,0:nmodes), cknorm(pcols,pver,0:nmodes), & - cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) - real(r8) aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & - vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & - aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & - vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) - real(r8) cintbg(pcols,pver,0:nbmodes), & - cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & - cintbc(pcols,pver,0:nbmodes), & - cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & - cintoc(pcols,pver,0:nbmodes), & - cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & - cintsc(pcols,pver,0:nbmodes), & - cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & - cintsa(pcols,pver,0:nbmodes), & - cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes) - real(r8) c_mi(pcols,pver), c_mi05(pcols,pver), c_mi125(pcols,pver), & - c_ss(pcols,pver), c_ss05(pcols,pver), c_ss125(pcols,pver), & - c_bc(pcols,pver), c_bc05(pcols,pver), c_bc125(pcols,pver), & - c_oc(pcols,pver), c_oc05(pcols,pver), c_oc125(pcols,pver), & - c_sa(pcols,pver), c_sa05(pcols,pver), c_sa125(pcols,pver), & - c_sc(pcols,pver), c_sc05(pcols,pver), c_sc125(pcols,pver), & - c_s4(pcols,pver), c_s405(pcols,pver), c_s4125(pcols,pver), & - c_s4_a(pcols,pver), c_s4_1(pcols,pver), c_s4_5(pcols,pver) - real(r8) c_bc_0(pcols,pver), c_bc_ac(pcols,pver), c_oc_ac(pcols,pver), & - c_bc_2(pcols,pver), c_bc_4(pcols,pver), c_bc_12(pcols,pver), c_bc_14(pcols,pver), & - c_oc_4(pcols,pver), c_oc_14(pcols,pver) - real(r8) c_tots(pcols), c_tot125s(pcols), c_pm25s(pcols) ! = PM all sizes, PM>2.5um and PM<2.5um (PM2.5) - real(r8) c_tot(pcols,pver), c_tot125(pcols,pver), c_pm25(pcols,pver), & - mmr_pm25(pcols,pver), c_tot05(pcols,pver), c_pm1(pcols,pver), mmr_pm1(pcols,pver) - real(r8) aaeros_tot(pcols,pver), aaerol_tot(pcols,pver), vaeros_tot(pcols,pver), & - vaerol_tot(pcols,pver), aaercols(pcols), aaercoll(pcols), vaercols(pcols), & - vaercoll(pcols), derlt05(pcols), dergt05(pcols), der(pcols), & - erlt053d(pcols,pver), ergt053d(pcols,pver), er3d(pcols,pver) - real(r8) bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & - bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & - beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & - bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes), backsc550x(pcols,pver,nbmp1:nmodes), & - backsc550tot(pcols,pver), ec550_aer(pcols,pver), abs550_aer(pcols,pver), & - bs550_aer(pcols,pver) - - ! Additional AeroCom Phase III output: - real(r8) asydry_aer(pcols,pver) ! dry asymtot in the visible band - ! - real(r8) ec550_so4(pcols,pver),ec550_bc(pcols,pver), ec550_pom(pcols,pver), & - ec550_ss(pcols,pver), ec550_du(pcols,pver) - - real(r8) bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & - bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & - beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & - bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & - backsc550n(pcols,pver,0:nbmodes) - - real(r8) bext440tot(pcols,pver), babs440tot(pcols,pver), & - bext500tot(pcols,pver), babs500tot(pcols,pver), & - bext550tot(pcols,pver), babs550tot(pcols,pver), & - bext670tot(pcols,pver), babs670tot(pcols,pver), & - bext870tot(pcols,pver), babs870tot(pcols,pver), & - bebg440tot(pcols,pver), & - bebg500tot(pcols,pver), & - bebg550tot(pcols,pver), babg550tot(pcols,pver), & - bebg670tot(pcols,pver), & - bebg870tot(pcols,pver), & - bebc440tot(pcols,pver), & - bebc500tot(pcols,pver), & - bebc550tot(pcols,pver), babc550tot(pcols,pver), & - bebc670tot(pcols,pver), & - bebc870tot(pcols,pver), & - beoc440tot(pcols,pver), & - beoc500tot(pcols,pver), & - beoc550tot(pcols,pver), baoc550tot(pcols,pver), & - beoc670tot(pcols,pver), & - beoc870tot(pcols,pver), & - besu440tot(pcols,pver), & - besu500tot(pcols,pver), & - besu550tot(pcols,pver), basu550tot(pcols,pver), & - besu670tot(pcols,pver), & - besu870tot(pcols,pver) - - real(r8) bebglt1t(pcols,pver), bebggt1t(pcols,pver), bebclt1t(pcols,pver), & - bebcgt1t(pcols,pver), beoclt1t(pcols,pver), beocgt1t(pcols,pver), & - bes4lt1t(pcols,pver), bes4gt1t(pcols,pver) - - real(r8) be440x(pcols,pver,nbmp1:nmodes), ba440x(pcols,pver,nbmp1:nmodes), & - be500x(pcols,pver,nbmp1:nmodes), ba500x(pcols,pver,nbmp1:nmodes), & - be550x(pcols,pver,nbmp1:nmodes), ba550x(pcols,pver,nbmp1:nmodes), & - be670x(pcols,pver,nbmp1:nmodes), ba670x(pcols,pver,nbmp1:nmodes), & - be870x(pcols,pver,nbmp1:nmodes), ba870x(pcols,pver,nbmp1:nmodes), & - belt1x(pcols,pver,nbmp1:nmodes), begt1x(pcols,pver,nbmp1:nmodes) - - real(r8) bebc440xt(pcols,pver),babc440xt(pcols,pver), & - bebc500xt(pcols,pver),babc500xt(pcols,pver), & - bebc550xt(pcols,pver),babc550xt(pcols,pver), & - bebc670xt(pcols,pver),babc670xt(pcols,pver), & - bebc870xt(pcols,pver),babc870xt(pcols,pver), & - beoc440xt(pcols,pver),baoc440xt(pcols,pver), & - beoc500xt(pcols,pver),baoc500xt(pcols,pver), & - beoc550xt(pcols,pver),baoc550xt(pcols,pver), & - beoc670xt(pcols,pver),baoc670xt(pcols,pver), & - beoc870xt(pcols,pver),baoc870xt(pcols,pver) - - real(r8) bbclt1xt(pcols,pver), & - bbcgt1xt(pcols,pver), boclt1xt(pcols,pver), bocgt1xt(pcols,pver) - - real(r8) bint440du(pcols,pver), bint500du(pcols,pver), bint550du(pcols,pver), & - bint670du(pcols,pver), bint870du(pcols,pver), & - bint440ss(pcols,pver), bint500ss(pcols,pver), bint550ss(pcols,pver), & - bint670ss(pcols,pver), bint870ss(pcols,pver), & - baint550du(pcols,pver), baint550ss(pcols,pver) - - real(r8) bedustlt1(pcols,pver), bedustgt1(pcols,pver), & - besslt1(pcols,pver), bessgt1(pcols,pver) - - real(r8) dod4403d(pcols,pver), abs4403d(pcols,pver), & - dod4403d_ss(pcols,pver), & ! abs4403d_ss(pcols,pver), & - dod4403d_dust(pcols,pver), & ! abs4403d_dust(pcols,pver), & - dod4403d_so4(pcols,pver), & ! abs4403d_so4(pcols,pver), & - dod4403d_bc(pcols,pver), & ! abs4403d_bc(pcols,pver), & - dod4403d_pom(pcols,pver), & ! abs4403d_pom(pcols,pver), & - dod5003d(pcols,pver), abs5003d(pcols,pver), & - dod5003d_ss(pcols,pver), & ! abs5003d_ss(pcols,pver), & - dod5003d_dust(pcols,pver), & ! abs5003d_dust(pcols,pver), & - dod5003d_so4(pcols,pver), & ! abs5003d_so4(pcols,pver), & - dod5003d_bc(pcols,pver), & ! abs5003d_bc(pcols,pver), & - dod5003d_pom(pcols,pver), & ! abs5003d_pom(pcols,pver), & - dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver), & - dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver), & - dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver), & - dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver), & - dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver), & - dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver), & - dod6703d(pcols,pver), abs6703d(pcols,pver), & - dod6703d_ss(pcols,pver), & ! abs6703d_ss(pcols,pver), & - dod6703d_dust(pcols,pver), & ! abs6703d_dust(pcols,pver), & - dod6703d_so4(pcols,pver), & ! abs6703d_so4(pcols,pver), & - dod6703d_bc(pcols,pver), & ! abs6703d_bc(pcols,pver), & - dod6703d_pom(pcols,pver), & ! abs6703d_pom(pcols,pver), & - dod8703d(pcols,pver), abs8703d(pcols,pver), & - dod8703d_ss(pcols,pver), & ! abs8703d_ss(pcols,pver), & - dod8703d_dust(pcols,pver), & ! abs8703d_dust(pcols,pver), & - dod8703d_so4(pcols,pver), & ! abs8703d_so4(pcols,pver), & - dod8703d_bc(pcols,pver), & ! abs8703d_bc(pcols,pver), & - dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) - - real(r8) dod5503dlt1_ss(pcols,pver), dod5503dgt1_ss(pcols,pver), & - dod5503dlt1_dust(pcols,pver), dod5503dgt1_dust(pcols,pver), & - dod5503dlt1_so4(pcols,pver), dod5503dgt1_so4(pcols,pver), & - dod5503dlt1_bc(pcols,pver), dod5503dgt1_bc(pcols,pver), & - dod5503dlt1_pom(pcols,pver), dod5503dgt1_pom(pcols,pver) - real(r8) abs440(pcols), dod500(pcols), abs500(pcols), & - dod670(pcols),& - abs670(pcols), abs870(pcols), & - dod440_ss(pcols), dod440_dust(pcols), dod440_so4(pcols), & - dod440_bc(pcols), dod440_pom(pcols), & - dod500_ss(pcols), dod500_dust(pcols), dod500_so4(pcols), & - dod500_bc(pcols), dod500_pom(pcols), & - dod550_ss(pcols), dod550_dust(pcols), dod550_so4(pcols), & - dod550_bc(pcols), dod550_pom(pcols), & - dod670_ss(pcols), dod670_dust(pcols), dod670_so4(pcols), & - dod670_bc(pcols), dod670_pom(pcols), & - dod870_ss(pcols), dod870_dust(pcols), dod870_so4(pcols), & - dod870_bc(pcols), dod870_pom(pcols), & - dod550lt1_ss(pcols), dod550gt1_ss(pcols), dod550lt1_dust(pcols), & - dod550gt1_dust(pcols), dod550lt1_so4(pcols), & - dod550gt1_so4(pcols), dod550lt1_bc(pcols), dod550gt1_bc(pcols), & - dod550lt1_pom(pcols), dod550gt1_pom(pcols) - real(r8) abs550_ss(pcols), abs550_dust(pcols), & - abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) - real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) - character(len=10) :: modeString - character(len=20) :: varname - integer irf,irfmax - real(r8) Camrel(pcols,pver,nbmodes) - real(r8) Camtot(pcols,nbmodes) - real(r8) cxsmtot(pcols,nbmodes) - real(r8) cxsmrel(pcols,nbmodes) - real(r8) xctrel,camdiff,cxsm - real(r8) cxs(pcols,pver), cxstot(pcols,pver), akcxs(pcols) - ! --------end do_aerocom----------- - !- - - ! + real(r8) :: xfombg(pcols,pver) + integer :: ifombg1(pcols,pver), ifombg2(pcols,pver) + real(r8) :: xct(pcols,pver,nmodes) + integer :: ict1(pcols,pver,nmodes) + real(r8) :: xfac(pcols,pver,nbmodes) + integer :: ifac1(pcols,pver,nbmodes) + real(r8) :: xfbc(pcols,pver,nbmodes) + integer :: ifbc1(pcols,pver,nbmodes) + real(r8) :: xfaq(pcols,pver,nbmodes) + integer :: ifaq1(pcols,pver,nbmodes) + real(r8) :: xfbcbg(pcols,pver) + integer :: ifbcbg1(pcols,pver) + real(r8) :: xfbcbgn(pcols,pver) + integer :: ifbcbgn1(pcols,pver) + logical :: lw_on ! LW calculations are performed in interpol* if true !------------------------------------------------------------------------- - ! - !test: hentet fra aer_rad_props, saa modifisert/rettet (!x) ! calculate relative humidity for table lookup into rh grid - !x call qsat(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & call qsat_water(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & es(1:ncol,1:pver), qs(1:ncol,1:pver)) rht(1:ncol,1:pver) = state%q(1:ncol,1:pver,1) / qs(1:ncol,1:pver) rh_temp(1:ncol,1:pver) = min(rht(1:ncol,1:pver),1._r8) - do k=1,pver do icol=1,ncol - ! Set upper and lower relative humidity for the aerosol calculations + ! Set upper and lower relative humidity for the aerosol calculations rhum(icol,k) = min(0.995_r8, max(rh_temp(icol,k), 0.01_r8)) rhoda(icol,k) = pmid(icol,k)/(rair*t(icol,k)) ! unit kg/m^3 - !test rhum(icol,k) = 0.01_r8 if (cld(icol,k) .lt. 1.0_r8) then rhum(icol,k) = (rhum(icol,k) - cld(icol,k)) / (1.0_r8 - cld(icol,k)) ! clear portion end if @@ -374,31 +134,25 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do end do - ! Layer thickness with unit km + ! Layer thickness with unit km do icol=1,ncol do k=1,pver - deltah_km(icol,k)=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) + deltah_km(icol,k)=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) end do end do - ! interpol-calculations only when daylight or not: - if (do_aerocom) then - do icol=1,ncol - daylight(icol) = .true. - end do - else + ! interpol-calculations only when daylight or not: do icol=1,ncol if (coszrs(icol) > 0.0_r8) then - daylight(icol) = .true. + daylight(icol) = .true. else daylight(icol) = .false. endif end do - end if - ! Set SO4, BC and OC concentrations: + ! Set SO4, BC and OC concentrations: - ! initialize concentration fields + ! initialize concentration fields do i=0,nmodes do k=1,pver do icol=1,ncol @@ -417,12 +171,12 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & ke(:,:,:,:)=0._r8 asym(:,:,:,:)=0._r8 ssa(:,:,:,:)=0._r8 - ! Find process tagged bulk aerosol properies (from the life cycle module): + ! Find process tagged bulk aerosol properies (from the life cycle module): call calculateBulkProperties(ncol, qm1, rhoda, Nnatk, Ca, f_c, f_bc, & f_aq, f_so4_cond, f_soa, faitbc, fnbc, f_soana) - ! calculating vulume fractions from mass fractions: + ! calculating vulume fractions from mass fractions: do k=1,pver do icol=1,ncol v_soana(icol,k) = f_soana(icol,k)/(f_soana(icol,k) & @@ -430,20 +184,20 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do end do - ! Avoid very small numbers + ! Avoid very small numbers do k=1,pver do icol=1,ncol Ca(icol,k) = max(eps,Ca(icol,k)) f_c(icol,k) = max(eps,f_c(icol,k)) - f_bc(icol,k) = max(eps,f_bc(icol,k)) - f_aq(icol,k) = max(eps,f_aq(icol,k)) + f_bc(icol,k) = max(eps,f_bc(icol,k)) + f_aq(icol,k) = max(eps,f_aq(icol,k)) fnbc(icol,k) = max(eps,fnbc(icol,k)) - faitbc(icol,k) = max(eps,faitbc(icol,k)) + faitbc(icol,k) = max(eps,faitbc(icol,k)) end do end do - ! Calculation of the apportionment of internally mixed SO4, BC and OC - ! mass between the various background modes. + ! Calculation of the apportionment of internally mixed SO4, BC and OC + ! mass between the various background modes. !==> calls modalapp to partition the mass call partitionMass(ncol, nnatk, Ca, f_c, f_bc, f_aq, f_so4_cond, f_soa , & @@ -453,8 +207,8 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & Nnatk(:ncol,:,:) = Nnatk(:ncol,:,:)*1.e-6_r8 cam(:ncol,:,:)=cam(:ncol,:,:)*1.e9_r8 - ! Calculate fraction of added mass which is either SOA condensate or OC coagulate, - ! which in AeroTab are both treated as condensate for kcomp=1-4. + ! Calculate fraction of added mass which is either SOA condensate or OC coagulate, + ! which in AeroTab are both treated as condensate for kcomp=1-4. do i=1,4 do k=1,pver do icol=1,ncol @@ -468,251 +222,42 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do enddo - ! find common input parameters for use in the interpolation routines - + ! find common input parameters for use in the interpolation routines call inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & f_soana, xfombg, ifombg1, faitbc, xfbcbg, ifbcbg1, & fnbc, xfbcbgn, ifbcbgn1, Nnatk, Cam, xct, ict1, & focm, fcm, xfac, ifac1, fbcm, xfbc, ifbc1, faqm, xfaq, ifaq1) - ! and define the respective RH input variables for dry aerosols - do k=1,pver - do icol=1,ncol - xrhnull(icol,k)=rh(1) - irh1null(icol,k)=1 - end do - enddo - - - if (do_aerocom) then - - ! Initialize overshooting mass summed over all modes - do k=1,pver - do icol=1,ncol - cxstot(icol,k)=0.0_r8 - enddo - enddo - do icol=1,ncol - akcxs(icol)=0.0_r8 - enddo - - ! Initializing total and relative exessive (overshooting w.r.t. - ! look-up table maxima) added mass column: - do i=1,nbmodes - do icol=1,ncol - Camtot(icol,i)=0.0_r8 - cxsmtot(icol,i)=0.0_r8 - cxsmrel(icol,i)=0.0_r8 - enddo - enddo - ! Calculating added internally mixed mass onto each mode 1-10, relative to - ! maximum mass which can be added w.r.t. the look-up tables (for level k), - ! as well as the relative exessive added mass column: - do i=1,4 - do k=1,pver - do icol=1,ncol - Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cate(i,16) - xctrel=min(max(Camrel(icol,k,i),cate(i,1)/cate(i,16)),1.0_r8) - camdiff=Cam(icol,k,i)-xctrel*cate(i,16)*(Nnatk(icol,k,i)+eps) - cxsm=max(0.0_r8,camdiff) - cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) - Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) - !t - camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) - cxs(icol,k)=max(0.0_r8,camdiff) - cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) - !t - enddo - enddo - enddo - do i=5,nbmodes - do k=1,pver - do icol=1,ncol - Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cat(i,6) - xctrel=min(max(Camrel(icol,k,i),cat(i,1)/cat(i,6)),1.0_r8) - camdiff=Cam(icol,k,i)-xctrel*cat(i,6)*(Nnatk(icol,k,i)+eps) - cxsm=max(0.0_r8,camdiff) - cxsmtot(icol,i)=cxsmtot(icol,i)+cxsm*deltah_km(icol,k) - Camtot(icol,i)=Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) - !t - camdiff=Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) - cxs(icol,k)=max(0.0_r8,camdiff) - cxstot(icol,k)= cxstot(icol,k)+cxs(icol,k) - !t - enddo - enddo - enddo - - ! Total overshooting mass summed over all modes and all levels - do icol=1,ncol - do k=1,pver - akcxs(icol) =akcxs(icol)+cxstot(icol,k)*deltah_km(icol,k) - enddo - enddo - call outfld('AKCXS ',akcxs ,pcols,lchnk) - - do i=1,nbmodes - do icol=1,ncol - cxsmrel(icol,i)=cxsmtot(icol,i)/(Camtot(icol,i)+eps) - enddo - enddo - - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Camrel"//trim(modeString) - if(i.ne.3) call outfld(varName,Camrel(:,:,i),pcols,lchnk) - enddo - - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Cxsrel"//trim(modeString) - if(i.ne.3) call outfld(varName,cxsmrel(:,i),pcols,lchnk) - enddo - - ! AeroCom: Find dry aerosol asymmetry factor and mass for subsequent - ! calculation of condensed water mass below... - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - do k=1,pver - do icol=1,ncol - Ctotdry(icol,k)=0.0_r8 - rh0(icol,k)=0.0_r8 - asydry_aer(icol,k)=0.0_r8 - end do - enddo - - lw_on = .false. ! No LW optics needed for RH=0 (interpol returns 0-values) - - do iloop=1,1 ! loop over i>1 for testing CPU use in interpol* - ! BC(ax) mode (dry only): - call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) - - mplus10=0 - ! SO4/SOA(Ait) mode: - call interpol1 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - - ! BC&OC(Ait) mode: ------ fcm not valid here (=0). Use faitbc instead - call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, & - xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - - ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call interpol5to10 (lchnk, ncol, daylight, xrhnull, irh1null, & - Nnatk, xct, ict1, xfac, ifac1, & - xfbc, ifbc1, xfaq, ifaq1, & - ssa, asym, be, ke, lw_on, kalw) - enddo ! iloop - - - do iloop=1,1 - mplus10=1 - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - - ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead - call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, & - ssa, asym, be, ke, lw_on, kalw) - - enddo ! iloop - - do i=0,nmodes ! mode 0 to 14 - do k=1,pver - do icol=1,ncol - dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) - Ctotdry(icol,k)=Ctotdry(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) - end do - enddo - enddo - - ! AeroCom Phase III: adding asymmetry factor for dry aerosol, wavelength band 4 only - ! (and with no CMIP6 volcnic contribution) - ib=4 - do k=1,pver - do icol=1,ncol - betot(icol,k,ib)=0.0_r8 - ssatot(icol,k,ib)=0.0_r8 - asymtot(icol,k,ib)=0.0_r8 - end do - enddo - do i=0,nmodes - do k=1,pver - do icol=1,ncol - betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) - ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib) - asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) - ! if(ib.eq.4) then - ! write(*,*) 'i, asym =', i, asym(icol,k,i,ib) - ! write(*,*) 'i, be =', i, be(icol,k,i,ib) - ! write(*,*) 'i, ssa =', i, ssa(icol,k,i,ib) - ! endif - - end do - enddo - enddo - do k=1,pver - do icol=1,ncol - ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) - asymtot(icol,k,ib)=asymtot(icol,k,ib) & - /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) - asydry_aer(icol,k)=asymtot(icol,k,ib) - end do - enddo - ! - call outfld('ASYMMDRY',asydry_aer,pcols,lchnk) - ! - end if ! AEROCOM - - ! (Wet) Optical properties for each of the aerosol modes: + ! (Wet) Optical properties for each of the aerosol modes: lw_on = .true. ! No LW optics needed for RH=0 (interpol returns 0-values) - do iloop=1,1 - ! BC(ax) mode (dry only): - call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) - - mplus10=0 - ! SO4/SOA(Ait) mode: - call interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, & - xfac, ifac1, ssa, asym, be, ke, lw_on, kalw) + ! BC(ax) mode (dry only): + call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) + mplus10=0 + ! SO4/SOA(Ait) mode: + call interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, & + xfac, ifac1, ssa, asym, be, ke, lw_on, kalw) - ! BC&OC(Ait) mode: ------ fcm invalid here (=0). Using faitbc instead - call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xfbcbg, ifbcbg1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) - ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call interpol5to10 (lchnk, ncol, daylight, xrh, irh1, & - Nnatk, xct, ict1, xfac, ifac1, & - xfbc, ifbc1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - enddo ! iloop + ! BC&OC(Ait) mode: ------ fcm invalid here (=0). Using faitbc instead + call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xfbcbg, ifbcbg1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call interpol5to10 (lchnk, ncol, daylight, xrh, irh1, & + Nnatk, xct, ict1, xfac, ifac1, & + xfbc, ifbc1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - ! total aerosol number concentrations - do i=0,nmodes ! mode 0 to 14 + ! total aerosol number concentrations + do i=0,nmodes ! mode 0 to 14 do k=1,pver do icol=1,ncol n_aer(icol,k)=n_aer(icol,k)+Nnatk(icol,k,i) @@ -721,21 +266,19 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & enddo call outfld('N_AER ',n_aer ,pcols,lchnk) - do iloop=1,1 - mplus10=1 - ! SO4/SOA(Ait) mode: - !does no longer exist as an externally mixed mode + mplus10=1 + ! SO4/SOA(Ait) mode: + !does no longer exist as an externally mixed mode - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) - ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead - call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - enddo ! iloop + ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead + call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & + Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) do k=1,pver do icol=1,ncol @@ -743,26 +286,16 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do enddo - do i=0,nmodes ! mode 0 to 14 + do i=0,nmodes ! mode 0 to 14 do k=1,pver do icol=1,ncol - dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) - Ctot(icol,k)=Ctot(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) + dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) + Ctot(icol,k)=Ctot(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) end do enddo enddo - if (do_aerocom) then - ! Mass concentration (ug/m3) and mmr (kg/kg) of aerosol condensed water - do k=1,pver - do icol=1,ncol - Cwater(icol,k)=Ctot(icol,k)-Ctotdry(icol,k) - mmr_aerh2o(icol,k)=1.e-9_r8*Cwater(icol,k)/rhoda(icol,k) - end do - enddo - end if - - ! SW Optical properties of total aerosol: + ! SW Optical properties of total aerosol: do ib=1,nbands do k=1,pver do icol=1,ncol @@ -778,25 +311,26 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & do icol=1,ncol betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib) + *be(icol,k,i,ib)*ssa(icol,k,i,ib) asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) end do enddo enddo enddo - ! Adding also the volcanic contribution (CMIP6), which is using a CMIP6 - ! band numbering identical to the AeroTab numbering (unlike CAM) both - ! for SW and LW. I.e., no remapping is required here. - ! Info from CMIP_CAM6_radiation_v3.nc - ! wl1_sun = 0.2, 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, - ! 1.2987, 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615 ; - ! wl2_sun = 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, 1.2987, - ! 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615, 12.1951 ; - ! wl1_earth = 3.07692, 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, - ! 7.19424, 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714 ; - ! wl2_earth = 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, 7.19424, - ! 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714, 1000 ; + + ! Adding also the volcanic contribution (CMIP6), which is using a CMIP6 + ! band numbering identical to the AeroTab numbering (unlike CAM) both + ! for SW and LW. I.e., no remapping is required here. + ! Info from CMIP_CAM6_radiation_v3.nc + ! wl1_sun = 0.2, 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, + ! 1.2987, 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615 ; + ! wl2_sun = 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, 1.2987, + ! 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615, 12.1951 ; + ! wl1_earth = 3.07692, 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, + ! 7.19424, 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714 ; + ! wl2_earth = 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, 7.19424, + ! 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714, 1000 ; do ib=1,nbands betot(1:ncol,1:pver,ib) = betot(1:ncol,1:pver,ib) & + volc_ext_sun(1:ncol,1:pver,ib) @@ -807,9 +341,9 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & *volc_g_sun(1:ncol,1:pver,ib) enddo !akc6+ - bevisvolc(1:ncol,1:pver) = volc_ext_sun(1:ncol,1:pver,4) + bevisvolc(1:ncol,1:pver) = volc_ext_sun(1:ncol,1:pver,4) !akc6- - ! and then calculate the total bulk optical parameters + ! and then calculate the total bulk optical parameters do ib=1,nbands do k=1,pver do icol=1,ncol @@ -823,9 +357,9 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & !------------------------------------------------------------------------------------------------ ! Replace CAM5 standard aerosol optics with CAM5-Oslo optics (except top layer: no aerosol) ! Remapping from AeroTab to CAM5 SW bands, see p. 167 in the CAM5.0 description: - ! CAM5 bands AeroTab bands - ! 14 3.846 12.195 14 - ! 1 3.077 3.846 13 + ! CAM5 bands AeroTab bands + ! 14 3.846 12.195 14 + ! 1 3.077 3.846 13 ! 2 2.500 3.077 12 ! 3 2.150 2.500 11 ! 4 1.942 2.150 10 @@ -855,7 +389,7 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do end do end do - ! Remapping of SW wavelength bands from AeroTab to CAM5 + ! Remapping of SW wavelength bands from AeroTab to CAM5 do i=1,ncol do ib=1,13 do k=1,pver @@ -863,13 +397,6 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & per_tau_w(i,k,ib)=per_tau(i,k,ib)*max(min(ssatot(i,k,14-ib),0.999999_r8),1.e-6_r8) per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,14-ib) per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,14-ib) - !tst - ! if(ib.eq.4.and.k.eq.pver.and.i.eq.1) then - ! write(*,*) 'per_tau =', per_tau(i,k,ib) - ! write(*,*) 'per_tau_w =', per_tau_w(i,k,ib) - ! write(*,*) 'per_tau_w_g =', per_tau_w_g(i,k,ib) - ! endif - !tst end do end do ib=14 @@ -879,10 +406,10 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,ib) per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,ib) end do - end do ! ncol + end do ! ncol !------------------------------------------------------------------------------------------------ - ! LW Optical properties of total aerosol: + ! LW Optical properties of total aerosol: do ib=1,nlwbands do k=1,pver do icol=1,ncol @@ -901,65 +428,50 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & enddo enddo - ! Adding also the volcanic contribution (CMIP6), which is also using - ! AeroTab band numbering, so that a remapping is required here + ! Adding also the volcanic contribution (CMIP6), which is also using + ! AeroTab band numbering, so that a remapping is required here do ib=1,nlwbands volc_balw(1:ncol,1:pver,ib) = volc_ext_earth(:ncol,1:pver,ib) & *(1.0_r8-volc_omega_earth(:ncol,1:pver,ib)) batotlw(1:ncol,1:pver,ib)=batotlw(1:ncol,1:pver,ib)+volc_balw(1:ncol,1:pver,ib) enddo - ! Remapping of LW wavelength bands from AeroTab to CAM5 + ! Remapping of LW wavelength bands from AeroTab to CAM5 do ib=1,nlwbands do i=1,ncol do k=1,pver - per_lw_abs(i,k,ib)=deltah_km(i,k)*batotlw(i,k,17-ib) - ! if(ib.eq.1.and.k.eq.pver.and.i.eq.1) then - ! write(*,*) 'per_lw_abs =', per_lw_abs(i,k,ib) - ! endif + per_lw_abs(i,k,ib)=deltah_km(i,k)*batotlw(i,k,17-ib) + ! if(ib.eq.1.and.k.eq.pver.and.i.eq.1) then + ! write(*,*) 'per_lw_abs =', per_lw_abs(i,k,ib) + ! endif end do end do end do - if (do_aerocom) then - do i=1,ncol - do k=1,pver - batotsw13(i,k)=betot(i,k,13)*(1.0_r8-ssatot(i,k,13)) - batotlw01(i,k)=batotlw(i,k,1) - end do - end do - ! These two fields should be close to equal, both representing absorption - ! in the 3.077-3.846 um wavelenght band (i.e., a check of LUT for LW vs. SW). - call outfld('BATSW13 ',batotsw13,pcols,lchnk) - call outfld('BATLW01 ',batotlw01,pcols,lchnk) - end if - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! APPROXIMATE aerosol extinction and absorption at 550nm (0.442-0.625 um) - ! (in the visible wavelength band) + ! APPROXIMATE aerosol extinction and absorption at 550nm (0.442-0.625 um) + ! (in the visible wavelength band) do k=1,pver do icol=1,ncol betotvis(icol,k)=betot(icol,k,4) batotvis(icol,k)=betotvis(icol,k)*(1.0-ssatot(icol,k,4)) end do enddo - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc do k=1,pver do icol=1,ncol ssavis(icol,k) = 0.0_r8 asymmvis(icol,k) = 0.0_r8 extvis(icol,k) = 0.0_r8 - dayfoc(icol,k) = 0.0_r8 + dayfoc(icol,k) = 0.0_r8 enddo end do do k=1,pver do icol=1,ncol - ! dayfoc < 1 when looping only over gridcells with daylight + ! dayfoc < 1 when looping only over gridcells with daylight if(daylight(icol)) then dayfoc(icol,k) = 1.0_r8 - ! with the new bands in CAM5, band 4 is now at ca 0.5 um (0.442-0.625) + ! with the new bands in CAM5, band 4 is now at ca 0.5 um (0.442-0.625) ssavis(icol,k) = ssatot(icol,k,4) asymmvis(icol,k) = asymtot(icol,k,4) extvis(icol,k) = betot(icol,k,4) @@ -967,17 +479,14 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & enddo end do - ! optical parameters in visible light (0.442-0.625um) + ! optical parameters in visible light (0.442-0.625um) call outfld('SSAVIS ',ssavis,pcols,lchnk) call outfld('ASYMMVIS',asymmvis,pcols,lchnk) call outfld('EXTVIS ',extvis,pcols,lchnk) call outfld('DAYFOC ',dayfoc,pcols,lchnk) - ! Initialize fields + ! Initialize fields do icol=1,ncol - ! akso4c(icol)=0.0_r8 - ! akbcc(icol)=0.0_r8 - ! akocc(icol)=0.0_r8 aodvis(icol)=0.0_r8 absvis(icol)=0.0_r8 aodvisvolc(icol)=0.0_r8 @@ -988,1114 +497,30 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & do icol=1,ncol if(daylight(icol)) then do k=1,pver - ! Layer thickness, unit km, and layer airmass, unit kg/m2 + ! Layer thickness, unit km, and layer airmass, unit kg/m2 deltah=deltah_km(icol,k) - !akc6 airmass(icol,k)=1.e3_r8*deltah*rhoda(icol,k) airmassl(icol,k)=1.e3_r8*deltah*rhoda(icol,k) airmass(icol)=airmass(icol)+airmassl(icol,k) !akc6 - ! Optical depths at ca. 550 nm (0.442-0.625um) all aerosols - !tst - ! aodvis3d(icol,k)=betotvis(icol,k)*deltah - !tst + + ! Optical depths at ca. 550 nm (0.442-0.625um) all aerosols aodvis(icol)=aodvis(icol)+betotvis(icol,k)*deltah absvis(icol)=absvis(icol)+batotvis(icol,k)*deltah - ! Optical depths at ca. 550 nm (0.442-0.625um) CMIP6 volcanic aerosol + + ! Optical depths at ca. 550 nm (0.442-0.625um) CMIP6 volcanic aerosol aodvisvolc(icol)=aodvisvolc(icol)+volc_ext_sun(icol,k,4)*deltah absvisvolc(icol)=absvisvolc(icol)+volc_ext_sun(icol,k,4) & *(1.0_r8-volc_omega_sun(icol,k,4))*deltah + end do ! k - endif ! daylight + endif ! daylight end do ! icol - ! Extinction and absorption for 0.55 um for the total aerosol, and AODs - if (do_aerocom) then - call outfld('BETOTVIS',betotvis,pcols,lchnk) - call outfld('BATOTVIS',batotvis,pcols,lchnk) - end if - ! call outfld('AODVIS ',aodvis ,pcols,lchnk) + ! Extinction and absorption for 0.55 um for the total aerosol, and AODs call outfld('AOD_VIS ',aodvis ,pcols,lchnk) call outfld('ABSVIS ',absvis ,pcols,lchnk) call outfld('AODVVOLC',aodvisvolc ,pcols,lchnk) call outfld('ABSVVOLC',absvisvolc ,pcols,lchnk) - !akc6+ call outfld('BVISVOLC',bevisvolc ,pcols,lchnk) - !akc6- - !tst - ! call outfld('AODVIS3D',aodvis3d,pcols,lchnk) - !tst - - ! AEROCOM***********AEROCOM**************AEROCOM***************below - - if (do_aerocom) then - - ! Initialize fields - do icol=1,ncol - daerh2o(icol)=0.0_r8 - vaercols(icol)=0.0_r8 - vaercoll(icol)=0.0_r8 - aaercols(icol)=0.0_r8 - aaercoll(icol)=0.0_r8 - do i=0,nmodes - dload(icol,i)=0.0_r8 - enddo - enddo - vnbcarr(:,:) = 0.0_r8 - vaitbcarr(:,:) = 0.0_r8 - cknorm(:,:,:) = 0.0_r8 - !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - - ! AeroCom diagnostics requiring table look-ups with ambient RH. - - do irf=0,0 - call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) - end do ! irf - !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - - do k=1,pver - do icol=1,ncol - - bebglt1t(icol,k)=0.0_r8 - bebggt1t(icol,k)=0.0_r8 - bebclt1t(icol,k)=0.0_r8 - bebcgt1t(icol,k)=0.0_r8 - beoclt1t(icol,k)=0.0_r8 - beocgt1t(icol,k)=0.0_r8 - bes4lt1t(icol,k)=0.0_r8 - bes4gt1t(icol,k)=0.0_r8 - bedustlt1(icol,k)=0.0_r8 - bedustgt1(icol,k)=0.0_r8 - besslt1(icol,k)=0.0_r8 - bessgt1(icol,k)=0.0_r8 - - bext440tot(icol,k)=0.0_r8 - babs440tot(icol,k)=0.0_r8 - bext500tot(icol,k)=0.0_r8 - babs500tot(icol,k)=0.0_r8 - bext550tot(icol,k)=0.0_r8 - babs550tot(icol,k)=0.0_r8 - bext670tot(icol,k)=0.0_r8 - babs670tot(icol,k)=0.0_r8 - bext870tot(icol,k)=0.0_r8 - babs870tot(icol,k)=0.0_r8 - - backsc550tot(icol,k)=0.0_r8 - - bebg440tot(icol,k)=0.0_r8 - bebg500tot(icol,k)=0.0_r8 - bebg550tot(icol,k)=0.0_r8 - babg550tot(icol,k)=0.0_r8 - bebg670tot(icol,k)=0.0_r8 - bebg870tot(icol,k)=0.0_r8 - - bebc440tot(icol,k)=0.0_r8 - bebc500tot(icol,k)=0.0_r8 - bebc550tot(icol,k)=0.0_r8 - babc550tot(icol,k)=0.0_r8 - bebc670tot(icol,k)=0.0_r8 - bebc870tot(icol,k)=0.0_r8 - - beoc440tot(icol,k)=0.0_r8 - beoc500tot(icol,k)=0.0_r8 - beoc550tot(icol,k)=0.0_r8 - baoc550tot(icol,k)=0.0_r8 - beoc670tot(icol,k)=0.0_r8 - beoc870tot(icol,k)=0.0_r8 - - besu440tot(icol,k)=0.0_r8 - besu500tot(icol,k)=0.0_r8 - besu550tot(icol,k)=0.0_r8 - basu550tot(icol,k)=0.0_r8 - besu670tot(icol,k)=0.0_r8 - besu870tot(icol,k)=0.0_r8 - - enddo - enddo - - do i=0,nbmodes - do k=1,pver - do icol=1,ncol - ! total internal extinction and absorption for 0.44, 0.50, 0.55, 0.68 and 0.87 um - bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext440(icol,k,i) - babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i) - bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext500(icol,k,i) - babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs500(icol,k,i) - bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext550(icol,k,i) - babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i) - bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext670(icol,k,i) - babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs670(icol,k,i) - bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext870(icol,k,i) - babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i) - backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%backsc550(icol,k,i) - - ! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um - ! for the whole background aerosol (icluding SO4,BC, and OC for modes 0-5) - bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg440(icol,k,i) - bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg500(icol,k,i) - bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg550(icol,k,i) - babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babg550(icol,k,i) - bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg670(icol,k,i) - bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg870(icol,k,i) - besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu440(icol,k,i) - besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu500(icol,k,i) - besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu550(icol,k,i) - basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%basu550(icol,k,i) - besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu670(icol,k,i) - besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu870(icol,k,i) - ! - ! Condensed OC on modes 1-4 and coagulated BC and OC on modes 5-10: - if(i>=1) then - bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc440(icol,k,i) - bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc500(icol,k,i) - bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc550(icol,k,i) - babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babc550(icol,k,i) - bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc670(icol,k,i) - bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc870(icol,k,i) - beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc440(icol,k,i) - beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc500(icol,k,i) - beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc550(icol,k,i) - baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%baoc550(icol,k,i) - beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc670(icol,k,i) - beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc870(icol,k,i) - endif ! i>=1 - if(i==6.or.i==7) then - bedustlt1(icol,k)=bedustlt1(icol,k) +Nnatk(icol,k,i)*bebglt1(icol,k,i) - bedustgt1(icol,k)=bedustgt1(icol,k) +Nnatk(icol,k,i)*bebggt1(icol,k,i) - elseif(i>=8.and.i<=10) then - besslt1(icol,k)=besslt1(icol,k) +Nnatk(icol,k,i)*bebglt1(icol,k,i) - bessgt1(icol,k)=bessgt1(icol,k) +Nnatk(icol,k,i)*bebggt1(icol,k,i) - endif - ! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: - bes4lt1t(icol,k)=bes4lt1t(icol,k) +Nnatk(icol,k,i)*bes4lt1(icol,k,i) - bes4gt1t(icol,k)=bes4gt1t(icol,k) +Nnatk(icol,k,i)*bes4gt1(icol,k,i) - ! Condensed OC on mode 1 and coagulated BC and OC on modes 5-10: - if(i>=1) then - bebclt1t(icol,k)=bebclt1t(icol,k) +Nnatk(icol,k,i)*bebclt1(icol,k,i) - bebcgt1t(icol,k)=bebcgt1t(icol,k) +Nnatk(icol,k,i)*bebcgt1(icol,k,i) - beoclt1t(icol,k)=beoclt1t(icol,k) +Nnatk(icol,k,i)*beoclt1(icol,k,i) - beocgt1t(icol,k)=beocgt1t(icol,k) +Nnatk(icol,k,i)*beocgt1(icol,k,i) - endif ! i>=1 - end do ! icol - enddo ! k - enddo ! i - - ! extinction/absorptions (km-1) for each background component - ! in the internal mixture are - do k=1,pver - do icol=1,ncol - bint440du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg440(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg440(icol,k,7) - bint500du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg500(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg500(icol,k,7) - bint550du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg550(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg550(icol,k,7) - bint670du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg670(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg670(icol,k,7) - bint870du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg870(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg870(icol,k,7) - bint440ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg440(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg440(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg440(icol,k,10) - bint500ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg500(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg500(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg500(icol,k,10) - bint550ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg550(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg550(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg550(icol,k,10) - bint670ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg670(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg670(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg670(icol,k,10) - bint870ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg870(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg870(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg870(icol,k,10) - baint550du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%babg550(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%babg550(icol,k,7) - baint550ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%babg550(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%babg550(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%babg550(icol,k,10) - end do - enddo - - ! Need to make the following substitutions - ! bebglt1 bebglt1n => extinction_coeffs%bebg550lt1 - ! bebggt1 bebggt1n => extinction_coeffs%bebg550gt1 - ! bebclt1 bebclt1n => extinction_coeffs%bebc550lt1 - ! bebcgt1 bebcgt1n => extinction_coeffs%bebc550gt1 - ! beoclt1 beoclt1n => extinction_coeffs%beoc550lt1 - ! beocgt1 beocgt1n => extinction_coeffs%beoc550gt1 - ! bes4lt1 bes4lt1n => extinction_coeffs%besu550lt1 - ! bes4gt1 bes4gt1n => extinction_coeffs%besu550gt1 - - do i=11,14 - do k=1,pver - do icol=1,ncol - be440x(icol,k,i) = extinction_coeffsn%bext440(icol,k,i-10) - ba440x(icol,k,i) = extinction_coeffsn%babs440(icol,k,i-10) - be500x(icol,k,i) = extinction_coeffsn%bext500(icol,k,i-10) - ba500x(icol,k,i) = extinction_coeffsn%babs500(icol,k,i-10) - be550x(icol,k,i) = extinction_coeffsn%bext550(icol,k,i-10) - ba550x(icol,k,i) = extinction_coeffsn%babs550(icol,k,i-10) - be670x(icol,k,i) = extinction_coeffsn%bext670(icol,k,i-10) - ba670x(icol,k,i) = extinction_coeffsn%babs670(icol,k,i-10) - be870x(icol,k,i) = extinction_coeffsn%bext870(icol,k,i-10) - ba870x(icol,k,i) = extinction_coeffsn%babs870(icol,k,i-10) - belt1x(icol,k,i) = extinction_coeffsn%bebg550lt1(icol,k,i-10) - begt1x(icol,k,i) = extinction_coeffsn%bebg550gt1(icol,k,i-10) - backsc550x(icol,k,i) = extinction_coeffsn%backsc550(icol,k,i-10) - end do - enddo - enddo - - ! The externally modes' contribution to extinction and absorption: - do k=1,pver - do icol=1,ncol - - !BC - vnbcarr(icol,k) = fnbc(icol,k)/(fnbc(icol,k) & - +(1.0_r8-fnbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) - vnbc = vnbcarr(icol,k) - bebc440xt(icol,k) =Nnatk(icol,k,12)*be440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) - babc440xt(icol,k) =Nnatk(icol,k,12)*ba440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) - bebc500xt(icol,k) =Nnatk(icol,k,12)*be500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) - babc500xt(icol,k) =Nnatk(icol,k,12)*ba500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) - bebc550xt(icol,k) =Nnatk(icol,k,12)*be550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) - babc550xt(icol,k) =Nnatk(icol,k,12)*ba550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) - bebc670xt(icol,k) =Nnatk(icol,k,12)*be670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) - babc670xt(icol,k) =Nnatk(icol,k,12)*ba670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) - bebc870xt(icol,k) =Nnatk(icol,k,12)*be870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) - babc870xt(icol,k) =Nnatk(icol,k,12)*ba870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) - bbclt1xt(icol,k)=Nnatk(icol,k,12)*belt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) - bbcgt1xt(icol,k)=Nnatk(icol,k,12)*begt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) - !OC - beoc440xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be440x(icol,k,14) - baoc440xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba440x(icol,k,14) - beoc500xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be500x(icol,k,14) - baoc500xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba500x(icol,k,14) - beoc550xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be550x(icol,k,14) - baoc550xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba550x(icol,k,14) - beoc670xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be670x(icol,k,14) - baoc670xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba670x(icol,k,14) - beoc870xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be870x(icol,k,14) - baoc870xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba870x(icol,k,14) - boclt1xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*belt1x(icol,k,14) - bocgt1xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*begt1x(icol,k,14) - ! Total (for all modes) absorption optical depth and backscattering - abs550_aer(icol,k)=babs550tot(icol,k) & - +Nnatk(icol,k,12)*ba550x(icol,k,12) & - +Nnatk(icol,k,14)*ba550x(icol,k,14) - abs550_aer(icol,k)=1.e-3_r8*abs550_aer(icol,k) - bs550_aer(icol,k)= backsc550tot(icol,k) & - +Nnatk(icol,k,12)*backsc550x(icol,k,12) & - +Nnatk(icol,k,14)*backsc550x(icol,k,14) - bs550_aer(icol,k)=1.e-3_r8*bs550_aer(icol,k) - ! - end do - enddo - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! collect AeroCom-fields for optical depth/absorption of each comp, - ! 3D and 2D, at 440, 500, 550, 670 and 870 nm, for all d, d<1um and d>1um - ! initialize 2d-fields - do icol=1,ncol - dod440(icol) = 0.0_r8 - abs440(icol) = 0.0_r8 - dod500(icol) = 0.0_r8 - abs500(icol) = 0.0_r8 - dod550(icol) = 0.0_r8 - abs550(icol) = 0.0_r8 - abs550alt(icol) = 0.0_r8 - dod670(icol) = 0.0_r8 - abs670(icol) = 0.0_r8 - dod870(icol) = 0.0_r8 - abs870(icol) = 0.0_r8 - ! - abs550_ss(icol) = 0.0_r8 - abs550_dust(icol) = 0.0_r8 - abs550_so4(icol) = 0.0_r8 - abs550_bc(icol) = 0.0_r8 - abs550_pom(icol) = 0.0_r8 - ! - dod440_ss(icol) = 0.0_r8 - dod440_dust(icol) = 0.0_r8 - dod440_so4(icol) = 0.0_r8 - dod440_bc(icol) = 0.0_r8 - dod440_pom(icol) = 0.0_r8 - dod500_ss(icol) = 0.0_r8 - dod500_dust(icol) = 0.0_r8 - dod500_so4(icol) = 0.0_r8 - dod500_bc(icol) = 0.0_r8 - dod500_pom(icol) = 0.0_r8 - dod550_ss(icol) = 0.0_r8 - dod550_dust(icol) = 0.0_r8 - dod550_so4(icol) = 0.0_r8 - dod550_bc(icol) = 0.0_r8 - dod550_pom(icol) = 0.0_r8 - dod670_ss(icol) = 0.0_r8 - dod670_dust(icol) = 0.0_r8 - dod670_so4(icol) = 0.0_r8 - dod670_bc(icol) = 0.0_r8 - dod670_pom(icol) = 0.0_r8 - dod870_ss(icol) = 0.0_r8 - dod870_dust(icol) = 0.0_r8 - dod870_so4(icol) = 0.0_r8 - dod870_bc(icol) = 0.0_r8 - dod870_pom(icol) = 0.0_r8 - dod550lt1_ss(icol) = 0.0_r8 - dod550gt1_ss(icol) = 0.0_r8 - dod550lt1_dust(icol) = 0.0_r8 - dod550gt1_dust(icol) = 0.0_r8 - dod550lt1_so4(icol) = 0.0_r8 - dod550gt1_so4(icol) = 0.0_r8 - dod550lt1_bc(icol) = 0.0_r8 - dod550gt1_bc(icol) = 0.0_r8 - dod550lt1_pom(icol) = 0.0_r8 - dod550gt1_pom(icol) = 0.0_r8 - do k=1,pver - abs4403d(icol,k) = 0.0_r8 - abs5003d(icol,k) = 0.0_r8 - abs5503d(icol,k) = 0.0_r8 - abs6703d(icol,k) = 0.0_r8 - abs8703d(icol,k) = 0.0_r8 - abs5503dalt(icol,k) = 0.0_r8 - enddo - enddo - - do icol=1,ncol - do k=1,pver - ! Layer thickness, unit km - deltah=deltah_km(icol,k) - ! if(k==pver) write(*,*) 'icol, deltah(pmxsub)=', icol, deltah - ! 3D optical depths for monthly averages - !SS - dod4403d_ss(icol,k) = bint440ss(icol,k)*deltah - dod5003d_ss(icol,k) = bint500ss(icol,k)*deltah - dod5503d_ss(icol,k) = bint550ss(icol,k)*deltah - abs5503d_ss(icol,k) = baint550ss(icol,k)*deltah - dod6703d_ss(icol,k) = bint670ss(icol,k)*deltah - dod8703d_ss(icol,k) = bint870ss(icol,k)*deltah - !DUST - dod4403d_dust(icol,k) = bint440du(icol,k)*deltah - dod5003d_dust(icol,k) = bint500du(icol,k)*deltah - dod5503d_dust(icol,k) = bint550du(icol,k)*deltah - abs5503d_dust(icol,k) = baint550du(icol,k)*deltah - dod6703d_dust(icol,k) = bint670du(icol,k)*deltah - dod8703d_dust(icol,k) = bint870du(icol,k)*deltah - !SO4 - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - dod4403d_so4(icol,k) = (besu440tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5003d_so4(icol,k) = (besu500tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5503d_so4(icol,k) = (besu550tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - abs5503d_so4(icol,k) = (basu550tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod6703d_so4(icol,k) = (besu670tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod8703d_so4(icol,k) = (besu870tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - !BC - vaitbcarr(icol,k) = faitbc(icol,k)/(faitbc(icol,k) & - +(1.0_r8-faitbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) - vaitbc = vaitbcarr(icol,k) - dod4403d_bc(icol,k) = (bebc440tot(icol,k)+bebc440xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg440(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5003d_bc(icol,k) = (bebc500tot(icol,k)+bebc500xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg500(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5503d_bc(icol,k) = (bebc550tot(icol,k)+bebc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) - abs5503d_bc(icol,k) = (babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%babg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod6703d_bc(icol,k) = (bebc670tot(icol,k)+bebc670xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg670(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod8703d_bc(icol,k) = (bebc870tot(icol,k)+bebc870xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg870(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) - !OC - !soa + v_soana part of mode 11 for the OC volume fraction of that mode - ! v_soana(icol,k) - dod4403d_pom(icol,k) = (beoc440tot(icol,k)+beoc440xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg440(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5003d_pom(icol,k) = (beoc500tot(icol,k)+beoc500xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg500(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5503d_pom(icol,k) = (beoc550tot(icol,k)+beoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - abs5503d_pom(icol,k) = (baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod6703d_pom(icol,k) = (beoc670tot(icol,k)+beoc670xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg670(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod8703d_pom(icol,k) = (beoc870tot(icol,k)+beoc870xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg870(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - - ec550_so4(icol,k) = 1.e-3*dod5503d_so4(icol,k)/deltah - ec550_bc(icol,k) = 1.e-3*dod5503d_bc(icol,k)/deltah - ec550_pom(icol,k) = 1.e-3*dod5503d_pom(icol,k)/deltah - ec550_ss(icol,k) = 1.e-3*dod5503d_ss(icol,k)/deltah - ec550_du(icol,k) = 1.e-3*dod5503d_dust(icol,k)/deltah - ec550_aer(icol,k) = ec550_so4(icol,k)+ec550_bc(icol,k)+ec550_pom(icol,k) & - + ec550_ss(icol,k)+ec550_du(icol,k) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! Total 3D optical depths/abs. for column integrations - dod4403d(icol,k) = dod4403d_ss(icol,k)+dod4403d_dust(icol,k) & - +dod4403d_so4(icol,k)+dod4403d_bc(icol,k) & - +dod4403d_pom(icol,k) - dod5003d(icol,k) = dod5003d_ss(icol,k)+dod5003d_dust(icol,k) & - +dod5003d_so4(icol,k)+dod5003d_bc(icol,k) & - +dod5003d_pom(icol,k) - dod5503d(icol,k) = dod5503d_ss(icol,k)+dod5503d_dust(icol,k) & - +dod5503d_so4(icol,k)+dod5503d_bc(icol,k) & - +dod5503d_pom(icol,k) - dod6703d(icol,k) = dod6703d_ss(icol,k)+dod6703d_dust(icol,k) & - +dod6703d_so4(icol,k)+dod6703d_bc(icol,k) & - +dod6703d_pom(icol,k) - dod8703d(icol,k) = dod8703d_ss(icol,k)+dod8703d_dust(icol,k) & - +dod8703d_so4(icol,k)+dod8703d_bc(icol,k) & - +dod8703d_pom(icol,k) - abs5503d(icol,k) = abs5503d_ss(icol,k)+abs5503d_dust(icol,k) & - +abs5503d_so4(icol,k)+abs5503d_bc(icol,k) & - +abs5503d_pom(icol,k) - ! (Note: Local abs550alt is up to 6% larger (annually averaged) in typical b.b. - ! regions, compared to abs550. This is most likely most correct, but should be checked!) - do i=0,10 - abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i)*deltah - abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs500(icol,k,i)*deltah - abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs670(icol,k,i)*deltah - abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i)*deltah - abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i)*deltah - enddo - do i=11,14 - abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs440(icol,k,i-10)*deltah - abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs500(icol,k,i-10)*deltah - abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs670(icol,k,i-10)*deltah - abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs870(icol,k,i-10)*deltah - abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs550(icol,k,i-10)*deltah - enddo - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! optical depths for d<1um and d>1um (r<0.5um and r>0.5um) - !SS - dod5503dlt1_ss(icol,k) = besslt1(icol,k)*deltah - dod5503dgt1_ss(icol,k) = bessgt1(icol,k)*deltah - !DUST - dod5503dlt1_dust(icol,k) = bedustlt1(icol,k)*deltah - dod5503dgt1_dust(icol,k) = bedustgt1(icol,k)*deltah - - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - dod5503dlt1_so4(icol,k) = (bes4lt1t(icol,k) & ! condensate - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebglt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5503dgt1_so4(icol,k) = (bes4gt1t(icol,k) & ! condensate + n-mode (11) - + Nnatk(icol,k,1)*bebggt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebggt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - !BC - dod5503dlt1_bc(icol,k) = (bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebglt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebglt1(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5503dgt1_bc(icol,k) = (bebcgt1t(icol,k)+bbcgt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebggt1(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebggt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebggt1(icol,k,0))*deltah ! background, BC(ax) mode (0) - !OC - !soa + v_soana part of mode 11 for the OC volume fraction of that mode - dod5503dlt1_pom(icol,k) = (beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebglt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5503dgt1_pom(icol,k) = (beocgt1t(icol,k)+bocgt1xt(icol,k) & ! coagulated + n-mode OC&OC (14) - + Nnatk(icol,k,1)*bebggt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*bebggt1(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebggt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! Column integrated optical depths/abs., total and for each constituent - dod440(icol) = dod440(icol)+dod4403d(icol,k) - abs440(icol) = abs440(icol)+abs4403d(icol,k) - dod500(icol) = dod500(icol)+dod5003d(icol,k) - abs500(icol) = abs500(icol)+abs5003d(icol,k) - dod550(icol) = dod550(icol)+dod5503d(icol,k) - abs550(icol) = abs550(icol)+abs5503d(icol,k) - abs550alt(icol) = abs550alt(icol)+abs5503dalt(icol,k) - dod670(icol) = dod670(icol)+dod6703d(icol,k) - abs670(icol) = abs670(icol)+abs6703d(icol,k) - dod870(icol) = dod870(icol)+dod8703d(icol,k) - abs870(icol) = abs870(icol)+abs8703d(icol,k) - ! Added abs components - abs550_ss(icol) = abs550_ss(icol)+abs5503d_ss(icol,k) - abs550_dust(icol) = abs550_dust(icol)+abs5503d_dust(icol,k) - abs550_so4(icol) = abs550_so4(icol)+abs5503d_so4(icol,k) - abs550_bc(icol) = abs550_bc(icol)+abs5503d_bc(icol,k) - abs550_pom(icol) = abs550_pom(icol)+abs5503d_pom(icol,k) - ! - dod440_ss(icol) = dod440_ss(icol)+dod4403d_ss(icol,k) - dod440_dust(icol) = dod440_dust(icol)+dod4403d_dust(icol,k) - dod440_so4(icol) = dod440_so4(icol)+dod4403d_so4(icol,k) - dod440_bc(icol) = dod440_bc(icol)+dod4403d_bc(icol,k) - dod440_pom(icol) = dod440_pom(icol)+dod4403d_pom(icol,k) - dod500_ss(icol) = dod500_ss(icol)+dod5003d_ss(icol,k) - dod500_dust(icol) = dod500_dust(icol)+dod5003d_dust(icol,k) - dod500_so4(icol) = dod500_so4(icol)+dod5003d_so4(icol,k) - dod500_bc(icol) = dod500_bc(icol)+dod5003d_bc(icol,k) - dod500_pom(icol) = dod500_pom(icol)+dod5003d_pom(icol,k) - dod550_ss(icol) = dod550_ss(icol)+dod5503d_ss(icol,k) - dod550_dust(icol) = dod550_dust(icol)+dod5503d_dust(icol,k) - dod550_so4(icol) = dod550_so4(icol)+dod5503d_so4(icol,k) - dod550_bc(icol) = dod550_bc(icol)+dod5503d_bc(icol,k) - dod550_pom(icol) = dod550_pom(icol)+dod5503d_pom(icol,k) - dod670_ss(icol) = dod670_ss(icol)+dod6703d_ss(icol,k) - dod670_dust(icol) = dod670_dust(icol)+dod6703d_dust(icol,k) - dod670_so4(icol) = dod670_so4(icol)+dod6703d_so4(icol,k) - dod670_bc(icol) = dod670_bc(icol)+dod6703d_bc(icol,k) - dod670_pom(icol) = dod670_pom(icol)+dod6703d_pom(icol,k) - dod870_ss(icol) = dod870_ss(icol)+dod8703d_ss(icol,k) - dod870_dust(icol) = dod870_dust(icol)+dod8703d_dust(icol,k) - dod870_so4(icol) = dod870_so4(icol)+dod8703d_so4(icol,k) - dod870_bc(icol) = dod870_bc(icol)+dod8703d_bc(icol,k) - dod870_pom(icol) = dod870_pom(icol)+dod8703d_pom(icol,k) - dod550lt1_ss(icol) = dod550lt1_ss(icol)+dod5503dlt1_ss(icol,k) - dod550gt1_ss(icol) = dod550gt1_ss(icol)+dod5503dgt1_ss(icol,k) - dod550lt1_dust(icol) = dod550lt1_dust(icol)+dod5503dlt1_dust(icol,k) - dod550gt1_dust(icol) = dod550gt1_dust(icol)+dod5503dgt1_dust(icol,k) - dod550lt1_so4(icol) = dod550lt1_so4(icol)+dod5503dlt1_so4(icol,k) - dod550gt1_so4(icol) = dod550gt1_so4(icol)+dod5503dgt1_so4(icol,k) - dod550lt1_bc(icol) = dod550lt1_bc(icol)+dod5503dlt1_bc(icol,k) - dod550gt1_bc(icol) = dod550gt1_bc(icol)+dod5503dgt1_bc(icol,k) - dod550lt1_pom(icol) = dod550lt1_pom(icol)+dod5503dlt1_pom(icol,k) - dod550gt1_pom(icol) = dod550gt1_pom(icol)+dod5503dgt1_pom(icol,k) - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - enddo ! k - - enddo ! icol - - ! extinction, absorption (m-1) and backscatter coefficients (m-1 sr-1) - call outfld('EC550AER',ec550_aer,pcols,lchnk) - call outfld('ABS550_A',abs550_aer,pcols,lchnk) - call outfld('BS550AER',bs550_aer,pcols,lchnk) - ! - ! speciated extinction coefficients (m-1) - call outfld('EC550SO4',ec550_so4,pcols,lchnk) - call outfld('EC550BC ',ec550_bc ,pcols,lchnk) - call outfld('EC550POM',ec550_pom,pcols,lchnk) - call outfld('EC550SS ',ec550_ss ,pcols,lchnk) - call outfld('EC550DU ',ec550_du ,pcols,lchnk) - ! - ! optical depths and absorption as requested by AeroCom - ! notation: 3=3D, D=DOD, A=ABS, LT=d<1um, GT=d>1um - call outfld('DOD440 ',dod440 ,pcols,lchnk) - call outfld('ABS440 ',abs440 ,pcols,lchnk) - call outfld('DOD500 ',dod500 ,pcols,lchnk) - call outfld('ABS500 ',abs500 ,pcols,lchnk) - call outfld('DOD550 ',dod550 ,pcols,lchnk) - call outfld('ABS550 ',abs550 ,pcols,lchnk) - call outfld('ABS550AL',abs550alt,pcols,lchnk) - call outfld('DOD670 ',dod670 ,pcols,lchnk) - call outfld('ABS670 ',abs670 ,pcols,lchnk) - call outfld('DOD870 ',dod870 ,pcols,lchnk) - call outfld('ABS870 ',abs870 ,pcols,lchnk) - call outfld('A550_SS ',abs550_ss ,pcols,lchnk) - call outfld('A550_DU ',abs550_dust,pcols,lchnk) - call outfld('A550_SO4',abs550_so4 ,pcols,lchnk) - call outfld('A550_BC ',abs550_bc ,pcols,lchnk) - call outfld('A550_POM',abs550_pom ,pcols,lchnk) - ! - call outfld('D440_SS ',dod440_ss ,pcols,lchnk) - call outfld('D440_DU ',dod440_dust,pcols,lchnk) - call outfld('D440_SO4',dod440_so4 ,pcols,lchnk) - call outfld('D440_BC ',dod440_bc ,pcols,lchnk) - call outfld('D440_POM',dod440_pom ,pcols,lchnk) - call outfld('D500_SS ',dod500_ss ,pcols,lchnk) - call outfld('D500_DU ',dod500_dust,pcols,lchnk) - call outfld('D500_SO4',dod500_so4 ,pcols,lchnk) - call outfld('D500_BC ',dod500_bc ,pcols,lchnk) - call outfld('D500_POM',dod500_pom ,pcols,lchnk) - call outfld('D550_SS ',dod550_ss ,pcols,lchnk) - call outfld('D550_DU ',dod550_dust,pcols,lchnk) - call outfld('D550_SO4',dod550_so4 ,pcols,lchnk) - call outfld('D550_BC ',dod550_bc ,pcols,lchnk) - call outfld('D550_POM',dod550_pom ,pcols,lchnk) - call outfld('D670_SS ',dod670_ss ,pcols,lchnk) - call outfld('D670_DU ',dod670_dust,pcols,lchnk) - call outfld('D670_SO4',dod670_so4 ,pcols,lchnk) - call outfld('D670_BC ',dod670_bc ,pcols,lchnk) - call outfld('D670_POM',dod670_pom ,pcols,lchnk) - call outfld('D870_SS ',dod870_ss ,pcols,lchnk) - call outfld('D870_DU ',dod870_dust,pcols,lchnk) - call outfld('D870_SO4',dod870_so4 ,pcols,lchnk) - call outfld('D870_BC ',dod870_bc ,pcols,lchnk) - call outfld('D870_POM',dod870_pom ,pcols,lchnk) - call outfld('DLT_SS ',dod550lt1_ss,pcols,lchnk) - call outfld('DGT_SS ',dod550gt1_ss,pcols,lchnk) - call outfld('DLT_DUST',dod550lt1_dust,pcols,lchnk) - call outfld('DGT_DUST',dod550gt1_dust,pcols,lchnk) - call outfld('DLT_SO4 ',dod550lt1_so4,pcols,lchnk) - call outfld('DGT_SO4 ',dod550gt1_so4,pcols,lchnk) - call outfld('DLT_BC ',dod550lt1_bc,pcols,lchnk) - call outfld('DGT_BC ',dod550gt1_bc,pcols,lchnk) - call outfld('DLT_POM ',dod550lt1_pom,pcols,lchnk) - call outfld('DGT_POM ',dod550gt1_pom,pcols,lchnk) - !tst - ! call outfld('DOD5503D',dod5503d,pcols,lchnk) - !tst - !- call outfld('ABS5503D',abs5503d,pcols,lchnk) - !- call outfld('D443_SS ',dod4403d_ss ,pcols,lchnk) - !- call outfld('D443_DU ',dod4403d_dust,pcols,lchnk) - !- call outfld('D443_SO4',dod4403d_so4 ,pcols,lchnk) - !- call outfld('D443_BC ',dod4403d_bc ,pcols,lchnk) - !- call outfld('D443_POM',dod4403d_pom ,pcols,lchnk) - !- call outfld('D503_SS ',dod5003d_ss ,pcols,lchnk) - !- call outfld('D503_DU ',dod5003d_dust,pcols,lchnk) - !- call outfld('D503_SO4',dod5003d_so4 ,pcols,lchnk) - !- call outfld('D503_BC ',dod5003d_bc ,pcols,lchnk) - !- call outfld('D503_POM',dod5003d_pom ,pcols,lchnk) - !- call outfld('D553_SS ',dod5503d_ss ,pcols,lchnk) - !- call outfld('D553_DU ',dod5503d_dust,pcols,lchnk) - !- call outfld('D553_SO4',dod5503d_so4 ,pcols,lchnk) - !- call outfld('D553_BC ',dod5503d_bc ,pcols,lchnk) - !- call outfld('D553_POM',dod5503d_pom ,pcols,lchnk) - !- call outfld('D673_SS ',dod6703d_ss ,pcols,lchnk) - !- call outfld('D673_DU ',dod6703d_dust,pcols,lchnk) - !- call outfld('D673_SO4',dod6703d_so4 ,pcols,lchnk) - !- call outfld('D673_BC ',dod6703d_bc ,pcols,lchnk) - !- call outfld('D673_POM',dod6703d_pom ,pcols,lchnk) - !- call outfld('D873_SS ',dod8703d_ss ,pcols,lchnk) - !- call outfld('D873_DU ',dod8703d_dust,pcols,lchnk) - !- call outfld('D873_SO4',dod8703d_so4 ,pcols,lchnk) - !- call outfld('D873_BC ',dod8703d_bc ,pcols,lchnk) - !- call outfld('D873_POM',dod8703d_pom ,pcols,lchnk) - - - !000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000000 - - ! Dry parameters of each aerosol component - ! BC(ax) mode - call aerodry_prop%intdrypar0(lchnk, ncol, Nnatk) - - ! SO4&SOA(Ait,n) mode - call aerodry_prop%intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) - - ! BC(Ait,n) and OC(Ait,n) modes - call aerodry_prop%intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1) - - ! BC&OC(Ait,n) mode ------ fcm not valid here (=0). Use faitbc or fnbc instead - call aerodry_prop%intdrypar4(lchnk, ncol, Nnatk, xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & - xct, ict1, xfac, ifac1, xfaq, ifaq1) - - ! SO4(Ait75) (5), mineral (6-7) and Sea-salt (8-10) modes: - call aerodry_prop%intdrypar5to10(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) - - do k=1,pver - do icol=1,ncol - c_ss(icol,k)=0.0_r8 - c_mi(icol,k)=0.0_r8 - enddo - enddo - - do k=1,pver - do icol=1,ncol - ! mineral and sea-salt background concentrations, internally mixed - c_mi(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg(icol,k,6) & - +Nnatk(icol,k,7) * aerodry_prop%cintbg(icol,k,7) - c_mi05(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg05(icol,k,6) & - +Nnatk(icol,k,7) * aerodry_prop%cintbg05(icol,k,7) - c_mi125(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg125(icol,k,6)& - +Nnatk(icol,k,7) * aerodry_prop%cintbg125(icol,k,7) - c_ss(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg(icol,k,8) & - +Nnatk(icol,k,9) * aerodry_prop%cintbg(icol,k,9) & - +Nnatk(icol,k,10) * aerodry_prop%cintbg(icol,k,10) - c_ss05(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg05(icol,k,8) & - +Nnatk(icol,k,9) * aerodry_prop%cintbg05(icol,k,9) & - +Nnatk(icol,k,10) * aerodry_prop%cintbg05(icol,k,10) - c_ss125(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg125(icol,k,8)& - +Nnatk(icol,k,9) * aerodry_prop%cintbg125(icol,k,9) & - +Nnatk(icol,k,10) * aerodry_prop%cintbg125(icol,k,10) - - ! internally mixed bc and oc (from coagulation) and so4 concentrations - ! (sa=so4(aq) and sc=so4(cond+coag), separated because of different density: - ! necessary for calculation of volume fractions!), and total aerosol surface - ! areas and volumes. - c_bc(icol,k)=0.0_r8 - c_bc05(icol,k)=0.0_r8 - c_bc125(icol,k)=0.0_r8 - c_oc(icol,k)=0.0_r8 - c_oc05(icol,k)=0.0_r8 - c_oc125(icol,k)=0.0_r8 - c_s4(icol,k)=0.0_r8 - c_s4_a(icol,k)=0.0_r8 - c_s4_1(icol,k)=0.0_r8 - c_s4_5(icol,k)=0.0_r8 - c_sa(icol,k)=0.0_r8 - c_sa05(icol,k)=0.0_r8 - c_sa125(icol,k)=0.0_r8 - c_sc(icol,k)=0.0_r8 - c_sc05(icol,k)=0.0_r8 - c_sc125(icol,k)=0.0_r8 - aaeros_tot(icol,k)=0.0_r8 - aaerol_tot(icol,k)=0.0_r8 - vaeros_tot(icol,k)=0.0_r8 - vaerol_tot(icol,k)=0.0_r8 - c_bc_0(icol,k)=0.0_r8 - c_bc_2(icol,k)=0.0_r8 - c_bc_4(icol,k)=0.0_r8 - c_bc_12(icol,k)=0.0_r8 - c_bc_14(icol,k)=0.0_r8 - c_oc_4(icol,k)=0.0_r8 - c_oc_14(icol,k)=0.0_r8 - c_tot(icol,k)=0.0_r8 - c_tot125(icol,k)=0.0_r8 - c_tot05(icol,k)=0.0_r8 - c_pm25(icol,k)=0.0_r8 - c_pm1(icol,k)=0.0_r8 - mmr_pm25(icol,k)=0.0_r8 - mmr_pm1(icol,k)=0.0_r8 - - do i=0,nbmodes - if(i.ne.3) then - c_bc(icol,k) = c_bc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc(icol,k,i) - c_bc05(icol,k) = c_bc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc05(icol,k,i) - c_bc125(icol,k) = c_bc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc125(icol,k,i) - c_oc(icol,k) = c_oc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc(icol,k,i) - c_oc05(icol,k) = c_oc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc05(icol,k,i) - c_oc125(icol,k) = c_oc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc125(icol,k,i) - c_sa(icol,k) = c_sa(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa(icol,k,i) - c_sa05(icol,k) = c_sa05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa05(icol,k,i) - c_sa125(icol,k) = c_sa125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa125(icol,k,i) - c_sc(icol,k) = c_sc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc(icol,k,i) - c_sc05(icol,k) = c_sc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc05(icol,k,i) - c_sc125(icol,k) = c_sc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc125(icol,k,i) - aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeros(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerol(icol,k,i) - vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeros(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerol(icol,k,i) - endif - enddo - ! add dry aerosol area and volume of externally mixed modes - do i=nbmp1,nmodes - aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerosn(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeroln(icol,k,i) - vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerosn(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeroln(icol,k,i) - end do - - !c_er3d - ! Effective radii for particles smaller and greater than 0.5um, - ! and for all radii, in each layer (er=3*V/A): - erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) /(aaeros_tot(icol,k)+eps) - ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) /(aaerol_tot(icol,k)+eps) - er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) - - !c_er3d - ! column integrated dry aerosol surface areas and volumes - ! for r<0.5um and r>0.5um (s and l, respectively). - aaercols(icol)=aaercols(icol)+aaeros_tot(icol,k) - aaercoll(icol)=aaercoll(icol)+aaerol_tot(icol,k) - vaercols(icol)=vaercols(icol)+vaeros_tot(icol,k) - vaercoll(icol)=vaercoll(icol)+vaerol_tot(icol,k) - - ! then add background and externally mixed BC, OC and SO4 to mass concentrations - c_bc_ac(icol,k)= c_bc(icol,k) - c_bc_0(icol,k) = Nnatk(icol,k,0) * aerodry_prop%cintbg(icol,k,0) - c_bc_2(icol,k) = Nnatk(icol,k,2) * aerodry_prop%cintbg(icol,k,2) - c_bc_4(icol,k) = Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*faitbc(icol,k) - c_bc_12(icol,k)= Nnatk(icol,k,12) * aerodry_prop%cknorm(icol,k,12) - c_bc_14(icol,k)= Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) - c_bc(icol,k) = c_bc(icol,k) & - +Nnatk(icol,k,2) * aerodry_prop%cintbg(icol,k,2) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4) * faitbc(icol,k) & - +Nnatk(icol,k,0) * aerodry_prop%cintbg(icol,k,0) & - +Nnatk(icol,k,12) * aerodry_prop%cknorm(icol,k,12) & - +Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) - c_bc05(icol,k) = c_bc05(icol,k) & - +Nnatk(icol,k,2) * aerodry_prop%cintbg05(icol,k,2) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg05(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0) * aerodry_prop%cintbg05(icol,k,0) & - +Nnatk(icol,k,12) * aerodry_prop%cknlt05(icol,k,12) & - +Nnatk(icol,k,14) * aerodry_prop%cknlt05(icol,k,14)*fnbc(icol,k) - c_bc125(icol,k) = c_bc125(icol,k) & - +Nnatk(icol,k,2) * aerodry_prop%cintbg125(icol,k,2) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg125(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0) * aerodry_prop%cintbg125(icol,k,0) & - +Nnatk(icol,k,12) * aerodry_prop%ckngt125(icol,k,12) & - +Nnatk(icol,k,14) * aerodry_prop%ckngt125(icol,k,14)*fnbc(icol,k) - c_oc_ac(icol,k)= c_oc(icol,k) - c_oc_4(icol,k) = Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) - c_oc_14(icol,k) = Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc(icol,k) = c_oc(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*f_soana(icol,k) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc05(icol,k) = c_oc05(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg05(icol,k,1)*f_soana(icol,k) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14) * aerodry_prop%cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc125(icol,k) = c_oc125(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg125(icol,k,1)*f_soana(icol,k) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14) * aerodry_prop%ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_s4(icol,k) = c_sa(icol,k)+c_sc(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5) * aerodry_prop%cintbg(icol,k,5) - c_s405(icol,k) = c_sa05(icol,k)+c_sc05(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5) * aerodry_prop%cintbg05(icol,k,5) - c_s4125(icol,k) = c_sa125(icol,k)+c_sc125(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5) * aerodry_prop%cintbg125(icol,k,5) - - c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) + c_mi(icol,k) + c_ss(icol,k) - c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) + c_mi125(icol,k) + c_ss125(icol,k) - c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) + c_mi05(icol,k) + c_ss05(icol,k) - c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) - c_pm1(icol,k) = c_tot05(icol,k) - - ! mass mixing ratio: - mmr_pm25(icol,k) = 1.e-9*c_pm25(icol,k)/rhoda(icol,k) - mmr_pm1(icol,k) = 1.e-9*c_pm1(icol,k)/rhoda(icol,k) - - ! converting from S to SO4 concentrations is no longer necessary, since - ! sc=H2SO4 and sa=(NH4)2SO4 now, not SO4 as in CAM4-Oslo - ! c_s4(icol,k)=c_s4(icol,k)/3._r8 - ! c_s405(icol,k)=c_s405(icol,k)/3._r8 - ! c_s4125(icol,k)=c_s4125(icol,k)/3._r8 - - c_s4_a(icol,k) = c_sa(icol,k)+c_sc(icol,k) - c_s4_1(icol,k) = Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) - c_s4_5(icol,k) = Nnatk(icol,k,5) * aerodry_prop%cintbg05(icol,k,5) - - end do ! icol - enddo ! k - - ! Total PM and PM2.5 (dry r>1.25um), surface values (ug/m3) - do icol=1,ncol - c_tots(icol) = c_tot(icol,pver) - c_tot125s(icol) = c_tot125(icol,pver) - c_pm25s(icol) = c_pm25(icol,pver) - enddo - - ! Effective, column integrated, radii for particles - ! smaller and greater than 0.5um, and for all radii - do icol=1,ncol - derlt05(icol)=3.0_r8*vaercols(icol)/(aaercols(icol)+eps) - dergt05(icol)=3.0_r8*vaercoll(icol)/(aaercoll(icol)+eps) - der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) /(aaercols(icol)+aaercoll(icol)+eps) - enddo - - do icol=1,ncol - dload_s4(icol)=0.0_r8 - dload_s4_a(icol)=0.0_r8 - dload_s4_1(icol)=0.0_r8 - dload_s4_5(icol)=0.0_r8 - dload_oc(icol)=0.0_r8 - dload_bc(icol)=0.0_r8 - dload_bc_ac(icol)=0.0_r8 - dload_bc_0(icol)=0.0_r8 - dload_bc_2(icol)=0.0_r8 - dload_bc_4(icol)=0.0_r8 - dload_bc_12(icol)=0.0_r8 - dload_bc_14(icol)=0.0_r8 - dload_oc_ac(icol)=0.0_r8 - dload_oc_4(icol)=0.0_r8 - dload_oc_14(icol)=0.0_r8 - do k=1,pver - ! Layer thickness, unit km - !- deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) - deltah=deltah_km(icol,k) - ! Modal and total mass concentrations for clean and dry aerosol, - ! i.e. not including coag./cond./Aq. BC,OC,SO4 or condensed water. - ! Units: ug/m3 for concentrations and mg/m2 (--> kg/m2 later) for mass loading. - do i=0,nmodes - ck(icol,k,i)=cknorm(icol,k,i)*Nnatk(icol,k,i) - dload3d(icol,k,i)=ck(icol,k,i)*deltah - dload(icol,i)=dload(icol,i)+dload3d(icol,k,i) - enddo - nnat_0(icol,k) =Nnatk(icol,k,0) - nnat_1(icol,k) =Nnatk(icol,k,1) - nnat_2(icol,k) =Nnatk(icol,k,2) - nnat_4(icol,k) =Nnatk(icol,k,4) - nnat_5(icol,k) =Nnatk(icol,k,5) - nnat_6(icol,k) =Nnatk(icol,k,6) - nnat_7(icol,k) =Nnatk(icol,k,7) - nnat_8(icol,k) =Nnatk(icol,k,8) - nnat_9(icol,k) =Nnatk(icol,k,9) - nnat_10(icol,k)=Nnatk(icol,k,10) - nnat_12(icol,k)=Nnatk(icol,k,12) - nnat_14(icol,k)=Nnatk(icol,k,14) - ! mineral and sea-salt mass concentrations - cmin(icol,k)=ck(icol,k,6)+ck(icol,k,7) - cseas(icol,k)=ck(icol,k,8)+ck(icol,k,9)+ck(icol,k,10) - ! Aerocom: Condensed water loading (mg_m2) - daerh2o(icol)=daerh2o(icol)+Cwater(icol,k)*deltah - ! just for checking purposes: - dload_s4(icol)=dload_s4(icol)+c_s4(icol,k)*deltah - dload_s4_a(icol)=dload_s4_a(icol)+c_s4_a(icol,k)*deltah - dload_s4_1(icol)=dload_s4_1(icol)+c_s4_1(icol,k)*deltah - dload_s4_5(icol)=dload_s4_5(icol)+c_s4_5(icol,k)*deltah - dload_oc(icol)=dload_oc(icol)+c_oc(icol,k)*deltah - dload_bc(icol)=dload_bc(icol)+c_bc(icol,k)*deltah - ! - dload_bc_ac(icol)=dload_bc_ac(icol)+c_bc_ac(icol,k)*deltah - dload_bc_0(icol)=dload_bc_0(icol)+c_bc_0(icol,k)*deltah - dload_bc_2(icol)=dload_bc_2(icol)+c_bc_2(icol,k)*deltah - dload_bc_4(icol)=dload_bc_4(icol)+c_bc_4(icol,k)*deltah - dload_bc_12(icol)=dload_bc_12(icol)+c_bc_12(icol,k)*deltah - dload_bc_14(icol)=dload_bc_14(icol)+c_bc_14(icol,k)*deltah - dload_oc_ac(icol)=dload_oc_ac(icol)+c_oc_ac(icol,k)*deltah - dload_oc_4(icol)=dload_oc_4(icol)+c_oc_4(icol,k)*deltah - dload_oc_14(icol)=dload_oc_14(icol)+c_oc_14(icol,k)*deltah - ! - end do ! k - dload_mi(icol)=dload(icol,6)+dload(icol,7) - dload_ss(icol)=dload(icol,8)+dload(icol,9)+dload(icol,10) - end do ! icol - - ! Internally and externally mixed dry concentrations (ug/m3) of - ! SO4, BC and OC, for all r, r<0.5um and r>1.25um... - ! call outfld('C_BCPM ',c_bc ,pcols,lchnk) - ! call outfld('C_BC05 ',c_bc05 ,pcols,lchnk) - ! call outfld('C_BC125 ',c_bc125,pcols,lchnk) - ! call outfld('C_OCPM ',c_oc ,pcols,lchnk) - ! call outfld('C_OC05 ',c_oc05 ,pcols,lchnk) - ! call outfld('C_OC125 ',c_oc125,pcols,lchnk) - ! call outfld('C_S4PM ',c_s4 ,pcols,lchnk) - ! call outfld('C_S405 ',c_s405 ,pcols,lchnk) - ! call outfld('C_S4125 ',c_s4125,pcols,lchnk) - ! ... and of background components for all r, r<0.5um and r>1.25um - ! call outfld('C_MIPM ',c_mi ,pcols,lchnk) - ! call outfld('C_MI05 ',c_mi05 ,pcols,lchnk) - ! call outfld('C_MI125 ',c_mi125,pcols,lchnk) - ! call outfld('C_SSPM ',c_ss ,pcols,lchnk) - ! call outfld('C_SS05 ',c_ss05 ,pcols,lchnk) - ! call outfld('C_SS125 ',c_ss125,pcols,lchnk) - call outfld('PMTOT ',c_tots ,pcols,lchnk) - call outfld('PM25 ',c_pm25s ,pcols,lchnk) - !akc6+ - call outfld('PM2P5 ',c_pm25 ,pcols,lchnk) - call outfld('MMRPM2P5',mmr_pm25,pcols,lchnk) - call outfld('MMRPM1 ',mmr_pm1 ,pcols,lchnk) - call outfld('MMRPM2P5_SRF',mmr_pm25(:pcols,pver),pcols,lchnk) - !akc6- - ! total (all r) dry concentrations (ug/m3) and loadings (mg/m2) - call outfld('DLOAD_MI',dload_mi,pcols,lchnk) - call outfld('DLOAD_SS',dload_ss,pcols,lchnk) - call outfld('DLOAD_S4',dload_s4,pcols,lchnk) - call outfld('DLOAD_OC',dload_oc,pcols,lchnk) - call outfld('DLOAD_BC',dload_bc,pcols,lchnk) - - call outfld('LOADBCAC',dload_bc_ac,pcols,lchnk) - call outfld('LOADBC0 ',dload_bc_0,pcols,lchnk) - call outfld('LOADBC2 ',dload_bc_2,pcols,lchnk) - call outfld('LOADBC4 ',dload_bc_4,pcols,lchnk) - call outfld('LOADBC12',dload_bc_12,pcols,lchnk) - call outfld('LOADBC14',dload_bc_14,pcols,lchnk) - call outfld('LOADOCAC',dload_oc_ac,pcols,lchnk) - call outfld('LOADOC4 ',dload_oc_4,pcols,lchnk) - call outfld('LOADOC14',dload_oc_14,pcols,lchnk) - ! condensed water mmr (kg/kg) - call outfld('MMR_AH2O',mmr_aerh2o,pcols,lchnk) - ! condensed water loading (mg/m2) - call outfld('DAERH2O ',daerh2o ,pcols,lchnk) - ! number concentrations (1/cm3) - call outfld('NNAT_0 ',nnat_0 ,pcols,lchnk) - call outfld('NNAT_1 ',nnat_1 ,pcols,lchnk) - call outfld('NNAT_2 ',nnat_2 ,pcols,lchnk) - !=0 call outfld('NNAT_3 ',nnat_3 ,pcols,lchnk) - call outfld('NNAT_4 ',nnat_4 ,pcols,lchnk) - call outfld('NNAT_5 ',nnat_5 ,pcols,lchnk) - call outfld('NNAT_6 ',nnat_6 ,pcols,lchnk) - call outfld('NNAT_7 ',nnat_7 ,pcols,lchnk) - call outfld('NNAT_8 ',nnat_8 ,pcols,lchnk) - call outfld('NNAT_9 ',nnat_9 ,pcols,lchnk) - call outfld('NNAT_10 ',nnat_10,pcols,lchnk) - !=0 call outfld('NNAT_11 ',nnat_11,pcols,lchnk) - call outfld('NNAT_12 ',nnat_12,pcols,lchnk) - !=0 call outfld('NNAT_13 ',nnat_13,pcols,lchnk) - call outfld('NNAT_14 ',nnat_14,pcols,lchnk) - !akc6 call outfld('AIRMASSL',airmassl,pcols,lchnk) - call outfld('AIRMASSL',airmassl,pcols,lchnk) - call outfld('AIRMASS ',airmass,pcols,lchnk) !akc6 - - !c_er3d - ! effective dry radii (um) in each layer - ! call outfld('ERLT053D',erlt053d,pcols,lchnk) - ! call outfld('ERGT053D',ergt053d,pcols,lchnk) - ! call outfld('ER3D ',er3d ,pcols,lchnk) - !c_er3d - ! column integrated effective dry radii (um) - call outfld('DERLT05 ',derlt05,pcols,lchnk) - call outfld('DERGT05 ',dergt05,pcols,lchnk) - call outfld('DER ',der ,pcols,lchnk) - ! - - ! Extra AeroCom diagnostics requiring table look-ups with RH = constant - -#ifdef AEROCOM_INSITU - irfmax=6 -#else - irfmax=1 -#endif ! AEROCOM_INSITU - - ! Note: using xrhnull etc as proxy for constant RH input values (see opttab.F90) - do irf=1,irfmax - do k=1,pver - do icol=1,ncol - xrhnull(icol,k)=xrhrf(irf) - irh1null(icol,k)=irhrf1(irf) - end do - enddo - call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrhnull, irh1null, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) - end do ! irf - - end if - ! ***********AEROCOM***********AEROCOM**************AEROCOM***************above end subroutine pmxsub diff --git a/src/physics/cam_oslo/radiation.F90 b/src/physics/cam_oslo/radiation.F90 index c7d4ae8504..3a1d517b86 100644 --- a/src/physics/cam_oslo/radiation.F90 +++ b/src/physics/cam_oslo/radiation.F90 @@ -1,732 +1,732 @@ module radiation -!--------------------------------------------------------------------------------- -! -! CAM interface to RRTMG radiation parameterization -! -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver, pverp, begchunk, endchunk -use physics_types, only: physics_state, physics_ptend -use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx -use camsrfexch, only: cam_out_t, cam_in_t -use physconst, only: cappa, cpair - -use time_manager, only: get_nstep, is_first_restart_step, & - get_curr_calday, get_step_size - -use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_info, & - rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & - liqcldoptics, icecldoptics - -use radconstants, only: nswbands, nlwbands, rrtmg_sw_cloudsim_band, rrtmg_lw_cloudsim_band, & - idx_sw_diag - -use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & - cospsimulator_intr_run, cosp_nradsteps - -use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs - -use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active -use cam_history_support, only: fillvalue - -use pio, only: file_desc_t, var_desc_t, & - pio_int, pio_noerr, & - pio_seterrorhandling, pio_bcast_error, & - pio_inq_varid, pio_def_var, & - pio_put_var, pio_get_var - -use cam_abortutils, only: endrun -use error_messages, only: handle_err -use perf_mod, only: t_startf, t_stopf -use cam_logfile, only: iulog -use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands -use pmxsub_mod, only: pmxsub - -implicit none -private - -public :: & - radiation_readnl, &! read namelist variables - radiation_register, &! registers radiation physics buffer fields - radiation_nextsw_cday, &! calendar day of next radiation calculation - radiation_do, &! query which radiation calcs are done this timestep - radiation_init, &! initialization - radiation_define_restart, &! define variables for restart - radiation_write_restart, &! write variables to restart - radiation_read_restart, &! read variables from restart - radiation_tend, &! compute heating rates and fluxes - rad_out_t ! type for diagnostic outputs - -integer,public, allocatable :: cosp_cnt(:) ! counter for cosp -integer,public :: cosp_cnt_init = 0 !initial value for cosp counter - -type rad_out_t - - real(r8) :: solin(pcols) ! Solar incident flux - - real(r8) :: qrsc(pcols,pver) - - real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux - real(r8) :: fsntoa(pcols) ! Net solar flux at TOA - real(r8) :: fsntoac(pcols) ! Clear sky net solar flux at TOA - real(r8) :: fsutoa(pcols) ! upwelling solar flux at TOA - - real(r8) :: fsnirt(pcols) ! Near-IR flux absorbed at toa - real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa - real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns - - real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb - real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb - real(r8) :: fsnr(pcols) ! fns interpolated to tropopause - - real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux - real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux - - real(r8) :: qrlc(pcols,pver) - - real(r8) :: flntc(pcols) ! Clear sky lw flux at model top - real(r8) :: flut(pcols) ! Upward flux at top of model - real(r8) :: flutc(pcols) ! Upward Clear Sky flux at top of model - real(r8) :: lwcf(pcols) ! longwave cloud forcing - - real(r8) :: fln200(pcols) ! net longwave flux interpolated to 200 mb - real(r8) :: fln200c(pcols) ! net clearsky longwave flux interpolated to 200 mb - real(r8) :: flnr(pcols) ! net longwave flux interpolated to tropopause - - real(r8) :: flnsc(pcols) ! Clear sky lw flux at srf (up-down) - real(r8) :: fldsc(pcols) ! Clear sky lw flux at srf (down) - - real(r8) :: tot_cld_vistau(pcols,pver) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: tot_icld_vistau(pcols,pver) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth (only during day, night = fillvalue) - real(r8) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth for output on history files - - real(r8) :: cld_tau_cloudsim(pcols,pver) - real(r8) :: aer_tau400(pcols,0:pver) - real(r8) :: aer_tau550(pcols,0:pver) - real(r8) :: aer_tau700(pcols,0:pver) - -end type rad_out_t - -! Namelist variables - -integer :: iradsw = -1 ! freq. of shortwave radiation calc in time steps (positive) - ! or hours (negative). -integer :: iradlw = -1 ! frequency of longwave rad. calc. in time steps (positive) - ! or hours (negative). - -integer :: irad_always = 0 ! Specifies length of time in timesteps (positive) - ! or hours (negative) SW/LW radiation will be - ! run continuously from the start of an - ! initial or restart run -logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations -logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. - -! Physics buffer indices -integer :: qrs_idx = 0 -integer :: qrl_idx = 0 -integer :: su_idx = 0 -integer :: sd_idx = 0 -integer :: lu_idx = 0 -integer :: ld_idx = 0 -integer :: fsds_idx = 0 -integer :: fsns_idx = 0 -integer :: fsnt_idx = 0 -integer :: flns_idx = 0 -integer :: flnt_idx = 0 -integer :: cldfsnow_idx = 0 -integer :: cld_idx = 0 -integer :: volc_idx = 0 - -character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) - -! averaging time interval for zenith angle -real(r8) :: dt_avg = 0._r8 - -! PIO descriptors (for restarts) -type(var_desc_t) :: cospcnt_desc + !--------------------------------------------------------------------------------- + ! + ! CAM interface to RRTMG radiation parameterization + ! + !--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp, begchunk, endchunk + use physics_types, only: physics_state, physics_ptend + use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx + use camsrfexch, only: cam_out_t, cam_in_t + use physconst, only: cappa, cpair + + use time_manager, only: get_nstep, is_first_restart_step, & + get_curr_calday, get_step_size + + use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_info, & + rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & + liqcldoptics, icecldoptics + + use radconstants, only: nswbands, nlwbands, rrtmg_sw_cloudsim_band, rrtmg_lw_cloudsim_band, & + idx_sw_diag + + use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & + cospsimulator_intr_run, cosp_nradsteps + + use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs + + use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active + use cam_history_support, only: fillvalue + + use pio, only: file_desc_t, var_desc_t, & + pio_int, pio_noerr, & + pio_seterrorhandling, pio_bcast_error, & + pio_inq_varid, pio_def_var, & + pio_put_var, pio_get_var + + use cam_abortutils, only: endrun + use error_messages, only: handle_err + use perf_mod, only: t_startf, t_stopf + use cam_logfile, only: iulog + use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands + use pmxsub_mod, only: pmxsub + + implicit none + private + + public :: & + radiation_readnl, &! read namelist variables + radiation_register, &! registers radiation physics buffer fields + radiation_nextsw_cday, &! calendar day of next radiation calculation + radiation_do, &! query which radiation calcs are done this timestep + radiation_init, &! initialization + radiation_define_restart, &! define variables for restart + radiation_write_restart, &! write variables to restart + radiation_read_restart, &! read variables from restart + radiation_tend, &! compute heating rates and fluxes + rad_out_t ! type for diagnostic outputs + + integer,public, allocatable :: cosp_cnt(:) ! counter for cosp + integer,public :: cosp_cnt_init = 0 !initial value for cosp counter + + type rad_out_t + + real(r8) :: solin(pcols) ! Solar incident flux + + real(r8) :: qrsc(pcols,pver) + + real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux + real(r8) :: fsntoa(pcols) ! Net solar flux at TOA + real(r8) :: fsntoac(pcols) ! Clear sky net solar flux at TOA + real(r8) :: fsutoa(pcols) ! upwelling solar flux at TOA + + real(r8) :: fsnirt(pcols) ! Near-IR flux absorbed at toa + real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa + real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns + + real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb + real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb + real(r8) :: fsnr(pcols) ! fns interpolated to tropopause + + real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux + real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux + + real(r8) :: qrlc(pcols,pver) + + real(r8) :: flntc(pcols) ! Clear sky lw flux at model top + real(r8) :: flut(pcols) ! Upward flux at top of model + real(r8) :: flutc(pcols) ! Upward Clear Sky flux at top of model + real(r8) :: lwcf(pcols) ! longwave cloud forcing + + real(r8) :: fln200(pcols) ! net longwave flux interpolated to 200 mb + real(r8) :: fln200c(pcols) ! net clearsky longwave flux interpolated to 200 mb + real(r8) :: flnr(pcols) ! net longwave flux interpolated to tropopause + + real(r8) :: flnsc(pcols) ! Clear sky lw flux at srf (up-down) + real(r8) :: fldsc(pcols) ! Clear sky lw flux at srf (down) + + real(r8) :: tot_cld_vistau(pcols,pver) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: tot_icld_vistau(pcols,pver) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth (only during day, night = fillvalue) + real(r8) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth for output on history files + + real(r8) :: cld_tau_cloudsim(pcols,pver) + real(r8) :: aer_tau400(pcols,0:pver) + real(r8) :: aer_tau550(pcols,0:pver) + real(r8) :: aer_tau700(pcols,0:pver) + + end type rad_out_t + + ! Namelist variables + + integer :: iradsw = -1 ! freq. of shortwave radiation calc in time steps (positive) + ! or hours (negative). + integer :: iradlw = -1 ! frequency of longwave rad. calc. in time steps (positive) + ! or hours (negative). + + integer :: irad_always = 0 ! Specifies length of time in timesteps (positive) + ! or hours (negative) SW/LW radiation will be + ! run continuously from the start of an + ! initial or restart run + logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations + logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. + + ! Physics buffer indices + integer :: qrs_idx = 0 + integer :: qrl_idx = 0 + integer :: su_idx = 0 + integer :: sd_idx = 0 + integer :: lu_idx = 0 + integer :: ld_idx = 0 + integer :: fsds_idx = 0 + integer :: fsns_idx = 0 + integer :: fsnt_idx = 0 + integer :: flns_idx = 0 + integer :: flnt_idx = 0 + integer :: cldfsnow_idx = 0 + integer :: cld_idx = 0 + integer :: volc_idx = 0 + + character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) + + ! averaging time interval for zenith angle + real(r8) :: dt_avg = 0._r8 + + ! PIO descriptors (for restarts) + type(var_desc_t) :: cospcnt_desc #ifdef AEROCOM -logical :: do_aerocom = .true. + logical :: do_aerocom = .true. #else -logical :: do_aerocom = .false. + logical :: do_aerocom = .false. #endif !=============================================================================== contains !=============================================================================== -subroutine radiation_readnl(nlfile) + subroutine radiation_readnl(nlfile) - ! Read radiation_nl namelist group. + ! Read radiation_nl namelist group. - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - ! Local variables - integer :: unitn, ierr - integer :: dtime ! timestep size - character(len=*), parameter :: sub = 'radiation_readnl' + ! Local variables + integer :: unitn, ierr + integer :: dtime ! timestep size + character(len=*), parameter :: sub = 'radiation_readnl' - namelist /radiation_nl/ iradsw, iradlw, irad_always, & - use_rad_dt_cosz, spectralflux - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'radiation_nl', status=ierr) - if (ierr == 0) then - read(unitn, radiation_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if + namelist /radiation_nl/ iradsw, iradlw, irad_always, & + use_rad_dt_cosz, spectralflux + !----------------------------------------------------------------------------- - ! Broadcast namelist variables - call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradsw") - call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradlw") - call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: irad_always") - call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_dt_cosz") - call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: spectralflux") + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'radiation_nl', status=ierr) + if (ierr == 0) then + read(unitn, radiation_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if - ! Convert iradsw, iradlw and irad_always from hours to timesteps if necessary - dtime = get_step_size() - if (iradsw < 0) iradsw = nint((-iradsw *3600._r8)/dtime) - if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) - if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) - - !----------------------------------------------------------------------- - ! Print runtime options to log. - !----------------------------------------------------------------------- - - if (masterproc) then - write(iulog,*) 'RRTMG radiation scheme parameters:' - write(iulog,10) iradsw, iradlw, irad_always, use_rad_dt_cosz, spectralflux - end if - -10 format(' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & - ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & - ' SW/LW calc done every timestep for first N steps. N=',i5/, & - ' Use average zenith angle: ',l5/, & - ' Output spectrally resolved fluxes: ',l5/) - -end subroutine radiation_readnl - -!================================================================================================ - -subroutine radiation_register - - ! Register radiation fields in the physics buffer - - use physics_buffer, only: pbuf_add_field, dtype_r8 - use radiation_data, only: rad_data_register - - call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate - call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate - - call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux - call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux - call pbuf_add_field('FSNT' , 'global',dtype_r8,(/pcols/), fsnt_idx) ! Top-of-model net shortwave flux - - call pbuf_add_field('FLNS' , 'global',dtype_r8,(/pcols/), flns_idx) ! Surface net longwave flux - call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux - - ! If the namelist has been configured for preserving the spectral fluxes, then create - ! physics buffer variables to store the results. - if (spectralflux) then - call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) - call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) - call pbuf_add_field('LU' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), lu_idx) ! longwave upward flux (per band) - call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) - end if - - call rad_data_register() - -end subroutine radiation_register - -!================================================================================================ - -function radiation_do(op, timestep) - - ! Return true if the specified operation is done this timestep. - - character(len=*), intent(in) :: op ! name of operation - integer, intent(in), optional:: timestep - logical :: radiation_do ! return value - - ! Local variables - integer :: nstep ! current timestep number - !----------------------------------------------------------------------- - - if (present(timestep)) then - nstep = timestep - else - nstep = get_nstep() - end if - - select case (op) - - case ('sw') ! do a shortwave heating calc this timestep? - radiation_do = nstep == 0 .or. iradsw == 1 & - .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - case ('lw') ! do a longwave heating calc this timestep? - radiation_do = nstep == 0 .or. iradlw == 1 & - .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - case default - call endrun('radiation_do: unknown operation:'//op) - - end select -end function radiation_do - -!================================================================================================ - -real(r8) function radiation_nextsw_cday() - - ! Return calendar day of next sw radiation calculation - - ! Local variables - integer :: nstep ! timestep counter - logical :: dosw ! true => do shosrtwave calc - integer :: offset ! offset for calendar day calculation - integer :: dTime ! integer timestep size - real(r8):: calday ! calendar day of - !----------------------------------------------------------------------- - - radiation_nextsw_cday = -1._r8 - dosw = .false. - nstep = get_nstep() - dtime = get_step_size() - offset = 0 - do while (.not. dosw) - nstep = nstep + 1 - offset = offset + dtime - if (radiation_do('sw', nstep)) then - radiation_nextsw_cday = get_curr_calday(offset=offset) - dosw = .true. - end if - end do - if(radiation_nextsw_cday == -1._r8) then - call endrun('error in radiation_nextsw_cday') - end if - -end function radiation_nextsw_cday - -!================================================================================================ - -subroutine radiation_init(pbuf2d) - - ! Initialize the radiation parameterization, add fields to the history buffer - - use physics_buffer, only: pbuf_get_index, pbuf_set_field - use phys_control, only: phys_getopts - use radsw, only: radsw_init - use radlw, only: radlw_init - use rad_solar_var, only: rad_solar_var_init - use radiation_data, only: rad_data_init - use cloud_rad_props, only: cloud_rad_props_init - use modal_aer_opt, only: modal_aer_opt_init - use rrtmg_state, only: rrtmg_state_init - use time_manager, only: is_first_step - - - ! arguments - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local variables - integer :: icall, nmodes - logical :: active_calls(0:N_DIAG) - integer :: nstep ! current timestep number - logical :: history_amwg ! output the variables used by the AMWG diag package - logical :: history_vdiag ! output the variables used by the AMWG variability diag package - logical :: history_budget ! output tendencies and state variables for CAM4 - ! temperature, water vapor, cloud ice and cloud - ! liquid budgets. - integer :: history_budget_histfile_num ! output history file number for budget fields - integer :: err - - integer :: dtime - !----------------------------------------------------------------------- - - call rad_solar_var_init() - call rrtmg_state_init() - call rad_data_init(pbuf2d) ! initialize output fields for offline driver - call radsw_init() - call radlw_init() - call cloud_rad_props_init() - - cld_idx = pbuf_get_index('CLD') - cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err) - - if (is_first_step()) then - call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) - end if - - - ! Set the radiation timestep for cosz calculations if requested using the adjusted iradsw value from radiation - if (use_rad_dt_cosz) then - dtime = get_step_size() - dt_avg = iradsw*dtime - end if - - call phys_getopts(history_amwg_out = history_amwg, & - history_vdiag_out = history_vdiag, & - history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num) - - ! Determine whether modal aerosols are affecting the climate, and if so - ! then initialize the modal aerosol optics module - call rad_cnst_get_info(0, nmodes=nmodes) - if (nmodes > 0) call modal_aer_opt_init() - - ! "irad_always" is number of time steps to execute radiation continuously from start of - ! initial OR restart run - nstep = get_nstep() - if (irad_always > 0) then - nstep = get_nstep() - irad_always = irad_always + nstep - end if - - if (docosp) call cospsimulator_intr_init - - allocate(cosp_cnt(begchunk:endchunk)) - if (is_first_restart_step()) then - cosp_cnt(begchunk:endchunk) = cosp_cnt_init - else - cosp_cnt(begchunk:endchunk) = 0 - end if - - call addfld('O3colAbove', horiz_only, 'A', 'DU', 'Column O3 above model top', sampling_seq='rad_lwsw') - - call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total gbx cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('TOT_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('LIQ_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Liquid in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('ICE_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Ice in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - - if (cldfsnow_idx > 0) then - call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Snow in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - endif - - ! get list of active radiation calls - call rad_cnst_get_call_list(active_calls) - - ! Add shortwave radiation fields to history master field list. - - do icall = 0, N_DIAG - - if (active_calls(icall)) then - - call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') - - call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') - call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & - sampling_seq='rad_lwsw') - call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & - sampling_seq='rad_lwsw') - call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') - - call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - - call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & - sampling_seq='rad_lwsw') - - call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') - call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') - call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') - call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') - - if (history_amwg) then - call add_default('SOLIN'//diag(icall), 1, ' ') - call add_default('QRS'//diag(icall), 1, ' ') - call add_default('FSNT'//diag(icall), 1, ' ') - call add_default('FSNTC'//diag(icall), 1, ' ') - call add_default('FSNTOA'//diag(icall), 1, ' ') - call add_default('FSNTOAC'//diag(icall), 1, ' ') - call add_default('SWCF'//diag(icall), 1, ' ') - call add_default('FSNS'//diag(icall), 1, ' ') - call add_default('FSNSC'//diag(icall), 1, ' ') - call add_default('FSUTOA'//diag(icall), 1, ' ') - call add_default('FSDSC'//diag(icall), 1, ' ') - call add_default('FSDS'//diag(icall), 1, ' ') - endif - - end if - end do - - call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') - call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') - - if (scm_crm_mode) then - call add_default('FUS ', 1, ' ') - call add_default('FUSC ', 1, ' ') - call add_default('FDS ', 1, ' ') - call add_default('FDSC ', 1, ' ') - endif - - ! Add longwave radiation fields to history master field list. - - do icall = 0, N_DIAG - - if (active_calls(icall)) then - - call addfld('QRL'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Longwave heating rate', sampling_seq='rad_lwsw') - call addfld('QRLC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky longwave heating rate', & - sampling_seq='rad_lwsw') - call addfld('FLNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLNTCLR'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky ONLY points net longwave flux at top of model',& - sampling_seq='rad_lwsw') - call addfld('FREQCLR'//diag(icall), horiz_only, 'A', 'Frac', 'Frequency of Occurrence of Clearsky', & - sampling_seq='rad_lwsw') - call addfld('FLUT'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLUTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky upwelling longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('LWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Longwave cloud forcing', sampling_seq='rad_lwsw') - - call addfld('FLN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FLN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FLNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at tropopause', & - sampling_seq='rad_lwsw') - - call addfld('FLNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky Downwelling longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FUL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave upward flux') - call addfld('FDL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave downward flux') - call addfld('FULC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky upward flux') - call addfld('FDLC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky downward flux') - - if (history_amwg) then - call add_default('QRL'//diag(icall), 1, ' ') - call add_default('FLNT'//diag(icall), 1, ' ') - call add_default('FLNTC'//diag(icall), 1, ' ') - call add_default('FLNTCLR'//diag(icall), 1, ' ') - call add_default('FREQCLR'//diag(icall), 1, ' ') - call add_default('FLUT'//diag(icall), 1, ' ') - call add_default('FLUTC'//diag(icall), 1, ' ') - call add_default('LWCF'//diag(icall), 1, ' ') - call add_default('FLNS'//diag(icall), 1, ' ') - call add_default('FLNSC'//diag(icall), 1, ' ') - call add_default('FLDS'//diag(icall), 1, ' ') - endif - - end if - end do - - call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') - - if (scm_crm_mode) then - call add_default ('FUL ', 1, ' ') - call add_default ('FULC ', 1, ' ') - call add_default ('FDL ', 1, ' ') - call add_default ('FDLC ', 1, ' ') - endif - - ! Heating rate needed for d(theta)/dt computation - call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') - - if ( history_budget .and. history_budget_histfile_num > 1 ) then - call add_default ('QRL ', history_budget_histfile_num, ' ') - call add_default ('QRS ', history_budget_histfile_num, ' ') - end if - - if (history_vdiag) then - call add_default('FLUT', 2, ' ') - call add_default('FLUT', 3, ' ') - end if - -end subroutine radiation_init + ! Broadcast namelist variables + call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradsw") + call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradlw") + call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: irad_always") + call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_dt_cosz") + call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: spectralflux") + + ! Convert iradsw, iradlw and irad_always from hours to timesteps if necessary + dtime = get_step_size() + if (iradsw < 0) iradsw = nint((-iradsw *3600._r8)/dtime) + if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) + if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) + + !----------------------------------------------------------------------- + ! Print runtime options to log. + !----------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) 'RRTMG radiation scheme parameters:' + write(iulog,10) iradsw, iradlw, irad_always, use_rad_dt_cosz, spectralflux + end if -!=============================================================================== +10 format(' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & + ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & + ' SW/LW calc done every timestep for first N steps. N=',i5/, & + ' Use average zenith angle: ',l5/, & + ' Output spectrally resolved fluxes: ',l5/) -subroutine radiation_define_restart(file) + end subroutine radiation_readnl - ! define variables to be written to restart file + !================================================================================================ - ! arguments - type(file_desc_t), intent(inout) :: file + subroutine radiation_register - ! local variables - integer :: ierr - !---------------------------------------------------------------------------- + ! Register radiation fields in the physics buffer - call pio_seterrorhandling(File, PIO_BCAST_ERROR) + use physics_buffer, only: pbuf_add_field, dtype_r8 + use radiation_data, only: rad_data_register - if (docosp) then - ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) - end if + call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate + call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate -end subroutine radiation_define_restart - -!=============================================================================== + call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux + call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux + call pbuf_add_field('FSNT' , 'global',dtype_r8,(/pcols/), fsnt_idx) ! Top-of-model net shortwave flux -subroutine radiation_write_restart(file) + call pbuf_add_field('FLNS' , 'global',dtype_r8,(/pcols/), flns_idx) ! Surface net longwave flux + call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux - ! write variables to restart file + ! If the namelist has been configured for preserving the spectral fluxes, then create + ! physics buffer variables to store the results. + if (spectralflux) then + call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) + call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) + call pbuf_add_field('LU' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), lu_idx) ! longwave upward flux (per band) + call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) + end if - ! arguments - type(file_desc_t), intent(inout) :: file + call rad_data_register() - ! local variables - integer :: ierr - !---------------------------------------------------------------------------- + end subroutine radiation_register - if (docosp) then - ierr = pio_put_var(File, cospcnt_desc, (/cosp_cnt(begchunk)/)) - end if + !================================================================================================ -end subroutine radiation_write_restart - -!=============================================================================== + function radiation_do(op, timestep) + + ! Return true if the specified operation is done this timestep. + + character(len=*), intent(in) :: op ! name of operation + integer, intent(in), optional:: timestep + logical :: radiation_do ! return value -subroutine radiation_read_restart(file) + ! Local variables + integer :: nstep ! current timestep number + !----------------------------------------------------------------------- - ! read variables from restart file + if (present(timestep)) then + nstep = timestep + else + nstep = get_nstep() + end if - ! arguments - type(file_desc_t), intent(inout) :: file + select case (op) + + case ('sw') ! do a shortwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradsw == 1 & + .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + case ('lw') ! do a longwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradlw == 1 & + .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + case default + call endrun('radiation_do: unknown operation:'//op) + + end select + end function radiation_do + + !================================================================================================ + + real(r8) function radiation_nextsw_cday() + + ! Return calendar day of next sw radiation calculation + + ! Local variables + integer :: nstep ! timestep counter + logical :: dosw ! true => do shosrtwave calc + integer :: offset ! offset for calendar day calculation + integer :: dTime ! integer timestep size + real(r8):: calday ! calendar day of + !----------------------------------------------------------------------- + + radiation_nextsw_cday = -1._r8 + dosw = .false. + nstep = get_nstep() + dtime = get_step_size() + offset = 0 + do while (.not. dosw) + nstep = nstep + 1 + offset = offset + dtime + if (radiation_do('sw', nstep)) then + radiation_nextsw_cday = get_curr_calday(offset=offset) + dosw = .true. + end if + end do + if(radiation_nextsw_cday == -1._r8) then + call endrun('error in radiation_nextsw_cday') + end if - ! local variables + end function radiation_nextsw_cday - integer :: err_handling - integer :: ierr + !================================================================================================ - type(var_desc_t) :: vardesc - !---------------------------------------------------------------------------- + subroutine radiation_init(pbuf2d) - if (docosp) then - call pio_seterrorhandling(File, PIO_BCAST_ERROR, err_handling) - ierr = pio_inq_varid(File, 'cosp_cnt_init', vardesc) - call pio_seterrorhandling(File, err_handling) - if (ierr /= PIO_NOERR) then - cosp_cnt_init = 0 - else - ierr = pio_get_var(File, vardesc, cosp_cnt_init) - end if - end if + ! Initialize the radiation parameterization, add fields to the history buffer -end subroutine radiation_read_restart + use physics_buffer, only: pbuf_get_index, pbuf_set_field + use phys_control, only: phys_getopts + use radsw, only: radsw_init + use radlw, only: radlw_init + use rad_solar_var, only: rad_solar_var_init + use radiation_data, only: rad_data_init + use cloud_rad_props, only: cloud_rad_props_init + use modal_aer_opt, only: modal_aer_opt_init + use rrtmg_state, only: rrtmg_state_init + use time_manager, only: is_first_step -!=============================================================================== - -subroutine radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) - - !----------------------------------------------------------------------- - ! - ! Driver for radiation computation. - ! - ! Revision history: - ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. - ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. - ! - ! - ! 2019-05-06 A. KirkevÃ¥g: Changes for testing the - ! "simple plumes" aerosols, based on NorESM1 code P. Räisänen. - !----------------------------------------------------------------------- - - use phys_grid, only: get_rlat_all_p, get_rlon_all_p - use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr - use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz - - use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw - - use cloud_rad_props, only: get_ice_optics_sw, get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & - ice_cloud_get_rad_props_lw, cloud_rad_props_get_lw, & - snow_cloud_get_rad_props_lw, get_snow_optics_sw - use slingo, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw - use ebert_curry, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw - - use rad_solar_var, only: get_variability - use radsw, only: rad_rrtmg_sw - use radlw, only: rad_rrtmg_lw - use radheat, only: radheat_tend - - use radiation_data, only: rad_data_write - use rrtmg_state, only: rrtmg_state_create, rrtmg_state_update, rrtmg_state_destroy, rrtmg_state_t, & - num_rrtmg_levs - - use interpolate_data, only: vertinterp - use tropopause, only: tropopause_find, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE - - use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps - - use commondefinitions - use aerosoldef - use opttab, only: nbands, eps - use constituents, only: pcnst - use oslo_control, only: oslo_getopts - use physics_buffer, only: pbuf_get_index + + ! arguments + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + ! local variables + integer :: icall, nmodes + logical :: active_calls(0:N_DIAG) + integer :: nstep ! current timestep number + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_vdiag ! output the variables used by the AMWG variability diag package + logical :: history_budget ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + integer :: history_budget_histfile_num ! output history file number for budget fields + integer :: err + + integer :: dtime + !----------------------------------------------------------------------- + + call rad_solar_var_init() + call rrtmg_state_init() + call rad_data_init(pbuf2d) ! initialize output fields for offline driver + call radsw_init() + call radlw_init() + call cloud_rad_props_init() + + cld_idx = pbuf_get_index('CLD') + cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err) + + if (is_first_step()) then + call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) + end if + + + ! Set the radiation timestep for cosz calculations if requested using the adjusted iradsw value from radiation + if (use_rad_dt_cosz) then + dtime = get_step_size() + dt_avg = iradsw*dtime + end if + + call phys_getopts(history_amwg_out = history_amwg, & + history_vdiag_out = history_vdiag, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num) + + ! Determine whether modal aerosols are affecting the climate, and if so + ! then initialize the modal aerosol optics module + call rad_cnst_get_info(0, nmodes=nmodes) + if (nmodes > 0) call modal_aer_opt_init() + + ! "irad_always" is number of time steps to execute radiation continuously from start of + ! initial OR restart run + nstep = get_nstep() + if (irad_always > 0) then + nstep = get_nstep() + irad_always = irad_always + nstep + end if + + if (docosp) call cospsimulator_intr_init + + allocate(cosp_cnt(begchunk:endchunk)) + if (is_first_restart_step()) then + cosp_cnt(begchunk:endchunk) = cosp_cnt_init + else + cosp_cnt(begchunk:endchunk) = 0 + end if + + call addfld('O3colAbove', horiz_only, 'A', 'DU', 'Column O3 above model top', sampling_seq='rad_lwsw') + + call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total gbx cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('TOT_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('LIQ_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Liquid in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('ICE_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Ice in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + + if (cldfsnow_idx > 0) then + call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Snow in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + endif + + ! get list of active radiation calls + call rad_cnst_get_call_list(active_calls) + + ! Add shortwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + + call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') + + call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') + call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & + sampling_seq='rad_lwsw') + call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & + sampling_seq='rad_lwsw') + call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') + + call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + + call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & + sampling_seq='rad_lwsw') + + call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') + call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') + call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') + call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') + + if (history_amwg) then + call add_default('SOLIN'//diag(icall), 1, ' ') + call add_default('QRS'//diag(icall), 1, ' ') + call add_default('FSNT'//diag(icall), 1, ' ') + call add_default('FSNTC'//diag(icall), 1, ' ') + call add_default('FSNTOA'//diag(icall), 1, ' ') + call add_default('FSNTOAC'//diag(icall), 1, ' ') + call add_default('SWCF'//diag(icall), 1, ' ') + call add_default('FSNS'//diag(icall), 1, ' ') + call add_default('FSNSC'//diag(icall), 1, ' ') + call add_default('FSUTOA'//diag(icall), 1, ' ') + call add_default('FSDSC'//diag(icall), 1, ' ') + call add_default('FSDS'//diag(icall), 1, ' ') + endif + + end if + end do + + call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') + call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') + + if (scm_crm_mode) then + call add_default('FUS ', 1, ' ') + call add_default('FUSC ', 1, ' ') + call add_default('FDS ', 1, ' ') + call add_default('FDSC ', 1, ' ') + endif + + ! Add longwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + + call addfld('QRL'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Longwave heating rate', sampling_seq='rad_lwsw') + call addfld('QRLC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky longwave heating rate', & + sampling_seq='rad_lwsw') + call addfld('FLNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLNTCLR'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky ONLY points net longwave flux at top of model',& + sampling_seq='rad_lwsw') + call addfld('FREQCLR'//diag(icall), horiz_only, 'A', 'Frac', 'Frequency of Occurrence of Clearsky', & + sampling_seq='rad_lwsw') + call addfld('FLUT'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLUTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky upwelling longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('LWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Longwave cloud forcing', sampling_seq='rad_lwsw') + + call addfld('FLN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FLN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FLNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at tropopause', & + sampling_seq='rad_lwsw') + + call addfld('FLNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky Downwelling longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FUL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave upward flux') + call addfld('FDL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave downward flux') + call addfld('FULC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky upward flux') + call addfld('FDLC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky downward flux') + + if (history_amwg) then + call add_default('QRL'//diag(icall), 1, ' ') + call add_default('FLNT'//diag(icall), 1, ' ') + call add_default('FLNTC'//diag(icall), 1, ' ') + call add_default('FLNTCLR'//diag(icall), 1, ' ') + call add_default('FREQCLR'//diag(icall), 1, ' ') + call add_default('FLUT'//diag(icall), 1, ' ') + call add_default('FLUTC'//diag(icall), 1, ' ') + call add_default('LWCF'//diag(icall), 1, ' ') + call add_default('FLNS'//diag(icall), 1, ' ') + call add_default('FLNSC'//diag(icall), 1, ' ') + call add_default('FLDS'//diag(icall), 1, ' ') + endif + + end if + end do + + call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') + + if (scm_crm_mode) then + call add_default ('FUL ', 1, ' ') + call add_default ('FULC ', 1, ' ') + call add_default ('FDL ', 1, ' ') + call add_default ('FDLC ', 1, ' ') + endif + + ! Heating rate needed for d(theta)/dt computation + call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') + + if ( history_budget .and. history_budget_histfile_num > 1 ) then + call add_default ('QRL ', history_budget_histfile_num, ' ') + call add_default ('QRS ', history_budget_histfile_num, ' ') + end if + + if (history_vdiag) then + call add_default('FLUT', 2, ' ') + call add_default('FLUT', 3, ' ') + end if + + end subroutine radiation_init + + !=============================================================================== + + subroutine radiation_define_restart(file) + + ! define variables to be written to restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- + + call pio_seterrorhandling(File, PIO_BCAST_ERROR) + + if (docosp) then + ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) + end if + + end subroutine radiation_define_restart + + !=============================================================================== + + subroutine radiation_write_restart(file) + + ! write variables to restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- + + if (docosp) then + ierr = pio_put_var(File, cospcnt_desc, (/cosp_cnt(begchunk)/)) + end if + + end subroutine radiation_write_restart + + !=============================================================================== + + subroutine radiation_read_restart(file) + + ! read variables from restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + + integer :: err_handling + integer :: ierr + + type(var_desc_t) :: vardesc + !---------------------------------------------------------------------------- + + if (docosp) then + call pio_seterrorhandling(File, PIO_BCAST_ERROR, err_handling) + ierr = pio_inq_varid(File, 'cosp_cnt_init', vardesc) + call pio_seterrorhandling(File, err_handling) + if (ierr /= PIO_NOERR) then + cosp_cnt_init = 0 + else + ierr = pio_get_var(File, vardesc, cosp_cnt_init) + end if + end if + + end subroutine radiation_read_restart + + !=============================================================================== + + subroutine radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) + + !----------------------------------------------------------------------- + ! + ! Driver for radiation computation. + ! + ! Revision history: + ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. + ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. + ! + ! + ! 2019-05-06 A. KirkevÃ¥g: Changes for testing the + ! "simple plumes" aerosols, based on NorESM1 code P. Räisänen. + !----------------------------------------------------------------------- + + use phys_grid, only: get_rlat_all_p, get_rlon_all_p + use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr + use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz + + use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw + + use cloud_rad_props, only: get_ice_optics_sw, get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & + ice_cloud_get_rad_props_lw, cloud_rad_props_get_lw, & + snow_cloud_get_rad_props_lw, get_snow_optics_sw + use slingo, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw + use ebert_curry, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw + + use rad_solar_var, only: get_variability + use radsw, only: rad_rrtmg_sw + use radlw, only: rad_rrtmg_lw + use radheat, only: radheat_tend + + use radiation_data, only: rad_data_write + use rrtmg_state, only: rrtmg_state_create, rrtmg_state_update, rrtmg_state_destroy, rrtmg_state_t, & + num_rrtmg_levs + + use interpolate_data, only: vertinterp + use tropopause, only: tropopause_find, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE + + use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps + + use commondefinitions + use aerosoldef + use opttab, only: nbands, eps + use constituents, only: pcnst + use oslo_control, only: oslo_getopts + use physics_buffer, only: pbuf_get_index real(r8) flnt_tmp(pcols) ! Net outgoing lw flux at model top for AIE calculations real(r8) volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode @@ -734,126 +734,126 @@ subroutine radiation_tend( & character(len=3) :: c3 logical idrf - ! Arguments - type(physics_state), intent(in), target :: state - type(physics_ptend), intent(out) :: ptend - - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(inout) :: cam_out - type(cam_in_t), intent(in) :: cam_in - real(r8), intent(out) :: net_flx(pcols) - - type(rad_out_t), target, optional, intent(out) :: rd_out - - - ! Local variables - type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object - ! if the argument is not present - logical :: write_output - - integer :: i, k - integer :: lchnk, ncol - logical :: dosw, dolw - - real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr - real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) - real(r8) :: calday ! current calendar day - real(r8) :: delta ! Solar declination angle in radians - real(r8) :: eccf ! Earth orbit eccentricity factor - real(r8) :: clat(pcols) ! current latitudes(radians) - real(r8) :: clon(pcols) ! current longitudes(radians) - real(r8) :: coszrs(pcols) ! Cosine solar zenith angle - - ! Gathered indices of day and night columns - ! chunk_column_index = IdxDay(daylight_column_index) - integer :: Nday ! Number of daylight columns - integer :: Nnite ! Number of night columns - integer :: IdxDay(pcols) ! Indices of daylight columns - integer :: IdxNite(pcols) ! Indices of night columns - - integer :: itim_old - - real(r8), pointer :: cld(:,:) ! cloud fraction - real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" - real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate - real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate - real(r8), pointer :: fsds(:) ! Surface solar down flux - real(r8), pointer :: fsns(:) ! Surface solar absorbed flux - real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top - real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux - real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top - - real(r8), pointer, dimension(:,:,:) :: su => NULL() ! shortwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: sd => NULL() ! shortwave spectral flux down - real(r8), pointer, dimension(:,:,:) :: lu => NULL() ! longwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: ld => NULL() ! longwave spectral flux down - - ! tropopause diagnostic - integer :: troplev(pcols) - real(r8) :: p_trop(pcols) - - type(rrtmg_state_t), pointer :: r_state ! contains the atm concentrations in layers needed for RRTMG - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: ice_tau (nswbands,pcols,pver) ! ice extinction optical depth - real(r8) :: ice_tau_w (nswbands,pcols,pver) ! ice single scattering albedo * tau - real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice assymetry parameter * tau * w - real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! ice forward scattered fraction * tau * w - real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth - real(r8) :: liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau - real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w - real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w - real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: cld_tau (nswbands,pcols,pver) ! cloud extinction optical depth - real(r8) :: cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau - real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau - real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau - real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth - real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau - real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow assymetry parameter * tau * w - real(r8) :: snow_tau_w_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w - real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) - - ! combined cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) - real(r8) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth - real(r8) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau - real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau - real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau - real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) - - real(r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band - - integer :: icall ! index through climate/diagnostic radiation calls - logical :: active_calls(0:N_DIAG) - - ! Aerosol radiative properties - real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth - real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau - real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau - real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) - - -! Local variables used for calculating aerosol optics and direct and indirect forcings. -! aodvis and absvis are AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) -! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values + ! Arguments + type(physics_state), intent(in), target :: state + type(physics_ptend), intent(out) :: ptend + + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in + real(r8), intent(out) :: net_flx(pcols) + + type(rad_out_t), target, optional, intent(out) :: rd_out + + + ! Local variables + type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object + ! if the argument is not present + logical :: write_output + + integer :: i, k + integer :: lchnk, ncol + logical :: dosw, dolw + + real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr + real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) + real(r8) :: calday ! current calendar day + real(r8) :: delta ! Solar declination angle in radians + real(r8) :: eccf ! Earth orbit eccentricity factor + real(r8) :: clat(pcols) ! current latitudes(radians) + real(r8) :: clon(pcols) ! current longitudes(radians) + real(r8) :: coszrs(pcols) ! Cosine solar zenith angle + + ! Gathered indices of day and night columns + ! chunk_column_index = IdxDay(daylight_column_index) + integer :: Nday ! Number of daylight columns + integer :: Nnite ! Number of night columns + integer :: IdxDay(pcols) ! Indices of daylight columns + integer :: IdxNite(pcols) ! Indices of night columns + + integer :: itim_old + + real(r8), pointer :: cld(:,:) ! cloud fraction + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" + real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate + real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate + real(r8), pointer :: fsds(:) ! Surface solar down flux + real(r8), pointer :: fsns(:) ! Surface solar absorbed flux + real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top + real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux + real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top + + real(r8), pointer, dimension(:,:,:) :: su => NULL() ! shortwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: sd => NULL() ! shortwave spectral flux down + real(r8), pointer, dimension(:,:,:) :: lu => NULL() ! longwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: ld => NULL() ! longwave spectral flux down + + ! tropopause diagnostic + integer :: troplev(pcols) + real(r8) :: p_trop(pcols) + + type(rrtmg_state_t), pointer :: r_state ! contains the atm concentrations in layers needed for RRTMG + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: ice_tau (nswbands,pcols,pver) ! ice extinction optical depth + real(r8) :: ice_tau_w (nswbands,pcols,pver) ! ice single scattering albedo * tau + real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice assymetry parameter * tau * w + real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! ice forward scattered fraction * tau * w + real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth + real(r8) :: liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau + real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w + real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w + real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: cld_tau (nswbands,pcols,pver) ! cloud extinction optical depth + real(r8) :: cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau + real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau + real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau + real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth + real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau + real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow assymetry parameter * tau * w + real(r8) :: snow_tau_w_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w + real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) + + ! combined cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) + real(r8) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth + real(r8) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau + real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau + real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau + real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) + + real(r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band + + integer :: icall ! index through climate/diagnostic radiation calls + logical :: active_calls(0:N_DIAG) + + ! Aerosol radiative properties + real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth + real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau + real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau + real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + + + ! Local variables used for calculating aerosol optics and direct and indirect forcings. + ! aodvis and absvis are AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) + ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values real(r8) qdirind(pcols,pver,pcnst) ! Common tracers for indirect and direct calculations real(r8) aodvis(pcols) ! AOD vis real(r8) absvis(pcols) ! absorptive AOD vis real(r8) clearodvis(pcols), clearabsvis(pcols), cloudfree(pcols), cloudfreemax(pcols) - ! AEROCOM beg - real(r8) dod440(pcols),dod550(pcols),dod870(pcols),abs550(pcols),abs550alt(pcols) - real(r8) clearod440(pcols),clearod550(pcols),clearod870(pcols),clearabs550(pcols),clearabs550alt(pcols) - ! AEROCOM end + ! AEROCOM beg + real(r8) dod440(pcols),dod550(pcols),dod870(pcols),abs550(pcols),abs550alt(pcols) + real(r8) clearod440(pcols),clearod550(pcols),clearod870(pcols),clearabs550(pcols),clearabs550alt(pcols) + ! AEROCOM end real(r8) ftem_1d(pcols) ! work-array to avoid NAN and pcols/ncol confusion real(r8) Nnatk(pcols,pver,0:nmodes) ! Modal aerosol number concentration real(r8) batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW @@ -873,333 +873,335 @@ subroutine radiation_tend( & real(r8) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 real(r8) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 - real(r8) :: fns(pcols,pverp) ! net shortwave flux - real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux - real(r8) :: fnl(pcols,pverp) ! net longwave flux - real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux - - ! for COSP - real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity - real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau - real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth - - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables - - real(r8) :: freqclr(pcols) ! Frequency of occurrence of clear sky columns - real(r8) :: flntclr(pcols) ! Clearsky only columns (zero if cloudy) - - character(*), parameter :: name = 'radiation_tend' - - logical, parameter :: cosz_rad_call=.true. !+tht - !-------------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - - per_lw_abs(:,:,:)=0._r8 - per_tau(:,:,:)=0._r8 - per_tau_w(:,:,:)=0._r8 - per_tau_w_g(:,:,:)=0._r8 - per_tau_w_f(:,:,:)=0._r8 - - if (present(rd_out)) then - rd => rd_out - write_output = .false. - else - allocate(rd) - write_output=.true. - end if - - dosw = radiation_do('sw') ! do shortwave heating calc this timestep? - dolw = radiation_do('lw') ! do longwave heating calc this timestep? - - ! Cosine solar zenith angle for current time step - calday = get_curr_calday() - call get_rlat_all_p(lchnk, ncol, clat) - call get_rlon_all_p(lchnk, ncol, clon) - - call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & - delta, eccf) - do i = 1, ncol - coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, cosz_rad_call) !+tht - end do - - ! Gather night/day column indices. - Nday = 0 - Nnite = 0 - do i = 1, ncol - if ( coszrs(i) > 0.0_r8 ) then - Nday = Nday + 1 - IdxDay(Nday) = i - else - Nnite = Nnite + 1 - IdxNite(Nnite) = i - end if - end do - - ! Associate pointers to physics buffer fields - itim_old = pbuf_old_tim_idx() - if (cldfsnow_idx > 0) then - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - endif - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, qrl_idx, qrl) - - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, fsds_idx, fsds) - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, flns_idx, flns) - call pbuf_get_field(pbuf, flnt_idx, flnt) - - if (spectralflux) then - call pbuf_get_field(pbuf, su_idx, su) - call pbuf_get_field(pbuf, sd_idx, sd) - call pbuf_get_field(pbuf, lu_idx, lu) - call pbuf_get_field(pbuf, ld_idx, ld) - end if - - ! For CRM, make cloud equal to input observations: - if (scm_crm_mode .and. have_cld) then - do k = 1, pver - cld(:ncol,k)= cldobs(k) - end do - end if + real(r8) :: fns(pcols,pverp) ! net shortwave flux + real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux + real(r8) :: fnl(pcols,pverp) ! net longwave flux + real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux + + ! for COSP + real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity + real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau + real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth + + real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables + + real(r8) :: freqclr(pcols) ! Frequency of occurrence of clear sky columns + real(r8) :: flntclr(pcols) ! Clearsky only columns (zero if cloudy) + + character(*), parameter :: name = 'radiation_tend' + + logical, parameter :: cosz_rad_call=.true. !+tht + !-------------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + per_lw_abs(:,:,:)=0._r8 + per_tau(:,:,:)=0._r8 + per_tau_w(:,:,:)=0._r8 + per_tau_w_g(:,:,:)=0._r8 + per_tau_w_f(:,:,:)=0._r8 + + if (present(rd_out)) then + rd => rd_out + write_output = .false. + else + allocate(rd) + write_output=.true. + end if + + dosw = radiation_do('sw') ! do shortwave heating calc this timestep? + dolw = radiation_do('lw') ! do longwave heating calc this timestep? + + ! Cosine solar zenith angle for current time step + calday = get_curr_calday() + call get_rlat_all_p(lchnk, ncol, clat) + call get_rlon_all_p(lchnk, ncol, clon) + + call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & + delta, eccf) + do i = 1, ncol + coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, cosz_rad_call) !+tht + end do + + ! Gather night/day column indices. + Nday = 0 + Nnite = 0 + do i = 1, ncol + if ( coszrs(i) > 0.0_r8 ) then + Nday = Nday + 1 + IdxDay(Nday) = i + else + Nnite = Nnite + 1 + IdxNite(Nnite) = i + end if + end do + + ! Associate pointers to physics buffer fields + itim_old = pbuf_old_tim_idx() + if (cldfsnow_idx > 0) then + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + endif + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, qrl_idx, qrl) + + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsds_idx, fsds) + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, flns_idx, flns) + call pbuf_get_field(pbuf, flnt_idx, flnt) + + if (spectralflux) then + call pbuf_get_field(pbuf, su_idx, su) + call pbuf_get_field(pbuf, sd_idx, sd) + call pbuf_get_field(pbuf, lu_idx, lu) + call pbuf_get_field(pbuf, ld_idx, ld) + end if + + ! For CRM, make cloud equal to input observations: + if (scm_crm_mode .and. have_cld) then + do k = 1, pver + cld(:ncol,k)= cldobs(k) + end do + end if qdirind(:ncol,:,:) = state%q(:ncol,:,:) if (has_prescribed_volcaero) then - call oslo_getopts(volc_fraction_coarse_out = volc_fraction_coarse) - call pbuf_get_field(pbuf, volc_idx, rvolcmmr, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - qdirind(:ncol,:,l_so4_pr) = qdirind(:ncol,:,l_so4_pr) + (1.0_r8 - volc_fraction_coarse)*rvolcmmr(:ncol,:) - qdirind(:ncol,:,l_ss_a3) = qdirind(:ncol,:,l_ss_a3) + volc_fraction_coarse*rvolcmmr(:ncol,:) + call oslo_getopts(volc_fraction_coarse_out = volc_fraction_coarse) + call pbuf_get_field(pbuf, volc_idx, rvolcmmr, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + qdirind(:ncol,:,l_so4_pr) = qdirind(:ncol,:,l_so4_pr) + (1.0_r8 - volc_fraction_coarse)*rvolcmmr(:ncol,:) + qdirind(:ncol,:,l_ss_a3) = qdirind(:ncol,:,l_ss_a3) + volc_fraction_coarse*rvolcmmr(:ncol,:) end if - ! Find tropopause height if needed for diagnostic output - if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then - call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) - endif - - if (dosw .or. dolw) then - - ! construct an RRTMG state object - r_state => rrtmg_state_create( state, cam_in ) - - call t_startf('cldoptics') - - if (cldfsnow_idx > 0) then - do k = 1, pver - do i = 1, ncol - cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) - end do - end do - else - cldfprime(:ncol,:) = cld(:ncol,:) - end if - - - if (dosw) then - - - if (oldcldoptics) then - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) - case ('mitchell') - call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) - case default - call endrun('iccldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) - case ('gammadist') - - call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) - - case default - call endrun('liqcldoptics must be either slingo or gammadist') - end select - end if - - cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) - cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) - cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) - cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) - - if (cldfsnow_idx > 0) then - ! add in snow - call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) - do i = 1, ncol - do k = 1, pver - - if (cldfprime(i,k) > 0._r8) then - - c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & - + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & - + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & - + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & - + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) - else - c_cld_tau(:,i,k) = 0._r8 - c_cld_tau_w(:,i,k) = 0._r8 - c_cld_tau_w_g(:,i,k) = 0._r8 - c_cld_tau_w_f(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) - c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) - c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) - c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) - end if - - ! Output cloud optical depth fields for the visible band - rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) - rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) - rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) - - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) - endif - - ! multiply by total cloud fraction to get gridbox value - rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) - - ! add fillvalue for night columns - do i = 1, Nnite - rd%tot_cld_vistau(IdxNite(i),:) = fillvalue - rd%tot_icld_vistau(IdxNite(i),:) = fillvalue - rd%liq_icld_vistau(IdxNite(i),:) = fillvalue - rd%ice_icld_vistau(IdxNite(i),:) = fillvalue - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(IdxNite(i),:) = fillvalue - end if - end do - - if (write_output) call radiation_output_cld(lchnk, ncol, rd) - - end if ! if (dosw) - - if (dolw) then - - if (oldcldoptics) then - call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) - case ('mitchell') - call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) - case default - call endrun('iccldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) - case ('gammadist') - call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) - case default - call endrun('liqcldoptics must be either slingo or gammadist') - end select - - cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) - - end if - - if (cldfsnow_idx > 0) then - - ! add in snow - call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) - - do i = 1, ncol - do k = 1, pver - if (cldfprime(i,k) > 0._r8) then - c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & - + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) - else - c_cld_lw_abs(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) - end if - - end if ! if (dolw) - - call t_stopf('cldoptics') - - ! Solar radiation computation - - if (dosw) then - -!TEST -! qdirind(:ncol,:,l_soa_a1) = 0.0_r8 -! qdirind(:ncol,:,l_soa_na) = 0.0_r8 -! qdirind(:ncol,:,l_so4_a1) = 0.0_r8 -! qdirind(:ncol,:,l_so4_na) = 0.0_r8 -!TEST -!cak+ Calculate CAM5-Oslo/NorESM2 aerosol optical parameters -! (move to aer_rad_props.F90? No, then it cannot be called for night-time calculations...) -! -! Volcanic optics for solar (SW) bands - do band=1, solar_bands - volc_ext_sun(1:ncol,1:pver,band)=0.0_r8 - volc_omega_sun(1:ncol,1:pver,band)=0.999_r8 - volc_g_sun(1:ncol,1:pver,band)=0.5_r8 - enddo - if (has_prescribed_volcaero_cmip6) then - do band=1, solar_bands - write(c3,'(i3)') band - volc_idx = pbuf_get_index('ext_sun'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_ext_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - volc_idx = pbuf_get_index('omega_sun'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_omega_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - volc_idx = pbuf_get_index('g_sun'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_g_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - enddo - endif -! Volcanic optics for terrestrial (LW) bands (g is not used here) - do band=1, terrestrial_bands - volc_ext_earth(1:ncol,1:pver,band)=0.0_r8 - volc_omega_earth(1:ncol,1:pver,band)=0.999_r8 - enddo - if (has_prescribed_volcaero_cmip6) then - do band=1, terrestrial_bands - write(c3,'(i3)') band - volc_idx = pbuf_get_index('ext_earth'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_ext_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - - volc_idx = pbuf_get_index('omega_earth'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_omega_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - enddo + ! Find tropopause height if needed for diagnostic output + if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then + call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) endif - call pmxsub(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & - coszrs, state, state%t, cld, qdirind, Nnatk, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & - per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, & - volc_ext_earth, volc_omega_earth, & - aodvis, absvis, dod440, dod550, dod870, abs550, abs550alt) + if (dosw .or. dolw) then + + ! construct an RRTMG state object + r_state => rrtmg_state_create( state, cam_in ) + + call t_startf('cldoptics') + + if (cldfsnow_idx > 0) then + do k = 1, pver + do i = 1, ncol + cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) + end do + end do + else + cldfprime(:ncol,:) = cld(:ncol,:) + end if + + + if (dosw) then + + + if (oldcldoptics) then + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) + case ('mitchell') + call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) + case default + call endrun('iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) + case ('gammadist') + + call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) + + case default + call endrun('liqcldoptics must be either slingo or gammadist') + end select + end if + + cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) + cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) + cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) + cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) + + if (cldfsnow_idx > 0) then + ! add in snow + call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) + do i = 1, ncol + do k = 1, pver + + if (cldfprime(i,k) > 0._r8) then + + c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & + + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & + + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & + + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & + + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) + else + c_cld_tau(:,i,k) = 0._r8 + c_cld_tau_w(:,i,k) = 0._r8 + c_cld_tau_w_g(:,i,k) = 0._r8 + c_cld_tau_w_f(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) + c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) + c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) + c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) + end if + + ! Output cloud optical depth fields for the visible band + rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) + rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) + rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) + + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) + endif + + ! multiply by total cloud fraction to get gridbox value + rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) + + ! add fillvalue for night columns + do i = 1, Nnite + rd%tot_cld_vistau(IdxNite(i),:) = fillvalue + rd%tot_icld_vistau(IdxNite(i),:) = fillvalue + rd%liq_icld_vistau(IdxNite(i),:) = fillvalue + rd%ice_icld_vistau(IdxNite(i),:) = fillvalue + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(IdxNite(i),:) = fillvalue + end if + end do + + if (write_output) call radiation_output_cld(lchnk, ncol, rd) + + end if ! if (dosw) + + if (dolw) then + + if (oldcldoptics) then + call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) + case ('mitchell') + call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) + case default + call endrun('iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) + case ('gammadist') + call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) + case default + call endrun('liqcldoptics must be either slingo or gammadist') + end select + + cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) + + end if + + if (cldfsnow_idx > 0) then + + ! add in snow + call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) + + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0._r8) then + c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & + + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) + else + c_cld_lw_abs(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) + end if + + end if ! if (dolw) + + call t_stopf('cldoptics') + + ! Solar radiation computation + + if (dosw) then + + !TEST + ! qdirind(:ncol,:,l_soa_a1) = 0.0_r8 + ! qdirind(:ncol,:,l_soa_na) = 0.0_r8 + ! qdirind(:ncol,:,l_so4_a1) = 0.0_r8 + ! qdirind(:ncol,:,l_so4_na) = 0.0_r8 + !TEST + !cak+ Calculate CAM5-Oslo/NorESM2 aerosol optical parameters + ! (move to aer_rad_props.F90? No, then it cannot be called for night-time calculations...) + ! + ! Volcanic optics for solar (SW) bands + do band=1, solar_bands + volc_ext_sun(1:ncol,1:pver,band)=0.0_r8 + volc_omega_sun(1:ncol,1:pver,band)=0.999_r8 + volc_g_sun(1:ncol,1:pver,band)=0.5_r8 + enddo + if (has_prescribed_volcaero_cmip6) then + do band=1, solar_bands + write(c3,'(i3)') band + volc_idx = pbuf_get_index('ext_sun'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_ext_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + volc_idx = pbuf_get_index('omega_sun'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_omega_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + volc_idx = pbuf_get_index('g_sun'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_g_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + enddo + endif + ! Volcanic optics for terrestrial (LW) bands (g is not used here) + do band=1, terrestrial_bands + volc_ext_earth(1:ncol,1:pver,band)=0.0_r8 + volc_omega_earth(1:ncol,1:pver,band)=0.999_r8 + enddo + if (has_prescribed_volcaero_cmip6) then + do band=1, terrestrial_bands + write(c3,'(i3)') band + volc_idx = pbuf_get_index('ext_earth'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_ext_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + + volc_idx = pbuf_get_index('omega_earth'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_omega_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + enddo + endif + + ! No aerocom variables passed for now + ! dod440, dod550, dod870, abs550, abs550alt + call pmxsub(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & + coszrs, state, state%t, cld, qdirind, Nnatk, & + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & + per_lw_abs, & + volc_ext_sun, volc_omega_sun, volc_g_sun, & + volc_ext_earth, volc_omega_earth, & + aodvis, absvis) call get_variability(sfac) @@ -1209,113 +1211,108 @@ subroutine radiation_tend( & ! The climate (icall==0) calculation must occur last. do icall = N_DIAG, 0, -1 - if (active_calls(icall)) then - - ! update the concentrations in the RRTMG state object - call rrtmg_state_update(state, pbuf, icall, r_state) - - !call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & - ! aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) -! A first call with Oslo aerosols set to zero for radiative forcing diagnostics -! follwoing the Ghan (2013) method: - - ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore - ! (just nudged), but with an extra call with 0 aerosol extiction. -! -!akc6+ - idrf = .true. -!akc6- - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, & - per_tau*0.0_r8, per_tau_w, per_tau_w_g, per_tau_w_f, & - eccf, coszrs, rd%solin, sfac, cam_in%asdir, & - cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & - fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & - rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & - rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & - IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & - E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & - E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) - - - ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair - ! - ! Dump shortwave radiation information to history tape buffer (diagnostics) - ! -!ak Note that DRF fields are now from the per_tau=0 call (clean), no longer with per_tau from pmxsub - call outfld('QRS_DRF ',ftem ,pcols,lchnk) - ftem(:ncol,:pver) = rd%qrsc(:ncol,:pver)/cpair - call outfld('QRSC_DRF',ftem ,pcols,lchnk) - call outfld('FSNT_DRF',fsnt(:) ,pcols,lchnk) - call outfld('FSNS_DRF',fsns(:) ,pcols,lchnk) - call outfld('FSNTCDRF',rd%fsntc(:) ,pcols,lchnk) - call outfld('FSNSCDRF',rd%fsnsc(:) ,pcols,lchnk) - ! AEROCOM beg - call outfld('FSUTADRF',rd%fsutoa(:),pcols,lchnk) - call outfld('FSDS_DRF',fsds(:) ,pcols,lchnk) - ftem_1d(1:ncol) = fsds(1:ncol)-fsns(1:ncol) - call outfld('FSUS_DRF',ftem_1d,pcols,lchnk) - call outfld('FSDSCDRF',rd%fsdsc(:) ,pcols,lchnk) - ! AEROCOM end - idrf = .false. - - rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) - rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) - rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) - rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) - -! Then the usual call with Oslo aerosols for radiative forcing diagnostics - - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & - eccf, coszrs, rd%solin, sfac, cam_in%asdir, & - cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & - fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & - rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & - rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & - IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & - E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & - E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) - - -!ak+ Has been moved from above to after the last rad_rrtmg_sw call... - ! Output net fluxes at 200 mb - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) - if (hist_fld_active('FSNR')) then - do i = 1,ncol - call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) - end do - end if - if (write_output) call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) -!ak- - end if - end do - - end if - - !Calculate cloud-free fraction assuming random overlap - !(kind of duplicated from cloud_cover_diags::cldsav) - cloudfree(1:ncol) = 1.0_r8 - cloudfreemax(1:ncol) = 1.0_r8 - - !Find cloud-free fraction (note this duplicated code and may not be consistent with cldtot calculated elsewhere) - do k = 1, pver - do i=1,ncol - cloudfree(i) = cloudfree(i) * cloudfreemax(i) - cloudfreemax(i) = min(cloudfreemax(i),1.0_r8-cld(i,k)) - end do - end do - - !Calculate AOD (visible) for cloud free + if (active_calls(icall)) then + + ! update the concentrations in the RRTMG state object + call rrtmg_state_update(state, pbuf, icall, r_state) + + !call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & + ! aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) + ! A first call with Oslo aerosols set to zero for radiative forcing diagnostics + ! follwoing the Ghan (2013) method: + + ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore + ! (just nudged), but with an extra call with 0 aerosol extiction. + ! + idrf = .true. + call rad_rrtmg_sw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + cldfprime, & + per_tau*0.0_r8, per_tau_w, per_tau_w_g, per_tau_w_f, & + eccf, coszrs, rd%solin, sfac, cam_in%asdir, & + cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & + fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & + rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & + rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & + IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & + E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & + E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) + + + ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair + ! + ! Dump shortwave radiation information to history tape buffer (diagnostics) + ! + ! Note that DRF fields are now from the per_tau=0 call (clean), no longer with per_tau from pmxsub + call outfld('QRS_DRF ',ftem ,pcols,lchnk) + ftem(:ncol,:pver) = rd%qrsc(:ncol,:pver)/cpair + call outfld('QRSC_DRF',ftem ,pcols,lchnk) + call outfld('FSNT_DRF',fsnt(:) ,pcols,lchnk) + call outfld('FSNS_DRF',fsns(:) ,pcols,lchnk) + call outfld('FSNTCDRF',rd%fsntc(:) ,pcols,lchnk) + call outfld('FSNSCDRF',rd%fsnsc(:) ,pcols,lchnk) + if (do_aerocom) then + call outfld('FSUTADRF',rd%fsutoa(:),pcols,lchnk) + call outfld('FSDS_DRF',fsds(:) ,pcols,lchnk) + ftem_1d(1:ncol) = fsds(1:ncol)-fsns(1:ncol) + call outfld('FSUS_DRF',ftem_1d,pcols,lchnk) + call outfld('FSDSCDRF',rd%fsdsc(:) ,pcols,lchnk) + end if + idrf = .false. + + rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) + rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) + rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) + rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) + + ! Then the usual call with Oslo aerosols for radiative forcing diagnostics + + call rad_rrtmg_sw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + cldfprime, & + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & + eccf, coszrs, rd%solin, sfac, cam_in%asdir, & + cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & + fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & + rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & + rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & + IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & + E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & + E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) + + ! Output net fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) + if (hist_fld_active('FSNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) + end do + end if + if (write_output) call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) + end if + end do + + end if + + !Calculate cloud-free fraction assuming random overlap + !(kind of duplicated from cloud_cover_diags::cldsav) + cloudfree(1:ncol) = 1.0_r8 + cloudfreemax(1:ncol) = 1.0_r8 + + !Find cloud-free fraction (note this duplicated code and may not be consistent with cldtot calculated elsewhere) + do k = 1, pver + do i=1,ncol + cloudfree(i) = cloudfree(i) * cloudfreemax(i) + cloudfreemax(i) = min(cloudfreemax(i),1.0_r8-cld(i,k)) + end do + end do + + !Calculate AOD (visible) for cloud free do i = 1, ncol - clearodvis(i)=cloudfree(i)*aodvis(i) - clearabsvis(i)=cloudfree(i)*absvis(i) + clearodvis(i)=cloudfree(i)*aodvis(i) + clearabsvis(i)=cloudfree(i)*absvis(i) end do ! clear-sky AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) ! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values @@ -1339,327 +1336,327 @@ subroutine radiation_tend( & ! Output aerosol mmr call rad_cnst_out(0, state, pbuf) - - ! Longwave radiation computation - - if (dolw) then - - call rad_cnst_get_call_list(active_calls) - - ! The climate (icall==0) calculation must occur last. - do icall = N_DIAG, 0, -1 - - if (active_calls(icall)) then - - ! update the conctrations in the RRTMG state object - call rrtmg_state_update( state, pbuf, icall, r_state) - - call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) - - ! for calculation of direct and direct radiative forcing - - call rad_rrtmg_lw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - per_lw_abs*0.0_r8, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & - flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & - rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & - lu, ld) - - call outfld('FLNT_DRF',flnt(:) ,pcols,lchnk) - call outfld('FLNTCDRF',rd%flntc(:) ,pcols,lchnk) - - call rad_rrtmg_lw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - per_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & - flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & - rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & - lu, ld) - - ! FLNT_ORG is just for temporary testing vs. FLNT - ftem_1d(1:ncol) = cam_out%flwds(1:ncol) - flns(1:ncol) - call outfld('FLUS ',ftem_1d ,pcols,lchnk) - - ! Output fluxes at 200 mb - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) - if (hist_fld_active('FLNR')) then - do i = 1,ncol - call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fnl(i,:), rd%flnr(i)) - end do - end if - - flntclr(:) = 0._r8 - freqclr(:) = 0._r8 - do i = 1, ncol - if (maxval(cldfprime(i,:)) <= 0.1_r8) then - freqclr(i) = 1._r8 - flntclr(i) = rd%flntc(i) - end if - end do - - if (write_output) call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) - - end if - end do - - end if - - ! deconstruct the RRTMG state object - call rrtmg_state_destroy(r_state) - - if (docosp) then - - ! initialize and calculate emis - emis(:,:) = 0._r8 - emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(rrtmg_lw_cloudsim_band,:ncol,:)) - call outfld('EMIS', emis, pcols, lchnk) - - ! compute grid-box mean SW and LW snow optical depth for use by COSP - gb_snow_tau(:,:) = 0._r8 - gb_snow_lw(:,:) = 0._r8 - if (cldfsnow_idx > 0) then - do i = 1, ncol - do k = 1, pver - if (cldfsnow(i,k) > 0._r8) then - gb_snow_tau(i,k) = snow_tau(rrtmg_sw_cloudsim_band,i,k)*cldfsnow(i,k) - gb_snow_lw(i,k) = snow_lw_abs(rrtmg_lw_cloudsim_band,i,k)*cldfsnow(i,k) - end if - end do - end do - end if - - ! advance counter for this timestep (chunk dimension required for thread safety) - cosp_cnt(lchnk) = cosp_cnt(lchnk) + 1 - - ! if counter is the same as cosp_nradsteps, run cosp and reset counter - if (cosp_nradsteps .eq. cosp_cnt(lchnk)) then - - ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave - ! optical depths are passed. - call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & - cld_swtau_in=cld_tau(rrtmg_sw_cloudsim_band,:,:),& - snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) - cosp_cnt(lchnk) = 0 - end if - end if - - else ! if (dosw .or. dolw) then - - ! convert radiative heating rates from Q*dp to Q for energy conservation - do k =1 , pver - do i = 1, ncol - qrs(i,k) = qrs(i,k)/state%pdel(i,k) - qrl(i,k) = qrl(i,k)/state%pdel(i,k) - end do - end do - - end if ! if (dosw .or. dolw) then + + ! Longwave radiation computation + + if (dolw) then + + call rad_cnst_get_call_list(active_calls) + + ! The climate (icall==0) calculation must occur last. + do icall = N_DIAG, 0, -1 + + if (active_calls(icall)) then + + ! update the conctrations in the RRTMG state object + call rrtmg_state_update( state, pbuf, icall, r_state) + + call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) + + ! for calculation of direct and direct radiative forcing + + call rad_rrtmg_lw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + per_lw_abs*0.0_r8, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & + flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & + rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & + lu, ld) + + call outfld('FLNT_DRF',flnt(:) ,pcols,lchnk) + call outfld('FLNTCDRF',rd%flntc(:) ,pcols,lchnk) + + call rad_rrtmg_lw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + per_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & + flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & + rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & + lu, ld) + + ! FLNT_ORG is just for temporary testing vs. FLNT + ftem_1d(1:ncol) = cam_out%flwds(1:ncol) - flns(1:ncol) + call outfld('FLUS ',ftem_1d ,pcols,lchnk) + + ! Output fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) + if (hist_fld_active('FLNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fnl(i,:), rd%flnr(i)) + end do + end if + + flntclr(:) = 0._r8 + freqclr(:) = 0._r8 + do i = 1, ncol + if (maxval(cldfprime(i,:)) <= 0.1_r8) then + freqclr(i) = 1._r8 + flntclr(i) = rd%flntc(i) + end if + end do + + if (write_output) call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) + + end if + end do + + end if + + ! deconstruct the RRTMG state object + call rrtmg_state_destroy(r_state) + + if (docosp) then + + ! initialize and calculate emis + emis(:,:) = 0._r8 + emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(rrtmg_lw_cloudsim_band,:ncol,:)) + call outfld('EMIS', emis, pcols, lchnk) + + ! compute grid-box mean SW and LW snow optical depth for use by COSP + gb_snow_tau(:,:) = 0._r8 + gb_snow_lw(:,:) = 0._r8 + if (cldfsnow_idx > 0) then + do i = 1, ncol + do k = 1, pver + if (cldfsnow(i,k) > 0._r8) then + gb_snow_tau(i,k) = snow_tau(rrtmg_sw_cloudsim_band,i,k)*cldfsnow(i,k) + gb_snow_lw(i,k) = snow_lw_abs(rrtmg_lw_cloudsim_band,i,k)*cldfsnow(i,k) + end if + end do + end do + end if + + ! advance counter for this timestep (chunk dimension required for thread safety) + cosp_cnt(lchnk) = cosp_cnt(lchnk) + 1 + + ! if counter is the same as cosp_nradsteps, run cosp and reset counter + if (cosp_nradsteps .eq. cosp_cnt(lchnk)) then + + ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave + ! optical depths are passed. + call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & + cld_swtau_in=cld_tau(rrtmg_sw_cloudsim_band,:,:),& + snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) + cosp_cnt(lchnk) = 0 + end if + end if + + else ! if (dosw .or. dolw) then + + ! convert radiative heating rates from Q*dp to Q for energy conservation + do k =1 , pver + do i = 1, ncol + qrs(i,k) = qrs(i,k)/state%pdel(i,k) + qrl(i,k) = qrl(i,k)/state%pdel(i,k) + end do + end do + + end if ! if (dosw .or. dolw) then ! output rad inputs and resulting heating rates call rad_data_write( pbuf, state, cam_in, coszrs ) - ! Compute net radiative heating tendency - call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & - fsnt, flns, flnt, cam_in%asdir, net_flx) + ! Compute net radiative heating tendency + call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & + fsnt, flns, flnt, cam_in%asdir, net_flx) - if (write_output) then - ! Compute heating rate for dtheta/dt - do k = 1, pver - do i = 1, ncol - ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa - end do - end do - call outfld('HR', ftem, pcols, lchnk) - end if + if (write_output) then + ! Compute heating rate for dtheta/dt + do k = 1, pver + do i = 1, ncol + ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa + end do + end do + call outfld('HR', ftem, pcols, lchnk) + end if - ! convert radiative heating rates to Q*dp for energy conservation - do k = 1, pver - do i = 1, ncol - qrs(i,k) = qrs(i,k)*state%pdel(i,k) - qrl(i,k) = qrl(i,k)*state%pdel(i,k) - end do - end do + ! convert radiative heating rates to Q*dp for energy conservation + do k = 1, pver + do i = 1, ncol + qrs(i,k) = qrs(i,k)*state%pdel(i,k) + qrl(i,k) = qrl(i,k)*state%pdel(i,k) + end do + end do - cam_out%netsw(:ncol) = fsns(:ncol) + cam_out%netsw(:ncol) = fsns(:ncol) - if (.not. present(rd_out)) then - deallocate(rd) - end if + if (.not. present(rd_out)) then + deallocate(rd) + end if -end subroutine radiation_tend + end subroutine radiation_tend -!=============================================================================== + !=============================================================================== -subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) + subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) - ! Dump shortwave radiation information to history buffer. + ! Dump shortwave radiation information to history buffer. - integer , intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: icall - type(rad_out_t), intent(in) :: rd - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(in) :: cam_out + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out - ! local variables - real(r8), pointer :: qrs(:,:) - real(r8), pointer :: fsnt(:) - real(r8), pointer :: fsns(:) - real(r8), pointer :: fsds(:) + ! local variables + real(r8), pointer :: qrs(:,:) + real(r8), pointer :: fsnt(:) + real(r8), pointer :: fsns(:) + real(r8), pointer :: fsds(:) - real(r8) :: ftem(pcols) - !---------------------------------------------------------------------------- + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, fsds_idx, fsds) + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, fsds_idx, fsds) - call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) + call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) - call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) - call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) - call outfld('FSNT'//diag(icall), fsnt, pcols, lchnk) - call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) - call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) - call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) + call outfld('FSNT'//diag(icall), fsnt, pcols, lchnk) + call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) + call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) + call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) - ftem(:ncol) = rd%fsntoa(:ncol) - rd%fsntoac(:ncol) - call outfld('SWCF'//diag(icall), ftem, pcols, lchnk) + ftem(:ncol) = rd%fsntoa(:ncol) - rd%fsntoac(:ncol) + call outfld('SWCF'//diag(icall), ftem, pcols, lchnk) - call outfld('FSUTOA'//diag(icall), rd%fsutoa, pcols, lchnk) + call outfld('FSUTOA'//diag(icall), rd%fsutoa, pcols, lchnk) - call outfld('FSNIRTOA'//diag(icall), rd%fsnirt, pcols, lchnk) - call outfld('FSNRTOAC'//diag(icall), rd%fsnrtc, pcols, lchnk) - call outfld('FSNRTOAS'//diag(icall), rd%fsnirtsq, pcols, lchnk) + call outfld('FSNIRTOA'//diag(icall), rd%fsnirt, pcols, lchnk) + call outfld('FSNRTOAC'//diag(icall), rd%fsnrtc, pcols, lchnk) + call outfld('FSNRTOAS'//diag(icall), rd%fsnirtsq, pcols, lchnk) - call outfld('FSN200'//diag(icall), rd%fsn200, pcols, lchnk) - call outfld('FSN200C'//diag(icall), rd%fsn200c, pcols, lchnk) + call outfld('FSN200'//diag(icall), rd%fsn200, pcols, lchnk) + call outfld('FSN200C'//diag(icall), rd%fsn200c, pcols, lchnk) - call outfld('FSNR'//diag(icall), rd%fsnr, pcols, lchnk) + call outfld('FSNR'//diag(icall), rd%fsnr, pcols, lchnk) - call outfld('SOLS'//diag(icall), cam_out%sols, pcols, lchnk) - call outfld('SOLL'//diag(icall), cam_out%soll, pcols, lchnk) - call outfld('SOLSD'//diag(icall), cam_out%solsd, pcols, lchnk) - call outfld('SOLLD'//diag(icall), cam_out%solld, pcols, lchnk) + call outfld('SOLS'//diag(icall), cam_out%sols, pcols, lchnk) + call outfld('SOLL'//diag(icall), cam_out%soll, pcols, lchnk) + call outfld('SOLSD'//diag(icall), cam_out%solsd, pcols, lchnk) + call outfld('SOLLD'//diag(icall), cam_out%solld, pcols, lchnk) - call outfld('FSNS'//diag(icall), fsns, pcols, lchnk) - call outfld('FSNSC'//diag(icall), rd%fsnsc, pcols, lchnk) + call outfld('FSNS'//diag(icall), fsns, pcols, lchnk) + call outfld('FSNSC'//diag(icall), rd%fsnsc, pcols, lchnk) - call outfld('FSDS'//diag(icall), fsds, pcols, lchnk) - call outfld('FSDSC'//diag(icall), rd%fsdsc, pcols, lchnk) + call outfld('FSDS'//diag(icall), fsds, pcols, lchnk) + call outfld('FSDSC'//diag(icall), rd%fsdsc, pcols, lchnk) -end subroutine radiation_output_sw + end subroutine radiation_output_sw -!=============================================================================== + !=============================================================================== -subroutine radiation_output_cld(lchnk, ncol, rd) + subroutine radiation_output_cld(lchnk, ncol, rd) - ! Dump shortwave cloud optics information to history buffer. + ! Dump shortwave cloud optics information to history buffer. - integer , intent(in) :: lchnk - integer, intent(in) :: ncol - type(rad_out_t), intent(in) :: rd - !---------------------------------------------------------------------------- + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + type(rad_out_t), intent(in) :: rd + !---------------------------------------------------------------------------- - call outfld('TOT_CLD_VISTAU', rd%tot_cld_vistau, pcols, lchnk) - call outfld('TOT_ICLD_VISTAU', rd%tot_icld_vistau, pcols, lchnk) - call outfld('LIQ_ICLD_VISTAU', rd%liq_icld_vistau, pcols, lchnk) - call outfld('ICE_ICLD_VISTAU', rd%ice_icld_vistau, pcols, lchnk) - if (cldfsnow_idx > 0) then - call outfld('SNOW_ICLD_VISTAU', rd%snow_icld_vistau, pcols, lchnk) - endif + call outfld('TOT_CLD_VISTAU', rd%tot_cld_vistau, pcols, lchnk) + call outfld('TOT_ICLD_VISTAU', rd%tot_icld_vistau, pcols, lchnk) + call outfld('LIQ_ICLD_VISTAU', rd%liq_icld_vistau, pcols, lchnk) + call outfld('ICE_ICLD_VISTAU', rd%ice_icld_vistau, pcols, lchnk) + if (cldfsnow_idx > 0) then + call outfld('SNOW_ICLD_VISTAU', rd%snow_icld_vistau, pcols, lchnk) + endif -end subroutine radiation_output_cld + end subroutine radiation_output_cld -!=============================================================================== + !=============================================================================== -subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) + subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) - ! Dump longwave radiation information to history buffer + ! Dump longwave radiation information to history buffer - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: icall ! icall=0 for climate diagnostics - type(rad_out_t), intent(in) :: rd - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(in) :: cam_out - real(r8), intent(in) :: freqclr(pcols) - real(r8), intent(in) :: flntclr(pcols) + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall ! icall=0 for climate diagnostics + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out + real(r8), intent(in) :: freqclr(pcols) + real(r8), intent(in) :: flntclr(pcols) - ! local variables - real(r8), pointer :: qrl(:,:) - real(r8), pointer :: flnt(:) - real(r8), pointer :: flns(:) + ! local variables + real(r8), pointer :: qrl(:,:) + real(r8), pointer :: flnt(:) + real(r8), pointer :: flns(:) - real(r8) :: ftem(pcols) - !---------------------------------------------------------------------------- + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- - call pbuf_get_field(pbuf, qrl_idx, qrl) - call pbuf_get_field(pbuf, flnt_idx, flnt) - call pbuf_get_field(pbuf, flns_idx, flns) + call pbuf_get_field(pbuf, qrl_idx, qrl) + call pbuf_get_field(pbuf, flnt_idx, flnt) + call pbuf_get_field(pbuf, flns_idx, flns) - call outfld('QRL'//diag(icall), qrl(:ncol,:)/cpair, ncol, lchnk) - call outfld('QRLC'//diag(icall), rd%qrlc(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRL'//diag(icall), qrl(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRLC'//diag(icall), rd%qrlc(:ncol,:)/cpair, ncol, lchnk) - call outfld('FLNT'//diag(icall), flnt, pcols, lchnk) - call outfld('FLNTC'//diag(icall), rd%flntc, pcols, lchnk) + call outfld('FLNT'//diag(icall), flnt, pcols, lchnk) + call outfld('FLNTC'//diag(icall), rd%flntc, pcols, lchnk) - call outfld('FREQCLR'//diag(icall), freqclr, pcols, lchnk) - call outfld('FLNTCLR'//diag(icall), flntclr, pcols, lchnk) + call outfld('FREQCLR'//diag(icall), freqclr, pcols, lchnk) + call outfld('FLNTCLR'//diag(icall), flntclr, pcols, lchnk) - call outfld('FLUT'//diag(icall), rd%flut, pcols, lchnk) - call outfld('FLUTC'//diag(icall), rd%flutc, pcols, lchnk) - - ftem(:ncol) = rd%flutc(:ncol) - rd%flut(:ncol) - call outfld('LWCF'//diag(icall), ftem, pcols, lchnk) + call outfld('FLUT'//diag(icall), rd%flut, pcols, lchnk) + call outfld('FLUTC'//diag(icall), rd%flutc, pcols, lchnk) - call outfld('FLN200'//diag(icall), rd%fln200, pcols, lchnk) - call outfld('FLN200C'//diag(icall), rd%fln200c, pcols, lchnk) + ftem(:ncol) = rd%flutc(:ncol) - rd%flut(:ncol) + call outfld('LWCF'//diag(icall), ftem, pcols, lchnk) - call outfld('FLNR'//diag(icall), rd%flnr, pcols, lchnk) + call outfld('FLN200'//diag(icall), rd%fln200, pcols, lchnk) + call outfld('FLN200C'//diag(icall), rd%fln200c, pcols, lchnk) - call outfld('FLNS'//diag(icall), flns, pcols, lchnk) - call outfld('FLNSC'//diag(icall), rd%flnsc, pcols, lchnk) + call outfld('FLNR'//diag(icall), rd%flnr, pcols, lchnk) - call outfld('FLDS'//diag(icall), cam_out%flwds, pcols, lchnk) - call outfld('FLDSC'//diag(icall), rd%fldsc, pcols, lchnk) + call outfld('FLNS'//diag(icall), flns, pcols, lchnk) + call outfld('FLNSC'//diag(icall), rd%flnsc, pcols, lchnk) -end subroutine radiation_output_lw + call outfld('FLDS'//diag(icall), cam_out%flwds, pcols, lchnk) + call outfld('FLDSC'//diag(icall), rd%fldsc, pcols, lchnk) -!=============================================================================== + end subroutine radiation_output_lw + + !=============================================================================== -subroutine calc_col_mean(state, mmr_pointer, mean_value) + subroutine calc_col_mean(state, mmr_pointer, mean_value) - ! Compute the column mean mass mixing ratio. + ! Compute the column mean mass mixing ratio. - type(physics_state), intent(in) :: state - real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) - real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr + type(physics_state), intent(in) :: state + real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) + real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr - integer :: i, k, ncol - real(r8) :: ptot(pcols) - !----------------------------------------------------------------------- + integer :: i, k, ncol + real(r8) :: ptot(pcols) + !----------------------------------------------------------------------- - ncol = state%ncol - mean_value = 0.0_r8 - ptot = 0.0_r8 + ncol = state%ncol + mean_value = 0.0_r8 + ptot = 0.0_r8 - do k=1,pver - do i=1,ncol - mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) - ptot(i) = ptot(i) + state%pdeldry(i,k) - end do - end do - do i=1,ncol - mean_value(i) = mean_value(i) / ptot(i) - end do + do k=1,pver + do i=1,ncol + mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) + ptot(i) = ptot(i) + state%pdeldry(i,k) + end do + end do + do i=1,ncol + mean_value(i) = mean_value(i) / ptot(i) + end do -end subroutine calc_col_mean + end subroutine calc_col_mean -!=============================================================================== + !=============================================================================== end module radiation From 1d456b38a802e25a124ebbe09e3bc0be45a22d12 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 17 Aug 2023 14:13:38 +0200 Subject: [PATCH 14/71] more cleanup --- src/NorESM/cam_diagnostics.F90 | 2 - src/NorESM/physpkg.F90 | 136 +- src/chemistry/oslo_aero/aero_model.F90 | 6 +- .../{aerodry_mod.F90 => aerocom_dry_mod.F90} | 23 +- src/physics/cam_oslo/aerocom_mod.F90 | 1923 +++++++++++++++++ .../{aeroopt_mod.F90 => aerocom_opt_mod.F90} | 23 +- src/physics/cam_oslo/checkTableHeader.F90 | 25 - src/physics/cam_oslo/intfrh_mod.F90 | 140 -- src/physics/cam_oslo/opttab.F90 | 151 +- src/physics/cam_oslo/oslo_control.F90 | 346 ++- src/physics/cam_oslo/pmxsub.F90 | 20 +- src/physics/cam_oslo/radiation.F90 | 1 - 12 files changed, 2295 insertions(+), 501 deletions(-) rename src/physics/cam_oslo/{aerodry_mod.F90 => aerocom_dry_mod.F90} (98%) create mode 100644 src/physics/cam_oslo/aerocom_mod.F90 rename src/physics/cam_oslo/{aeroopt_mod.F90 => aerocom_opt_mod.F90} (99%) delete mode 100644 src/physics/cam_oslo/checkTableHeader.F90 delete mode 100644 src/physics/cam_oslo/intfrh_mod.F90 diff --git a/src/NorESM/cam_diagnostics.F90 b/src/NorESM/cam_diagnostics.F90 index 7259c19979..3a7bede3ff 100644 --- a/src/NorESM/cam_diagnostics.F90 +++ b/src/NorESM/cam_diagnostics.F90 @@ -23,8 +23,6 @@ module cam_diagnostics use scamMod, only: single_column, wfld use cam_abortutils, only: endrun -use opttab, only: RF - implicit none private diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index b535292ee9..af5fcda0ee 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -31,7 +31,9 @@ module physpkg use perf_mod use cam_logfile, only: iulog use camsrfexch, only: cam_export - use intfrh_mod, only: intfrh +#ifdef AEROCOM + use aerocom_intfrh_mod, only: intfrh +#endif use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg use modal_aero_wateruptake, only: modal_aero_wateruptake_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg @@ -1778,9 +1780,9 @@ subroutine tphysbc (ztodt, state, & integer :: i,k,m ! Longitude, level, constituent indices integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. -!AL + !AL integer :: ixcldni, ixcldnc ! constituent indices for cloud liquid and ice water. -!AL + !AL ! for macro/micro co-substepping integer :: macmic_it ! iteration variables real(r8) :: cld_macmic_ztodt ! modified timestep @@ -1798,10 +1800,10 @@ subroutine tphysbc (ztodt, state, & real(r8), pointer, dimension(:,:) :: cldliqini real(r8), pointer, dimension(:,:) :: cldiceini real(r8), pointer, dimension(:,:) :: dtcore -!AL + !AL real(r8), pointer, dimension(:,:) :: cldncini real(r8), pointer, dimension(:,:) :: cldniini -!AL + !AL real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. @@ -1892,7 +1894,7 @@ subroutine tphysbc (ztodt, state, & real(r8) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) real(r8) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt real(r8) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor - ! OSLO_AERO_END + ! OSLO_AERO_END !----------------------------------------------------------------------- call t_startf('bc_init') @@ -1916,10 +1918,10 @@ subroutine tphysbc (ztodt, state, & call pbuf_get_field(pbuf, qini_idx, qini) call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) -!AL + !AL call pbuf_get_field(pbuf, cldncini_idx, cldncini) call pbuf_get_field(pbuf, cldniini_idx, cldniini) -!AL + !AL ifld = pbuf_get_index('DTCORE') call pbuf_get_field(pbuf, ifld, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) @@ -1980,12 +1982,12 @@ subroutine tphysbc (ztodt, state, & qini (:ncol,:pver) = state%q(:ncol,:pver, 1) cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) -!AL + !AL call cnst_get_ind('NUMLIQ', ixcldnc) call cnst_get_ind('NUMICE', ixcldni) cldncini(:ncol,:pver) = state%q(:ncol,:pver,ixcldnc) cldniini(:ncol,:pver) = state%q(:ncol,:pver,ixcldni) -!AL + !AL call outfld('TEOUT', teout , pcols, lchnk ) call outfld('TEINP', state%te_ini, pcols, lchnk ) @@ -2040,8 +2042,8 @@ subroutine tphysbc (ztodt, state, & call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) if (use_subcol_microp) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) end if ! Check energy integrals, including "reserved liquid" @@ -2082,7 +2084,7 @@ subroutine tphysbc (ztodt, state, & ! from the stratiform interface has access to the same aerosols as the radiation ! code. call sslt_rebin_adv(pbuf, state) - + !=================================================== ! Calculate tendencies from CARMA bin microphysics. !=================================================== @@ -2183,8 +2185,8 @@ subroutine tphysbc (ztodt, state, & ! ===================================================== call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& - cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & - dlf, det_s, det_ice) + cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & + dlf, det_s, det_ice) ! Since we "added" the reserved liquid back in this routine, we need ! to account for it in the energy checker @@ -2204,10 +2206,10 @@ subroutine tphysbc (ztodt, state, & ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & - cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & - flx_cnd(:ncol)/cld_macmic_num_steps, & - det_ice(:ncol)/cld_macmic_num_steps, & - flx_heat(:ncol)/cld_macmic_num_steps) + cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & + flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) endif @@ -2319,53 +2321,53 @@ subroutine tphysbc (ztodt, state, & call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) call physics_update(state, ptend, ztodt, tend) - if (do_aerocom) then - ! Estimating hygroscopic growth by use of linear interpolation w.r.t. mass - ! fractions of each internally mixed component for each mode (kcomp). - ! - call intfrh(lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relhum, frh) - ! - do k=1,pver - do i=1,ncol - rnewdry1(i,k) = rnew3d(i,k,1) - rnewdry2(i,k) = rnew3d(i,k,2) - rnewdry4(i,k) = rnew3d(i,k,4) - rnewdry5(i,k) = rnew3d(i,k,5) - rnewdry6(i,k) = rnew3d(i,k,6) - rnewdry7(i,k) = rnew3d(i,k,7) - rnewdry8(i,k) = rnew3d(i,k,8) - rnewdry9(i,k) = rnew3d(i,k,9) - rnewdry10(i,k) = rnew3d(i,k,10) - rnewdry11(i,k) = rnew3d(i,k,11) - rnewdry13(i,k) = rnew3d(i,k,13) - rnewdry14(i,k) = rnew3d(i,k,14) - rnew1(i,k) = rnew3d(i,k,1)*frh(i,k,1) - rnew2(i,k) = rnew3d(i,k,2)*frh(i,k,2) - rnew4(i,k) = rnew3d(i,k,4)*frh(i,k,4) - rnew5(i,k) = rnew3d(i,k,5)*frh(i,k,5) - rnew6(i,k) = rnew3d(i,k,6)*frh(i,k,6) - rnew7(i,k) = rnew3d(i,k,7)*frh(i,k,7) - rnew8(i,k) = rnew3d(i,k,8)*frh(i,k,8) - rnew9(i,k) = rnew3d(i,k,9)*frh(i,k,9) - rnew10(i,k) = rnew3d(i,k,10)*frh(i,k,10) - rnew11(i,k) = rnew3d(i,k,11)*frh(i,k,11) - rnew13(i,k) = rnew3d(i,k,13)*frh(i,k,13) - rnew14(i,k) = rnew3d(i,k,14)*frh(i,k,14) - logsig1(i,k) = logsig3d(i,k,1) - logsig2(i,k) = logsig3d(i,k,2) - logsig4(i,k) = logsig3d(i,k,4) - logsig5(i,k) = logsig3d(i,k,5) - logsig6(i,k) = logsig3d(i,k,6) - logsig7(i,k) = logsig3d(i,k,7) - logsig8(i,k) = logsig3d(i,k,8) - logsig9(i,k) = logsig3d(i,k,9) - logsig10(i,k)= logsig3d(i,k,10) - logsig11(i,k)= logsig3d(i,k,11) - logsig13(i,k)= logsig3d(i,k,13) - logsig14(i,k)= logsig3d(i,k,14) - end do +#ifdef AEROCOM + ! Estimating hygroscopic growth by use of linear interpolation w.r.t. mass + ! fractions of each internally mixed component for each mode (kcomp). + ! + call intfrh(lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relhum, frh) + ! + do k=1,pver + do i=1,ncol + rnewdry1(i,k) = rnew3d(i,k,1) + rnewdry2(i,k) = rnew3d(i,k,2) + rnewdry4(i,k) = rnew3d(i,k,4) + rnewdry5(i,k) = rnew3d(i,k,5) + rnewdry6(i,k) = rnew3d(i,k,6) + rnewdry7(i,k) = rnew3d(i,k,7) + rnewdry8(i,k) = rnew3d(i,k,8) + rnewdry9(i,k) = rnew3d(i,k,9) + rnewdry10(i,k) = rnew3d(i,k,10) + rnewdry11(i,k) = rnew3d(i,k,11) + rnewdry13(i,k) = rnew3d(i,k,13) + rnewdry14(i,k) = rnew3d(i,k,14) + rnew1(i,k) = rnew3d(i,k,1)*frh(i,k,1) + rnew2(i,k) = rnew3d(i,k,2)*frh(i,k,2) + rnew4(i,k) = rnew3d(i,k,4)*frh(i,k,4) + rnew5(i,k) = rnew3d(i,k,5)*frh(i,k,5) + rnew6(i,k) = rnew3d(i,k,6)*frh(i,k,6) + rnew7(i,k) = rnew3d(i,k,7)*frh(i,k,7) + rnew8(i,k) = rnew3d(i,k,8)*frh(i,k,8) + rnew9(i,k) = rnew3d(i,k,9)*frh(i,k,9) + rnew10(i,k) = rnew3d(i,k,10)*frh(i,k,10) + rnew11(i,k) = rnew3d(i,k,11)*frh(i,k,11) + rnew13(i,k) = rnew3d(i,k,13)*frh(i,k,13) + rnew14(i,k) = rnew3d(i,k,14)*frh(i,k,14) + logsig1(i,k) = logsig3d(i,k,1) + logsig2(i,k) = logsig3d(i,k,2) + logsig4(i,k) = logsig3d(i,k,4) + logsig5(i,k) = logsig3d(i,k,5) + logsig6(i,k) = logsig3d(i,k,6) + logsig7(i,k) = logsig3d(i,k,7) + logsig8(i,k) = logsig3d(i,k,8) + logsig9(i,k) = logsig3d(i,k,9) + logsig10(i,k)= logsig3d(i,k,10) + logsig11(i,k)= logsig3d(i,k,11) + logsig13(i,k)= logsig3d(i,k,13) + logsig14(i,k)= logsig3d(i,k,14) end do - end if + end do +#endif ! AEROCOM if (carma_do_wetdep) then ! CARMA wet deposition @@ -2389,7 +2391,7 @@ subroutine tphysbc (ztodt, state, & call t_stopf('bc_aerosols') - endif + end if !=================================================== ! Moist physical parameteriztions complete: @@ -2419,7 +2421,7 @@ subroutine tphysbc (ztodt, state, & call radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx) + state, ptend, pbuf, cam_out, cam_in, net_flx) ! Set net flux used by spectral dycores do i=1,ncol diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index aa22b36f69..a1ebc14e02 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -12,8 +12,6 @@ module aero_model use perf_mod, only: t_startf, t_stopf use camsrfexch, only: cam_in_t, cam_out_t use aerodep_flx, only: aerodep_flx_prescribed - use aeroopt_mod, only: initaeropt - use aerodry_mod, only: initdryp use physics_types, only: physics_state, physics_ptend, physics_ptend_init use physics_buffer, only: physics_buffer_desc use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field @@ -28,6 +26,10 @@ module aero_model use koagsub, only: coagtend, clcoag use sox_cldaero_mod, only: sox_cldaero_init use intlog, only: initlogn +#ifdef AEROCOM + use aerocom_opt_mod, only: initaeropt + use aerocom_dry_mod, only: initdryp +#endif !use modal_aero_data,only: cnst_name_cw, lptr_so4_cw_amode !use modal_aero_data,only: ntot_amode, modename_amode, nspec_max diff --git a/src/physics/cam_oslo/aerodry_mod.F90 b/src/physics/cam_oslo/aerocom_dry_mod.F90 similarity index 98% rename from src/physics/cam_oslo/aerodry_mod.F90 rename to src/physics/cam_oslo/aerocom_dry_mod.F90 index 117e18c058..5ae901a737 100644 --- a/src/physics/cam_oslo/aerodry_mod.F90 +++ b/src/physics/cam_oslo/aerocom_dry_mod.F90 @@ -1,4 +1,6 @@ -module aerodry_mod +module aerocom_dry_mod + +#ifdef AEROCOM use shr_kind_mod , only: r8 => shr_kind_r8 use ppgrid , only: pcols, pver @@ -1115,4 +1117,21 @@ subroutine update(this, kcomp, k, icol, iv, opt) end subroutine update -end module aerodry_mod + subroutine checkTableHeader (ifil) + ! Read the header-text in a look-up table (in file with iu=ifil). + + integer, intent(in) :: ifil + character*80 :: headertext + character*12 :: text0, text1 + + text0='X-CHECK LUT' + text1='none ' + do while (text1(2:12) .ne. text0(2:12)) + read(ifil,'(A)') headertext + text1 = headertext(2:12) + enddo + end subroutine checkTableHeader + +#endif + +end module aerocom_dry_mod diff --git a/src/physics/cam_oslo/aerocom_mod.F90 b/src/physics/cam_oslo/aerocom_mod.F90 new file mode 100644 index 0000000000..37f2cfcf24 --- /dev/null +++ b/src/physics/cam_oslo/aerocom_mod.F90 @@ -0,0 +1,1923 @@ +module aerocom_mod + +#ifdef AEROCOM + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_history, only: outfld + use constituents, only: pcnst + use const + use aerosoldef + use commondefinitions + use aerocom_opt_mod, only: extinction_coeffs, extinction_coeffsn + use aerocom_dry_mod, only: aerodry_prop + + public :: aerocom + public :: opticsAtConstRh + public :: intfrh + +contains + + subroutine aerocom(daylight, Cam) + + ! Arguments + real(r8), intent(in) :: Cam(pcols,pver,nbmodes) + + ! Local variables + integer i, k, ib, icol, mplus10 + integer iloop + logical daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. + + real(r8) Ctotdry(pcols,pver), Cwater(pcols,pver), mmr_aerh2o(pcols,pver), & + dod550dry(pcols), abs550dry(pcols) + + real(r8) daerh2o(pcols), dload(pcols,0:nmodes), dload3d(pcols,pver,0:nmodes), & + dload_mi(pcols), dload_ss(pcols), & + dload_s4(pcols), dload_oc(pcols), dload_bc(pcols), & + dload_s4_a(pcols), dload_s4_1(pcols), dload_s4_5(pcols) + + real(r8) dload_bc_0(pcols), dload_bc_ac(pcols), dload_oc_ac(pcols), & + dload_bc_2(pcols), dload_bc_4(pcols), dload_bc_12(pcols), dload_bc_14(pcols), & + dload_oc_4(pcols), dload_oc_14(pcols) + + real(r8) cmin(pcols,pver), cseas(pcols,pver) + + real(r8) nnat_1(pcols,pver), nnat_2(pcols,pver), nnat_3(pcols,pver), & + nnat_4(pcols,pver), nnat_5(pcols,pver), nnat_6(pcols,pver), & + nnat_7(pcols,pver), nnat_8(pcols,pver), nnat_9(pcols,pver), & + nnat_10(pcols,pver), nnat_12(pcols,pver), & + nnat_14(pcols,pver), nnat_0(pcols,pver) + + real(r8) ck(pcols,pver,0:nmodes), cknorm(pcols,pver,0:nmodes), & + cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) + + real(r8) aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & + vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & + aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & + vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) + + real(r8) cintbg(pcols,pver,0:nbmodes), & + cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & + cintbc(pcols,pver,0:nbmodes), & + cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & + cintoc(pcols,pver,0:nbmodes), & + cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & + cintsc(pcols,pver,0:nbmodes), & + cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & + cintsa(pcols,pver,0:nbmodes), & + cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes) + + real(r8) c_mi(pcols,pver), c_mi05(pcols,pver), c_mi125(pcols,pver), & + c_ss(pcols,pver), c_ss05(pcols,pver), c_ss125(pcols,pver), & + c_bc(pcols,pver), c_bc05(pcols,pver), c_bc125(pcols,pver), & + c_oc(pcols,pver), c_oc05(pcols,pver), c_oc125(pcols,pver), & + c_sa(pcols,pver), c_sa05(pcols,pver), c_sa125(pcols,pver), & + c_sc(pcols,pver), c_sc05(pcols,pver), c_sc125(pcols,pver), & + c_s4(pcols,pver), c_s405(pcols,pver), c_s4125(pcols,pver), & + c_s4_a(pcols,pver), c_s4_1(pcols,pver), c_s4_5(pcols,pver) + + real(r8) c_bc_0(pcols,pver), c_bc_ac(pcols,pver), c_oc_ac(pcols,pver), & + c_bc_2(pcols,pver), c_bc_4(pcols,pver), c_bc_12(pcols,pver), c_bc_14(pcols,pver), & + c_oc_4(pcols,pver), c_oc_14(pcols,pver) + + real(r8) c_tots(pcols), c_tot125s(pcols), c_pm25s(pcols) ! = PM all sizes, PM>2.5um and PM<2.5um (PM2.5) + + real(r8) c_tot(pcols,pver), c_tot125(pcols,pver), c_pm25(pcols,pver), & + mmr_pm25(pcols,pver), c_tot05(pcols,pver), c_pm1(pcols,pver), mmr_pm1(pcols,pver) + + real(r8) aaeros_tot(pcols,pver), aaerol_tot(pcols,pver), vaeros_tot(pcols,pver), & + vaerol_tot(pcols,pver), aaercols(pcols), aaercoll(pcols), vaercols(pcols), & + vaercoll(pcols), derlt05(pcols), dergt05(pcols), der(pcols), & + erlt053d(pcols,pver), ergt053d(pcols,pver), er3d(pcols,pver) + + real(r8) bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & + bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & + beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & + bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & + backsc550(pcols,pver,0:nbmodes), backsc550x(pcols,pver,nbmp1:nmodes), & + backsc550tot(pcols,pver), ec550_aer(pcols,pver), abs550_aer(pcols,pver), & + bs550_aer(pcols,pver) + + ! Additional AeroCom Phase III output: + real(r8) asydry_aer(pcols,pver) ! dry asymtot in the visible band + ! + real(r8) ec550_so4(pcols,pver),ec550_bc(pcols,pver), ec550_pom(pcols,pver), & + ec550_ss(pcols,pver), ec550_du(pcols,pver) + + real(r8) bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & + bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & + beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & + bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & + backsc550n(pcols,pver,0:nbmodes) + + real(r8) bext440tot(pcols,pver), babs440tot(pcols,pver), & + bext500tot(pcols,pver), babs500tot(pcols,pver), & + bext550tot(pcols,pver), babs550tot(pcols,pver), & + bext670tot(pcols,pver), babs670tot(pcols,pver), & + bext870tot(pcols,pver), babs870tot(pcols,pver), & + bebg440tot(pcols,pver), & + bebg500tot(pcols,pver), & + bebg550tot(pcols,pver), babg550tot(pcols,pver), & + bebg670tot(pcols,pver), & + bebg870tot(pcols,pver), & + bebc440tot(pcols,pver), & + bebc500tot(pcols,pver), & + bebc550tot(pcols,pver), babc550tot(pcols,pver), & + bebc670tot(pcols,pver), & + bebc870tot(pcols,pver), & + beoc440tot(pcols,pver), & + beoc500tot(pcols,pver), & + beoc550tot(pcols,pver), baoc550tot(pcols,pver), & + beoc670tot(pcols,pver), & + beoc870tot(pcols,pver), & + besu440tot(pcols,pver), & + besu500tot(pcols,pver), & + besu550tot(pcols,pver), basu550tot(pcols,pver), & + besu670tot(pcols,pver), & + besu870tot(pcols,pver) + + real(r8) bebglt1t(pcols,pver), bebggt1t(pcols,pver), bebclt1t(pcols,pver), & + bebcgt1t(pcols,pver), beoclt1t(pcols,pver), beocgt1t(pcols,pver), & + bes4lt1t(pcols,pver), bes4gt1t(pcols,pver) + + real(r8) be440x(pcols,pver,nbmp1:nmodes), ba440x(pcols,pver,nbmp1:nmodes), & + be500x(pcols,pver,nbmp1:nmodes), ba500x(pcols,pver,nbmp1:nmodes), & + be550x(pcols,pver,nbmp1:nmodes), ba550x(pcols,pver,nbmp1:nmodes), & + be670x(pcols,pver,nbmp1:nmodes), ba670x(pcols,pver,nbmp1:nmodes), & + be870x(pcols,pver,nbmp1:nmodes), ba870x(pcols,pver,nbmp1:nmodes), & + belt1x(pcols,pver,nbmp1:nmodes), begt1x(pcols,pver,nbmp1:nmodes) + + real(r8) bebc440xt(pcols,pver),babc440xt(pcols,pver), & + bebc500xt(pcols,pver),babc500xt(pcols,pver), & + bebc550xt(pcols,pver),babc550xt(pcols,pver), & + bebc670xt(pcols,pver),babc670xt(pcols,pver), & + bebc870xt(pcols,pver),babc870xt(pcols,pver), & + beoc440xt(pcols,pver),baoc440xt(pcols,pver), & + beoc500xt(pcols,pver),baoc500xt(pcols,pver), & + beoc550xt(pcols,pver),baoc550xt(pcols,pver), & + beoc670xt(pcols,pver),baoc670xt(pcols,pver), & + beoc870xt(pcols,pver),baoc870xt(pcols,pver) + + real(r8) bbclt1xt(pcols,pver), & + bbcgt1xt(pcols,pver), boclt1xt(pcols,pver), bocgt1xt(pcols,pver) + + real(r8) bint440du(pcols,pver), bint500du(pcols,pver), bint550du(pcols,pver), & + bint670du(pcols,pver), bint870du(pcols,pver), & + bint440ss(pcols,pver), bint500ss(pcols,pver), bint550ss(pcols,pver), & + bint670ss(pcols,pver), bint870ss(pcols,pver), & + baint550du(pcols,pver), baint550ss(pcols,pver) + + real(r8) bedustlt1(pcols,pver), bedustgt1(pcols,pver), & + besslt1(pcols,pver), bessgt1(pcols,pver) + + real(r8) dod4403d(pcols,pver), abs4403d(pcols,pver), & + dod4403d_ss(pcols,pver), & ! abs4403d_ss(pcols,pver), & + dod4403d_dust(pcols,pver), & ! abs4403d_dust(pcols,pver), & + dod4403d_so4(pcols,pver), & ! abs4403d_so4(pcols,pver), & + dod4403d_bc(pcols,pver), & ! abs4403d_bc(pcols,pver), & + dod4403d_pom(pcols,pver), & ! abs4403d_pom(pcols,pver), & + dod5003d(pcols,pver), abs5003d(pcols,pver), & + dod5003d_ss(pcols,pver), & ! abs5003d_ss(pcols,pver), & + dod5003d_dust(pcols,pver), & ! abs5003d_dust(pcols,pver), & + dod5003d_so4(pcols,pver), & ! abs5003d_so4(pcols,pver), & + dod5003d_bc(pcols,pver), & ! abs5003d_bc(pcols,pver), & + dod5003d_pom(pcols,pver), & ! abs5003d_pom(pcols,pver), & + dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver), & + dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver), & + dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver), & + dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver), & + dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver), & + dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver), & + dod6703d(pcols,pver), abs6703d(pcols,pver), & + dod6703d_ss(pcols,pver), & ! abs6703d_ss(pcols,pver), & + dod6703d_dust(pcols,pver), & ! abs6703d_dust(pcols,pver), & + dod6703d_so4(pcols,pver), & ! abs6703d_so4(pcols,pver), & + dod6703d_bc(pcols,pver), & ! abs6703d_bc(pcols,pver), & + dod6703d_pom(pcols,pver), & ! abs6703d_pom(pcols,pver), & + dod8703d(pcols,pver), abs8703d(pcols,pver), & + dod8703d_ss(pcols,pver), & ! abs8703d_ss(pcols,pver), & + dod8703d_dust(pcols,pver), & ! abs8703d_dust(pcols,pver), & + dod8703d_so4(pcols,pver), & ! abs8703d_so4(pcols,pver), & + dod8703d_bc(pcols,pver), & ! abs8703d_bc(pcols,pver), & + dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) + + real(r8) dod5503dlt1_ss(pcols,pver), dod5503dgt1_ss(pcols,pver), & + dod5503dlt1_dust(pcols,pver), dod5503dgt1_dust(pcols,pver), & + dod5503dlt1_so4(pcols,pver), dod5503dgt1_so4(pcols,pver), & + dod5503dlt1_bc(pcols,pver), dod5503dgt1_bc(pcols,pver), & + dod5503dlt1_pom(pcols,pver), dod5503dgt1_pom(pcols,pver) + + real(r8) abs440(pcols), dod500(pcols), abs500(pcols), & + dod670(pcols),& + abs670(pcols), abs870(pcols), & + dod440_ss(pcols), dod440_dust(pcols), dod440_so4(pcols), & + dod440_bc(pcols), dod440_pom(pcols), & + dod500_ss(pcols), dod500_dust(pcols), dod500_so4(pcols), & + dod500_bc(pcols), dod500_pom(pcols), & + dod550_ss(pcols), dod550_dust(pcols), dod550_so4(pcols), & + dod550_bc(pcols), dod550_pom(pcols), & + dod670_ss(pcols), dod670_dust(pcols), dod670_so4(pcols), & + dod670_bc(pcols), dod670_pom(pcols), & + dod870_ss(pcols), dod870_dust(pcols), dod870_so4(pcols), & + dod870_bc(pcols), dod870_pom(pcols), & + dod550lt1_ss(pcols), dod550gt1_ss(pcols), dod550lt1_dust(pcols), & + dod550gt1_dust(pcols), dod550lt1_so4(pcols), & + dod550gt1_so4(pcols), dod550lt1_bc(pcols), dod550gt1_bc(pcols), & + dod550lt1_pom(pcols), dod550gt1_pom(pcols) + + real(r8) abs550_ss(pcols), abs550_dust(pcols), & + abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) + + real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) + character(len=10) :: modeString + character(len=20) :: varname + integer irf,irfmax + real(r8) Camrel(pcols,pver,nbmodes) + real(r8) Camtot(pcols,nbmodes) + real(r8) cxsmtot(pcols,nbmodes) + real(r8) cxsmrel(pcols,nbmodes) + real(r8) xctrel,camdiff,cxsm + real(r8) cxs(pcols,pver), cxstot(pcols,pver), akcxs(pcols) + !------------------------------------------------------------------------- + + ! interpol-calculations only when daylight or not: + do icol=1,ncol + if (coszrs(icol) > 0.0_r8) then + daylight(icol) = .true. + else + daylight(icol) = .false. + endif + end do + + ! Initialize overshooting mass summed over all modes + do k=1,pver + do icol=1,ncol + cxstot(icol,k)=0.0_r8 + enddo + enddo + do icol=1,ncol + akcxs(icol)=0.0_r8 + enddo + + ! Initializing total and relative exessive (overshooting w.r.t. + ! look-up table maxima) added mass column: + do i=1,nbmodes + do icol=1,ncol + Camtot(icol,i)=0.0_r8 + cxsmtot(icol,i)=0.0_r8 + cxsmrel(icol,i)=0.0_r8 + enddo + enddo + + ! Calculating added internally mixed mass onto each mode 1-10, relative to + ! maximum mass which can be added w.r.t. the look-up tables (for level k), + ! as well as the relative exessive added mass column: + do i=1,4 + do k=1,pver + do icol=1,ncol + Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cate(i,16) + xctrel = min(max(Camrel(icol,k,i),cate(i,1)/cate(i,16)),1.0_r8) + camdiff = Cam(icol,k,i)-xctrel*cate(i,16)*(Nnatk(icol,k,i)+eps) + cxsm = max(0.0_r8,camdiff) + cxsmtot(icol,i) = cxsmtot(icol,i)+cxsm*deltah_km(icol,k) + Camtot(icol,i) = Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) + camdiff = Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) + cxs(icol,k) = max(0.0_r8,camdiff) + cxstot(icol,k) = cxstot(icol,k)+cxs(icol,k) + enddo + enddo + enddo + do i=5,nbmodes + do k=1,pver + do icol=1,ncol + Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cat(i,6) + xctrel = min(max(Camrel(icol,k,i),cat(i,1)/cat(i,6)),1.0_r8) + camdiff = Cam(icol,k,i)-xctrel*cat(i,6)*(Nnatk(icol,k,i)+eps) + cxsm = max(0.0_r8,camdiff) + cxsmtot(icol,i) = cxsmtot(icol,i)+cxsm*deltah_km(icol,k) + Camtot(icol,i) = Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) + camdiff = Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) + cxs(icol,k) = max(0.0_r8,camdiff) + cxstot(icol,k) = cxstot(icol,k)+cxs(icol,k) + enddo + enddo + enddo + + ! Total overshooting mass summed over all modes and all levels + do icol=1,ncol + do k=1,pver + akcxs(icol) =akcxs(icol)+cxstot(icol,k)*deltah_km(icol,k) + enddo + enddo + call outfld('AKCXS ',akcxs ,pcols,lchnk) + + do i=1,nbmodes + do icol=1,ncol + cxsmrel(icol,i)=cxsmtot(icol,i)/(Camtot(icol,i)+eps) + enddo + enddo + + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Camrel"//trim(modeString) + if(i.ne.3) call outfld(varName,Camrel(:,:,i),pcols,lchnk) + enddo + + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Cxsrel"//trim(modeString) + if(i.ne.3) call outfld(varName,cxsmrel(:,i),pcols,lchnk) + enddo + + ! AeroCom: Find dry aerosol asymmetry factor and mass for subsequent + ! calculation of condensed water mass below... + do k=1,pver + do icol=1,ncol + Ctotdry(icol,k)=0.0_r8 + rh0(icol,k)=0.0_r8 + asydry_aer(icol,k)=0.0_r8 + end do + enddo + + ! and define the respective RH input variables for dry aerosols + do k=1,pver + do icol=1,ncol + xrhnull(icol,k)=rh(1) + irh1null(icol,k)=1 + end do + enddo + + !-------- + lw_on = .false. ! No LW optics needed for RH=0 (interpol returns 0-values) + !-------- + + ! BC(ax) mode (dry only): + call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) + + mplus10 = 0 + ! SO4/SOA(Ait) mode: + call interpol1 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + + ! BC&OC(Ait) mode: ------ fcm not valid here (=0). Use faitbc instead + call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, & + xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) + + ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call interpol5to10 (lchnk, ncol, daylight, xrhnull, irh1null, & + Nnatk, xct, ict1, xfac, ifac1, & + xfbc, ifbc1, xfaq, ifaq1, & + ssa, asym, be, ke, lw_on, kalw) + + mplus10 = 1 + ! BC(Ait) and OC(Ait) modes: + call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xct, ict1, xfac, ifac1, & + ssa, asym, be, ke, lw_on, kalw) + + ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead + call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & + Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & + xfac, ifac1, xfaq, ifaq1, & + ssa, asym, be, ke, lw_on, kalw) + + do i=0,nmodes ! mode 0 to 14 + do k=1,pver + do icol=1,ncol + dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) + Ctotdry(icol,k)=Ctotdry(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) + end do + enddo + enddo + + ! AeroCom Phase III: adding asymmetry factor for dry aerosol, wavelength band 4 only + ! (and with no CMIP6 volcnic contribution) + ib=4 + do k=1,pver + do icol=1,ncol + betot(icol,k,ib)=0.0_r8 + ssatot(icol,k,ib)=0.0_r8 + asymtot(icol,k,ib)=0.0_r8 + end do + enddo + do i=0,nmodes + do k=1,pver + do icol=1,ncol + betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) + ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib) + asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & + *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) + end do + enddo + enddo + do k=1,pver + do icol=1,ncol + ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) + asymtot(icol,k,ib)=asymtot(icol,k,ib) & + /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) + asydry_aer(icol,k)=asymtot(icol,k,ib) + end do + enddo + call outfld('ASYMMDRY',asydry_aer,pcols,lchnk) + + !..................! + + ! Mass concentration (ug/m3) and mmr (kg/kg) of aerosol condensed water + do k=1,pver + do icol=1,ncol + Cwater(icol,k)=Ctot(icol,k)-Ctotdry(icol,k) + mmr_aerh2o(icol,k)=1.e-9_r8*Cwater(icol,k)/rhoda(icol,k) + end do + enddo + + !..................! + + do i=1,ncol + do k=1,pver + batotsw13(i,k)=betot(i,k,13)*(1.0_r8-ssatot(i,k,13)) + batotlw01(i,k)=batotlw(i,k,1) + end do + end do + ! These two fields should be close to equal, both representing absorption + ! in the 3.077-3.846 um wavelenght band (i.e., a check of LUT for LW vs. SW). + call outfld('BATSW13 ',batotsw13,pcols,lchnk) + call outfld('BATLW01 ',batotlw01,pcols,lchnk) + + !..................! + + call outfld('BETOTVIS',betotvis,pcols,lchnk) + call outfld('BATOTVIS',batotvis,pcols,lchnk) + + ! Initialize fields + do icol=1,ncol + daerh2o(icol)=0.0_r8 + vaercols(icol)=0.0_r8 + vaercoll(icol)=0.0_r8 + aaercols(icol)=0.0_r8 + aaercoll(icol)=0.0_r8 + do i=0,nmodes + dload(icol,i)=0.0_r8 + enddo + enddo + vnbcarr(:,:) = 0.0_r8 + vaitbcarr(:,:) = 0.0_r8 + cknorm(:,:,:) = 0.0_r8 + + ! AeroCom diagnostics requiring table look-ups with ambient RH. + do irf=0,0 + call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) + end do ! irf + + do k=1,pver + do icol=1,ncol + + bebglt1t(icol,k)=0.0_r8 + bebggt1t(icol,k)=0.0_r8 + bebclt1t(icol,k)=0.0_r8 + bebcgt1t(icol,k)=0.0_r8 + beoclt1t(icol,k)=0.0_r8 + beocgt1t(icol,k)=0.0_r8 + bes4lt1t(icol,k)=0.0_r8 + bes4gt1t(icol,k)=0.0_r8 + bedustlt1(icol,k)=0.0_r8 + bedustgt1(icol,k)=0.0_r8 + besslt1(icol,k)=0.0_r8 + bessgt1(icol,k)=0.0_r8 + + bext440tot(icol,k)=0.0_r8 + babs440tot(icol,k)=0.0_r8 + bext500tot(icol,k)=0.0_r8 + babs500tot(icol,k)=0.0_r8 + bext550tot(icol,k)=0.0_r8 + babs550tot(icol,k)=0.0_r8 + bext670tot(icol,k)=0.0_r8 + babs670tot(icol,k)=0.0_r8 + bext870tot(icol,k)=0.0_r8 + babs870tot(icol,k)=0.0_r8 + + backsc550tot(icol,k)=0.0_r8 + + bebg440tot(icol,k)=0.0_r8 + bebg500tot(icol,k)=0.0_r8 + bebg550tot(icol,k)=0.0_r8 + babg550tot(icol,k)=0.0_r8 + bebg670tot(icol,k)=0.0_r8 + bebg870tot(icol,k)=0.0_r8 + + bebc440tot(icol,k)=0.0_r8 + bebc500tot(icol,k)=0.0_r8 + bebc550tot(icol,k)=0.0_r8 + babc550tot(icol,k)=0.0_r8 + bebc670tot(icol,k)=0.0_r8 + bebc870tot(icol,k)=0.0_r8 + + beoc440tot(icol,k)=0.0_r8 + beoc500tot(icol,k)=0.0_r8 + beoc550tot(icol,k)=0.0_r8 + baoc550tot(icol,k)=0.0_r8 + beoc670tot(icol,k)=0.0_r8 + beoc870tot(icol,k)=0.0_r8 + + besu440tot(icol,k)=0.0_r8 + besu500tot(icol,k)=0.0_r8 + besu550tot(icol,k)=0.0_r8 + basu550tot(icol,k)=0.0_r8 + besu670tot(icol,k)=0.0_r8 + besu870tot(icol,k)=0.0_r8 + + enddo + enddo + + do i=0,nbmodes + do k=1,pver + do icol=1,ncol + ! total internal extinction and absorption for 0.44, 0.50, 0.55, 0.68 and 0.87 um + bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext440(icol,k,i) + babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i) + bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext500(icol,k,i) + babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs500(icol,k,i) + bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext550(icol,k,i) + babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i) + bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext670(icol,k,i) + babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs670(icol,k,i) + bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext870(icol,k,i) + babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i) + backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%backsc550(icol,k,i) + + ! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um + ! for the whole background aerosol (icluding SO4,BC, and OC for modes 0-5) + bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg440(icol,k,i) + bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg500(icol,k,i) + bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg550(icol,k,i) + babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babg550(icol,k,i) + bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg670(icol,k,i) + bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg870(icol,k,i) + besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu440(icol,k,i) + besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu500(icol,k,i) + besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu550(icol,k,i) + basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%basu550(icol,k,i) + besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu670(icol,k,i) + besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu870(icol,k,i) + ! + ! Condensed OC on modes 1-4 and coagulated BC and OC on modes 5-10: + if(i>=1) then + bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc440(icol,k,i) + bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc500(icol,k,i) + bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc550(icol,k,i) + babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babc550(icol,k,i) + bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc670(icol,k,i) + bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc870(icol,k,i) + beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc440(icol,k,i) + beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc500(icol,k,i) + beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc550(icol,k,i) + baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%baoc550(icol,k,i) + beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc670(icol,k,i) + beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc870(icol,k,i) + endif ! i>=1 + if(i==6.or.i==7) then + bedustlt1(icol,k)=bedustlt1(icol,k) +Nnatk(icol,k,i)*bebglt1(icol,k,i) + bedustgt1(icol,k)=bedustgt1(icol,k) +Nnatk(icol,k,i)*bebggt1(icol,k,i) + elseif(i>=8.and.i<=10) then + besslt1(icol,k)=besslt1(icol,k) +Nnatk(icol,k,i)*bebglt1(icol,k,i) + bessgt1(icol,k)=bessgt1(icol,k) +Nnatk(icol,k,i)*bebggt1(icol,k,i) + endif + ! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: + bes4lt1t(icol,k)=bes4lt1t(icol,k) +Nnatk(icol,k,i)*bes4lt1(icol,k,i) + bes4gt1t(icol,k)=bes4gt1t(icol,k) +Nnatk(icol,k,i)*bes4gt1(icol,k,i) + ! Condensed OC on mode 1 and coagulated BC and OC on modes 5-10: + if(i>=1) then + bebclt1t(icol,k)=bebclt1t(icol,k) +Nnatk(icol,k,i)*bebclt1(icol,k,i) + bebcgt1t(icol,k)=bebcgt1t(icol,k) +Nnatk(icol,k,i)*bebcgt1(icol,k,i) + beoclt1t(icol,k)=beoclt1t(icol,k) +Nnatk(icol,k,i)*beoclt1(icol,k,i) + beocgt1t(icol,k)=beocgt1t(icol,k) +Nnatk(icol,k,i)*beocgt1(icol,k,i) + endif ! i>=1 + end do ! icol + enddo ! k + enddo ! i + + ! extinction/absorptions (km-1) for each background component + ! in the internal mixture are + do k=1,pver + do icol=1,ncol + bint440du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg440(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg440(icol,k,7) + bint500du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg500(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg500(icol,k,7) + bint550du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg550(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg550(icol,k,7) + bint670du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg670(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg670(icol,k,7) + bint870du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg870(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%bebg870(icol,k,7) + bint440ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg440(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg440(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg440(icol,k,10) + bint500ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg500(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg500(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg500(icol,k,10) + bint550ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg550(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg550(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg550(icol,k,10) + bint670ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg670(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg670(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg670(icol,k,10) + bint870ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg870(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%bebg870(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%bebg870(icol,k,10) + baint550du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%babg550(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%babg550(icol,k,7) + baint550ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%babg550(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%babg550(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%babg550(icol,k,10) + end do + enddo + + ! Need to make the following substitutions + ! bebglt1 bebglt1n => extinction_coeffs%bebg550lt1 + ! bebggt1 bebggt1n => extinction_coeffs%bebg550gt1 + ! bebclt1 bebclt1n => extinction_coeffs%bebc550lt1 + ! bebcgt1 bebcgt1n => extinction_coeffs%bebc550gt1 + ! beoclt1 beoclt1n => extinction_coeffs%beoc550lt1 + ! beocgt1 beocgt1n => extinction_coeffs%beoc550gt1 + ! bes4lt1 bes4lt1n => extinction_coeffs%besu550lt1 + ! bes4gt1 bes4gt1n => extinction_coeffs%besu550gt1 + + do i=11,14 + do k=1,pver + do icol=1,ncol + be440x(icol,k,i) = extinction_coeffsn%bext440(icol,k,i-10) + ba440x(icol,k,i) = extinction_coeffsn%babs440(icol,k,i-10) + be500x(icol,k,i) = extinction_coeffsn%bext500(icol,k,i-10) + ba500x(icol,k,i) = extinction_coeffsn%babs500(icol,k,i-10) + be550x(icol,k,i) = extinction_coeffsn%bext550(icol,k,i-10) + ba550x(icol,k,i) = extinction_coeffsn%babs550(icol,k,i-10) + be670x(icol,k,i) = extinction_coeffsn%bext670(icol,k,i-10) + ba670x(icol,k,i) = extinction_coeffsn%babs670(icol,k,i-10) + be870x(icol,k,i) = extinction_coeffsn%bext870(icol,k,i-10) + ba870x(icol,k,i) = extinction_coeffsn%babs870(icol,k,i-10) + belt1x(icol,k,i) = extinction_coeffsn%bebg550lt1(icol,k,i-10) + begt1x(icol,k,i) = extinction_coeffsn%bebg550gt1(icol,k,i-10) + backsc550x(icol,k,i) = extinction_coeffsn%backsc550(icol,k,i-10) + end do + enddo + enddo + + ! The externally modes' contribution to extinction and absorption: + do k=1,pver + do icol=1,ncol + + !BC + vnbcarr(icol,k) = fnbc(icol,k)/(fnbc(icol,k) & + +(1.0_r8-fnbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) + vnbc = vnbcarr(icol,k) + bebc440xt(icol,k) =Nnatk(icol,k,12)*be440x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) + babc440xt(icol,k) =Nnatk(icol,k,12)*ba440x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) + bebc500xt(icol,k) =Nnatk(icol,k,12)*be500x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) + babc500xt(icol,k) =Nnatk(icol,k,12)*ba500x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) + bebc550xt(icol,k) =Nnatk(icol,k,12)*be550x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) + babc550xt(icol,k) =Nnatk(icol,k,12)*ba550x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) + bebc670xt(icol,k) =Nnatk(icol,k,12)*be670x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) + babc670xt(icol,k) =Nnatk(icol,k,12)*ba670x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) + bebc870xt(icol,k) =Nnatk(icol,k,12)*be870x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) + babc870xt(icol,k) =Nnatk(icol,k,12)*ba870x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) + bbclt1xt(icol,k)=Nnatk(icol,k,12)*belt1x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) + bbcgt1xt(icol,k)=Nnatk(icol,k,12)*begt1x(icol,k,12) & + +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) + !OC + beoc440xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be440x(icol,k,14) + baoc440xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba440x(icol,k,14) + beoc500xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be500x(icol,k,14) + baoc500xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba500x(icol,k,14) + beoc550xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be550x(icol,k,14) + baoc550xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba550x(icol,k,14) + beoc670xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be670x(icol,k,14) + baoc670xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba670x(icol,k,14) + beoc870xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be870x(icol,k,14) + baoc870xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba870x(icol,k,14) + boclt1xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*belt1x(icol,k,14) + bocgt1xt(icol,k) = & + +(1.0_r8-vnbc)*Nnatk(icol,k,14)*begt1x(icol,k,14) + ! Total (for all modes) absorption optical depth and backscattering + abs550_aer(icol,k)=babs550tot(icol,k) & + +Nnatk(icol,k,12)*ba550x(icol,k,12) & + +Nnatk(icol,k,14)*ba550x(icol,k,14) + abs550_aer(icol,k)=1.e-3_r8*abs550_aer(icol,k) + bs550_aer(icol,k)= backsc550tot(icol,k) & + +Nnatk(icol,k,12)*backsc550x(icol,k,12) & + +Nnatk(icol,k,14)*backsc550x(icol,k,14) + bs550_aer(icol,k)=1.e-3_r8*bs550_aer(icol,k) + ! + end do + enddo + + ! collect AeroCom-fields for optical depth/absorption of each comp, + ! 3D and 2D, at 440, 500, 550, 670 and 870 nm, for all d, d<1um and d>1um + ! initialize 2d-fields + do icol=1,ncol + dod440(icol) = 0.0_r8 + abs440(icol) = 0.0_r8 + dod500(icol) = 0.0_r8 + abs500(icol) = 0.0_r8 + dod550(icol) = 0.0_r8 + abs550(icol) = 0.0_r8 + abs550alt(icol) = 0.0_r8 + dod670(icol) = 0.0_r8 + abs670(icol) = 0.0_r8 + dod870(icol) = 0.0_r8 + abs870(icol) = 0.0_r8 + ! + abs550_ss(icol) = 0.0_r8 + abs550_dust(icol) = 0.0_r8 + abs550_so4(icol) = 0.0_r8 + abs550_bc(icol) = 0.0_r8 + abs550_pom(icol) = 0.0_r8 + ! + dod440_ss(icol) = 0.0_r8 + dod440_dust(icol) = 0.0_r8 + dod440_so4(icol) = 0.0_r8 + dod440_bc(icol) = 0.0_r8 + dod440_pom(icol) = 0.0_r8 + dod500_ss(icol) = 0.0_r8 + dod500_dust(icol) = 0.0_r8 + dod500_so4(icol) = 0.0_r8 + dod500_bc(icol) = 0.0_r8 + dod500_pom(icol) = 0.0_r8 + dod550_ss(icol) = 0.0_r8 + dod550_dust(icol) = 0.0_r8 + dod550_so4(icol) = 0.0_r8 + dod550_bc(icol) = 0.0_r8 + dod550_pom(icol) = 0.0_r8 + dod670_ss(icol) = 0.0_r8 + dod670_dust(icol) = 0.0_r8 + dod670_so4(icol) = 0.0_r8 + dod670_bc(icol) = 0.0_r8 + dod670_pom(icol) = 0.0_r8 + dod870_ss(icol) = 0.0_r8 + dod870_dust(icol) = 0.0_r8 + dod870_so4(icol) = 0.0_r8 + dod870_bc(icol) = 0.0_r8 + dod870_pom(icol) = 0.0_r8 + dod550lt1_ss(icol) = 0.0_r8 + dod550gt1_ss(icol) = 0.0_r8 + dod550lt1_dust(icol) = 0.0_r8 + dod550gt1_dust(icol) = 0.0_r8 + dod550lt1_so4(icol) = 0.0_r8 + dod550gt1_so4(icol) = 0.0_r8 + dod550lt1_bc(icol) = 0.0_r8 + dod550gt1_bc(icol) = 0.0_r8 + dod550lt1_pom(icol) = 0.0_r8 + dod550gt1_pom(icol) = 0.0_r8 + do k=1,pver + abs4403d(icol,k) = 0.0_r8 + abs5003d(icol,k) = 0.0_r8 + abs5503d(icol,k) = 0.0_r8 + abs6703d(icol,k) = 0.0_r8 + abs8703d(icol,k) = 0.0_r8 + abs5503dalt(icol,k) = 0.0_r8 + enddo + enddo + + do icol=1,ncol + do k=1,pver + ! Layer thickness, unit km + deltah=deltah_km(icol,k) + ! if(k==pver) write(*,*) 'icol, deltah(pmxsub)=', icol, deltah + ! 3D optical depths for monthly averages + !SS + dod4403d_ss(icol,k) = bint440ss(icol,k)*deltah + dod5003d_ss(icol,k) = bint500ss(icol,k)*deltah + dod5503d_ss(icol,k) = bint550ss(icol,k)*deltah + abs5503d_ss(icol,k) = baint550ss(icol,k)*deltah + dod6703d_ss(icol,k) = bint670ss(icol,k)*deltah + dod8703d_ss(icol,k) = bint870ss(icol,k)*deltah + !DUST + dod4403d_dust(icol,k) = bint440du(icol,k)*deltah + dod5003d_dust(icol,k) = bint500du(icol,k)*deltah + dod5503d_dust(icol,k) = bint550du(icol,k)*deltah + abs5503d_dust(icol,k) = baint550du(icol,k)*deltah + dod6703d_dust(icol,k) = bint670du(icol,k)*deltah + dod8703d_dust(icol,k) = bint870du(icol,k)*deltah + !SO4 + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + dod4403d_so4(icol,k) = (besu440tot(icol,k) & ! condensate ) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5003d_so4(icol,k) = (besu500tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5503d_so4(icol,k) = (besu550tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + abs5503d_so4(icol,k) = (basu550tot(icol,k) & ! condensate ) + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod6703d_so4(icol,k) = (besu670tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod8703d_so4(icol,k) = (besu870tot(icol,k) & ! condensate + +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + !BC + vaitbcarr(icol,k) = faitbc(icol,k)/(faitbc(icol,k) & + +(1.0_r8-faitbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) + vaitbc = vaitbcarr(icol,k) + dod4403d_bc(icol,k) = (bebc440tot(icol,k)+bebc440xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*extinction_coeffs%bebg440(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5003d_bc(icol,k) = (bebc500tot(icol,k)+bebc500xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*extinction_coeffs%bebg500(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5503d_bc(icol,k) = (bebc550tot(icol,k)+bebc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*extinction_coeffs%bebg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + abs5503d_bc(icol,k) = (babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*extinction_coeffs%babg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod6703d_bc(icol,k) = (bebc670tot(icol,k)+bebc670xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*extinction_coeffs%bebg670(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod8703d_bc(icol,k) = (bebc870tot(icol,k)+bebc870xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*extinction_coeffs%bebg870(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) + !OC + !soa + v_soana part of mode 11 for the OC volume fraction of that mode + ! v_soana(icol,k) + dod4403d_pom(icol,k) = (beoc440tot(icol,k)+beoc440xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*extinction_coeffs%bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg440(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5003d_pom(icol,k) = (beoc500tot(icol,k)+beoc500xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*extinction_coeffs%bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg500(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5503d_pom(icol,k) = (beoc550tot(icol,k)+beoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*extinction_coeffs%bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + abs5503d_pom(icol,k) = (baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod6703d_pom(icol,k) = (beoc670tot(icol,k)+beoc670xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*extinction_coeffs%bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg670(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod8703d_pom(icol,k) = (beoc870tot(icol,k)+beoc870xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*extinction_coeffs%bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg870(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + ec550_so4(icol,k) = 1.e-3*dod5503d_so4(icol,k)/deltah + ec550_bc(icol,k) = 1.e-3*dod5503d_bc(icol,k)/deltah + ec550_pom(icol,k) = 1.e-3*dod5503d_pom(icol,k)/deltah + ec550_ss(icol,k) = 1.e-3*dod5503d_ss(icol,k)/deltah + ec550_du(icol,k) = 1.e-3*dod5503d_dust(icol,k)/deltah + ec550_aer(icol,k) = ec550_so4(icol,k)+ec550_bc(icol,k)+ec550_pom(icol,k) & + + ec550_ss(icol,k)+ec550_du(icol,k) + + ! Total 3D optical depths/abs. for column integrations + dod4403d(icol,k) = dod4403d_ss(icol,k)+dod4403d_dust(icol,k) & + +dod4403d_so4(icol,k)+dod4403d_bc(icol,k) & + +dod4403d_pom(icol,k) + dod5003d(icol,k) = dod5003d_ss(icol,k)+dod5003d_dust(icol,k) & + +dod5003d_so4(icol,k)+dod5003d_bc(icol,k) & + +dod5003d_pom(icol,k) + dod5503d(icol,k) = dod5503d_ss(icol,k)+dod5503d_dust(icol,k) & + +dod5503d_so4(icol,k)+dod5503d_bc(icol,k) & + +dod5503d_pom(icol,k) + dod6703d(icol,k) = dod6703d_ss(icol,k)+dod6703d_dust(icol,k) & + +dod6703d_so4(icol,k)+dod6703d_bc(icol,k) & + +dod6703d_pom(icol,k) + dod8703d(icol,k) = dod8703d_ss(icol,k)+dod8703d_dust(icol,k) & + +dod8703d_so4(icol,k)+dod8703d_bc(icol,k) & + +dod8703d_pom(icol,k) + abs5503d(icol,k) = abs5503d_ss(icol,k)+abs5503d_dust(icol,k) & + +abs5503d_so4(icol,k)+abs5503d_bc(icol,k) & + +abs5503d_pom(icol,k) + ! (Note: Local abs550alt is up to 6% larger (annually averaged) in typical b.b. + ! regions, compared to abs550. This is most likely most correct, but should be checked!) + do i=0,10 + abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i)*deltah + abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs500(icol,k,i)*deltah + abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs670(icol,k,i)*deltah + abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i)*deltah + abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i)*deltah + enddo + do i=11,14 + abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs440(icol,k,i-10)*deltah + abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs500(icol,k,i-10)*deltah + abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs670(icol,k,i-10)*deltah + abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs870(icol,k,i-10)*deltah + abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs550(icol,k,i-10)*deltah + enddo + + ! optical depths for d<1um and d>1um (r<0.5um and r>0.5um) + !SS + dod5503dlt1_ss(icol,k) = besslt1(icol,k)*deltah + dod5503dgt1_ss(icol,k) = bessgt1(icol,k)*deltah + !DUST + dod5503dlt1_dust(icol,k) = bedustlt1(icol,k)*deltah + dod5503dgt1_dust(icol,k) = bedustgt1(icol,k)*deltah + + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + dod5503dlt1_so4(icol,k) = (bes4lt1t(icol,k) & ! condensate + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebglt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + dod5503dgt1_so4(icol,k) = (bes4gt1t(icol,k) & ! condensate + n-mode (11) + + Nnatk(icol,k,1)*bebggt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*bebggt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) + !BC + dod5503dlt1_bc(icol,k) = (bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebglt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebglt1(icol,k,0))*deltah ! background, BC(ax) mode (0) + dod5503dgt1_bc(icol,k) = (bebcgt1t(icol,k)+bbcgt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*bebggt1(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc*Nnatk(icol,k,4)*bebggt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*bebggt1(icol,k,0))*deltah ! background, BC(ax) mode (0) + !OC + !soa + v_soana part of mode 11 for the OC volume fraction of that mode + dod5503dlt1_pom(icol,k) = (beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC&BC (14) + + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebglt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + dod5503dgt1_pom(icol,k) = (beocgt1t(icol,k)+bocgt1xt(icol,k) & ! coagulated + n-mode OC&OC (14) + + Nnatk(icol,k,1)*bebggt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 + !-3 + Nnatk(icol,k,3)*bebggt1(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebggt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) + + ! Column integrated optical depths/abs., total and for each constituent + dod440(icol) = dod440(icol)+dod4403d(icol,k) + abs440(icol) = abs440(icol)+abs4403d(icol,k) + dod500(icol) = dod500(icol)+dod5003d(icol,k) + abs500(icol) = abs500(icol)+abs5003d(icol,k) + dod550(icol) = dod550(icol)+dod5503d(icol,k) + abs550(icol) = abs550(icol)+abs5503d(icol,k) + abs550alt(icol) = abs550alt(icol)+abs5503dalt(icol,k) + dod670(icol) = dod670(icol)+dod6703d(icol,k) + abs670(icol) = abs670(icol)+abs6703d(icol,k) + dod870(icol) = dod870(icol)+dod8703d(icol,k) + abs870(icol) = abs870(icol)+abs8703d(icol,k) + ! Added abs components + abs550_ss(icol) = abs550_ss(icol)+abs5503d_ss(icol,k) + abs550_dust(icol) = abs550_dust(icol)+abs5503d_dust(icol,k) + abs550_so4(icol) = abs550_so4(icol)+abs5503d_so4(icol,k) + abs550_bc(icol) = abs550_bc(icol)+abs5503d_bc(icol,k) + abs550_pom(icol) = abs550_pom(icol)+abs5503d_pom(icol,k) + ! + dod440_ss(icol) = dod440_ss(icol)+dod4403d_ss(icol,k) + dod440_dust(icol) = dod440_dust(icol)+dod4403d_dust(icol,k) + dod440_so4(icol) = dod440_so4(icol)+dod4403d_so4(icol,k) + dod440_bc(icol) = dod440_bc(icol)+dod4403d_bc(icol,k) + dod440_pom(icol) = dod440_pom(icol)+dod4403d_pom(icol,k) + dod500_ss(icol) = dod500_ss(icol)+dod5003d_ss(icol,k) + dod500_dust(icol) = dod500_dust(icol)+dod5003d_dust(icol,k) + dod500_so4(icol) = dod500_so4(icol)+dod5003d_so4(icol,k) + dod500_bc(icol) = dod500_bc(icol)+dod5003d_bc(icol,k) + dod500_pom(icol) = dod500_pom(icol)+dod5003d_pom(icol,k) + dod550_ss(icol) = dod550_ss(icol)+dod5503d_ss(icol,k) + dod550_dust(icol) = dod550_dust(icol)+dod5503d_dust(icol,k) + dod550_so4(icol) = dod550_so4(icol)+dod5503d_so4(icol,k) + dod550_bc(icol) = dod550_bc(icol)+dod5503d_bc(icol,k) + dod550_pom(icol) = dod550_pom(icol)+dod5503d_pom(icol,k) + dod670_ss(icol) = dod670_ss(icol)+dod6703d_ss(icol,k) + dod670_dust(icol) = dod670_dust(icol)+dod6703d_dust(icol,k) + dod670_so4(icol) = dod670_so4(icol)+dod6703d_so4(icol,k) + dod670_bc(icol) = dod670_bc(icol)+dod6703d_bc(icol,k) + dod670_pom(icol) = dod670_pom(icol)+dod6703d_pom(icol,k) + dod870_ss(icol) = dod870_ss(icol)+dod8703d_ss(icol,k) + dod870_dust(icol) = dod870_dust(icol)+dod8703d_dust(icol,k) + dod870_so4(icol) = dod870_so4(icol)+dod8703d_so4(icol,k) + dod870_bc(icol) = dod870_bc(icol)+dod8703d_bc(icol,k) + dod870_pom(icol) = dod870_pom(icol)+dod8703d_pom(icol,k) + dod550lt1_ss(icol) = dod550lt1_ss(icol)+dod5503dlt1_ss(icol,k) + dod550gt1_ss(icol) = dod550gt1_ss(icol)+dod5503dgt1_ss(icol,k) + dod550lt1_dust(icol) = dod550lt1_dust(icol)+dod5503dlt1_dust(icol,k) + dod550gt1_dust(icol) = dod550gt1_dust(icol)+dod5503dgt1_dust(icol,k) + dod550lt1_so4(icol) = dod550lt1_so4(icol)+dod5503dlt1_so4(icol,k) + dod550gt1_so4(icol) = dod550gt1_so4(icol)+dod5503dgt1_so4(icol,k) + dod550lt1_bc(icol) = dod550lt1_bc(icol)+dod5503dlt1_bc(icol,k) + dod550gt1_bc(icol) = dod550gt1_bc(icol)+dod5503dgt1_bc(icol,k) + dod550lt1_pom(icol) = dod550lt1_pom(icol)+dod5503dlt1_pom(icol,k) + dod550gt1_pom(icol) = dod550gt1_pom(icol)+dod5503dgt1_pom(icol,k) + enddo ! k + + enddo ! icol + + ! extinction, absorption (m-1) and backscatter coefficients (m-1 sr-1) + call outfld('EC550AER',ec550_aer,pcols,lchnk) + call outfld('ABS550_A',abs550_aer,pcols,lchnk) + call outfld('BS550AER',bs550_aer,pcols,lchnk) + ! + ! speciated extinction coefficients (m-1) + call outfld('EC550SO4',ec550_so4,pcols,lchnk) + call outfld('EC550BC ',ec550_bc ,pcols,lchnk) + call outfld('EC550POM',ec550_pom,pcols,lchnk) + call outfld('EC550SS ',ec550_ss ,pcols,lchnk) + call outfld('EC550DU ',ec550_du ,pcols,lchnk) + ! + ! optical depths and absorption as requested by AeroCom + ! notation: 3=3D, D=DOD, A=ABS, LT=d<1um, GT=d>1um + call outfld('DOD440 ',dod440 ,pcols,lchnk) + call outfld('ABS440 ',abs440 ,pcols,lchnk) + call outfld('DOD500 ',dod500 ,pcols,lchnk) + call outfld('ABS500 ',abs500 ,pcols,lchnk) + call outfld('DOD550 ',dod550 ,pcols,lchnk) + call outfld('ABS550 ',abs550 ,pcols,lchnk) + call outfld('ABS550AL',abs550alt,pcols,lchnk) + call outfld('DOD670 ',dod670 ,pcols,lchnk) + call outfld('ABS670 ',abs670 ,pcols,lchnk) + call outfld('DOD870 ',dod870 ,pcols,lchnk) + call outfld('ABS870 ',abs870 ,pcols,lchnk) + call outfld('A550_SS ',abs550_ss ,pcols,lchnk) + call outfld('A550_DU ',abs550_dust,pcols,lchnk) + call outfld('A550_SO4',abs550_so4 ,pcols,lchnk) + call outfld('A550_BC ',abs550_bc ,pcols,lchnk) + call outfld('A550_POM',abs550_pom ,pcols,lchnk) + ! + call outfld('D440_SS ',dod440_ss ,pcols,lchnk) + call outfld('D440_DU ',dod440_dust,pcols,lchnk) + call outfld('D440_SO4',dod440_so4 ,pcols,lchnk) + call outfld('D440_BC ',dod440_bc ,pcols,lchnk) + call outfld('D440_POM',dod440_pom ,pcols,lchnk) + call outfld('D500_SS ',dod500_ss ,pcols,lchnk) + call outfld('D500_DU ',dod500_dust,pcols,lchnk) + call outfld('D500_SO4',dod500_so4 ,pcols,lchnk) + call outfld('D500_BC ',dod500_bc ,pcols,lchnk) + call outfld('D500_POM',dod500_pom ,pcols,lchnk) + call outfld('D550_SS ',dod550_ss ,pcols,lchnk) + call outfld('D550_DU ',dod550_dust,pcols,lchnk) + call outfld('D550_SO4',dod550_so4 ,pcols,lchnk) + call outfld('D550_BC ',dod550_bc ,pcols,lchnk) + call outfld('D550_POM',dod550_pom ,pcols,lchnk) + call outfld('D670_SS ',dod670_ss ,pcols,lchnk) + call outfld('D670_DU ',dod670_dust,pcols,lchnk) + call outfld('D670_SO4',dod670_so4 ,pcols,lchnk) + call outfld('D670_BC ',dod670_bc ,pcols,lchnk) + call outfld('D670_POM',dod670_pom ,pcols,lchnk) + call outfld('D870_SS ',dod870_ss ,pcols,lchnk) + call outfld('D870_DU ',dod870_dust,pcols,lchnk) + call outfld('D870_SO4',dod870_so4 ,pcols,lchnk) + call outfld('D870_BC ',dod870_bc ,pcols,lchnk) + call outfld('D870_POM',dod870_pom ,pcols,lchnk) + call outfld('DLT_SS ',dod550lt1_ss,pcols,lchnk) + call outfld('DGT_SS ',dod550gt1_ss,pcols,lchnk) + call outfld('DLT_DUST',dod550lt1_dust,pcols,lchnk) + call outfld('DGT_DUST',dod550gt1_dust,pcols,lchnk) + call outfld('DLT_SO4 ',dod550lt1_so4,pcols,lchnk) + call outfld('DGT_SO4 ',dod550gt1_so4,pcols,lchnk) + call outfld('DLT_BC ',dod550lt1_bc,pcols,lchnk) + call outfld('DGT_BC ',dod550gt1_bc,pcols,lchnk) + call outfld('DLT_POM ',dod550lt1_pom,pcols,lchnk) + call outfld('DGT_POM ',dod550gt1_pom,pcols,lchnk) + ! Dry parameters of each aerosol component + ! BC(ax) mode + call aerodry_prop%intdrypar0(lchnk, ncol, Nnatk) + + ! SO4&SOA(Ait,n) mode + call aerodry_prop%intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) + + ! BC(Ait,n) and OC(Ait,n) modes + call aerodry_prop%intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1) + + ! BC&OC(Ait,n) mode ------ fcm not valid here (=0). Use faitbc or fnbc instead + call aerodry_prop%intdrypar4(lchnk, ncol, Nnatk, xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & + xct, ict1, xfac, ifac1, xfaq, ifaq1) + + ! SO4(Ait75) (5), mineral (6-7) and Sea-salt (8-10) modes: + call aerodry_prop%intdrypar5to10(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) + + do k=1,pver + do icol=1,ncol + c_ss(icol,k)=0.0_r8 + c_mi(icol,k)=0.0_r8 + enddo + enddo + + do k=1,pver + do icol=1,ncol + ! mineral and sea-salt background concentrations, internally mixed + c_mi(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg(icol,k,6) & + +Nnatk(icol,k,7) * aerodry_prop%cintbg(icol,k,7) + c_mi05(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg05(icol,k,6) & + +Nnatk(icol,k,7) * aerodry_prop%cintbg05(icol,k,7) + c_mi125(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg125(icol,k,6)& + +Nnatk(icol,k,7) * aerodry_prop%cintbg125(icol,k,7) + c_ss(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg(icol,k,8) & + +Nnatk(icol,k,9) * aerodry_prop%cintbg(icol,k,9) & + +Nnatk(icol,k,10) * aerodry_prop%cintbg(icol,k,10) + c_ss05(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg05(icol,k,8) & + +Nnatk(icol,k,9) * aerodry_prop%cintbg05(icol,k,9) & + +Nnatk(icol,k,10) * aerodry_prop%cintbg05(icol,k,10) + c_ss125(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg125(icol,k,8)& + +Nnatk(icol,k,9) * aerodry_prop%cintbg125(icol,k,9) & + +Nnatk(icol,k,10) * aerodry_prop%cintbg125(icol,k,10) + + ! internally mixed bc and oc (from coagulation) and so4 concentrations + ! (sa=so4(aq) and sc=so4(cond+coag), separated because of different density: + ! necessary for calculation of volume fractions!), and total aerosol surface + ! areas and volumes. + c_bc(icol,k)=0.0_r8 + c_bc05(icol,k)=0.0_r8 + c_bc125(icol,k)=0.0_r8 + c_oc(icol,k)=0.0_r8 + c_oc05(icol,k)=0.0_r8 + c_oc125(icol,k)=0.0_r8 + c_s4(icol,k)=0.0_r8 + c_s4_a(icol,k)=0.0_r8 + c_s4_1(icol,k)=0.0_r8 + c_s4_5(icol,k)=0.0_r8 + c_sa(icol,k)=0.0_r8 + c_sa05(icol,k)=0.0_r8 + c_sa125(icol,k)=0.0_r8 + c_sc(icol,k)=0.0_r8 + c_sc05(icol,k)=0.0_r8 + c_sc125(icol,k)=0.0_r8 + aaeros_tot(icol,k)=0.0_r8 + aaerol_tot(icol,k)=0.0_r8 + vaeros_tot(icol,k)=0.0_r8 + vaerol_tot(icol,k)=0.0_r8 + c_bc_0(icol,k)=0.0_r8 + c_bc_2(icol,k)=0.0_r8 + c_bc_4(icol,k)=0.0_r8 + c_bc_12(icol,k)=0.0_r8 + c_bc_14(icol,k)=0.0_r8 + c_oc_4(icol,k)=0.0_r8 + c_oc_14(icol,k)=0.0_r8 + c_tot(icol,k)=0.0_r8 + c_tot125(icol,k)=0.0_r8 + c_tot05(icol,k)=0.0_r8 + c_pm25(icol,k)=0.0_r8 + c_pm1(icol,k)=0.0_r8 + mmr_pm25(icol,k)=0.0_r8 + mmr_pm1(icol,k)=0.0_r8 + + do i=0,nbmodes + if(i.ne.3) then + c_bc(icol,k) = c_bc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc(icol,k,i) + c_bc05(icol,k) = c_bc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc05(icol,k,i) + c_bc125(icol,k) = c_bc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc125(icol,k,i) + c_oc(icol,k) = c_oc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc(icol,k,i) + c_oc05(icol,k) = c_oc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc05(icol,k,i) + c_oc125(icol,k) = c_oc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc125(icol,k,i) + c_sa(icol,k) = c_sa(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa(icol,k,i) + c_sa05(icol,k) = c_sa05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa05(icol,k,i) + c_sa125(icol,k) = c_sa125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa125(icol,k,i) + c_sc(icol,k) = c_sc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc(icol,k,i) + c_sc05(icol,k) = c_sc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc05(icol,k,i) + c_sc125(icol,k) = c_sc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc125(icol,k,i) + aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeros(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerol(icol,k,i) + vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeros(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerol(icol,k,i) + endif + enddo + ! add dry aerosol area and volume of externally mixed modes + do i=nbmp1,nmodes + aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerosn(icol,k,i) + aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeroln(icol,k,i) + vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerosn(icol,k,i) + vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeroln(icol,k,i) + end do + + !c_er3d + ! Effective radii for particles smaller and greater than 0.5um, + ! and for all radii, in each layer (er=3*V/A): + erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) /(aaeros_tot(icol,k)+eps) + ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) /(aaerol_tot(icol,k)+eps) + er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) + + !c_er3d + ! column integrated dry aerosol surface areas and volumes + ! for r<0.5um and r>0.5um (s and l, respectively). + aaercols(icol)=aaercols(icol)+aaeros_tot(icol,k) + aaercoll(icol)=aaercoll(icol)+aaerol_tot(icol,k) + vaercols(icol)=vaercols(icol)+vaeros_tot(icol,k) + vaercoll(icol)=vaercoll(icol)+vaerol_tot(icol,k) + + ! then add background and externally mixed BC, OC and SO4 to mass concentrations + c_bc_ac(icol,k)= c_bc(icol,k) + c_bc_0(icol,k) = Nnatk(icol,k,0) * aerodry_prop%cintbg(icol,k,0) + c_bc_2(icol,k) = Nnatk(icol,k,2) * aerodry_prop%cintbg(icol,k,2) + c_bc_4(icol,k) = Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*faitbc(icol,k) + c_bc_12(icol,k)= Nnatk(icol,k,12) * aerodry_prop%cknorm(icol,k,12) + c_bc_14(icol,k)= Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) + c_bc(icol,k) = c_bc(icol,k) & + +Nnatk(icol,k,2) * aerodry_prop%cintbg(icol,k,2) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4) * faitbc(icol,k) & + +Nnatk(icol,k,0) * aerodry_prop%cintbg(icol,k,0) & + +Nnatk(icol,k,12) * aerodry_prop%cknorm(icol,k,12) & + +Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) + c_bc05(icol,k) = c_bc05(icol,k) & + +Nnatk(icol,k,2) * aerodry_prop%cintbg05(icol,k,2) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg05(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0) * aerodry_prop%cintbg05(icol,k,0) & + +Nnatk(icol,k,12) * aerodry_prop%cknlt05(icol,k,12) & + +Nnatk(icol,k,14) * aerodry_prop%cknlt05(icol,k,14)*fnbc(icol,k) + c_bc125(icol,k) = c_bc125(icol,k) & + +Nnatk(icol,k,2) * aerodry_prop%cintbg125(icol,k,2) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg125(icol,k,4)*faitbc(icol,k) & + +Nnatk(icol,k,0) * aerodry_prop%cintbg125(icol,k,0) & + +Nnatk(icol,k,12) * aerodry_prop%ckngt125(icol,k,12) & + +Nnatk(icol,k,14) * aerodry_prop%ckngt125(icol,k,14)*fnbc(icol,k) + c_oc_ac(icol,k)= c_oc(icol,k) + c_oc_4(icol,k) = Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) + c_oc_14(icol,k) = Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc(icol,k) = c_oc(icol,k) & + +Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*f_soana(icol,k) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc05(icol,k) = c_oc05(icol,k) & + +Nnatk(icol,k,1) * aerodry_prop%cintbg05(icol,k,1)*f_soana(icol,k) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14) * aerodry_prop%cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_oc125(icol,k) = c_oc125(icol,k) & + +Nnatk(icol,k,1) * aerodry_prop%cintbg125(icol,k,1)*f_soana(icol,k) & + +Nnatk(icol,k,4) * aerodry_prop%cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & + +Nnatk(icol,k,14) * aerodry_prop%ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) + c_s4(icol,k) = c_sa(icol,k)+c_sc(icol,k) & + +Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5) * aerodry_prop%cintbg(icol,k,5) + c_s405(icol,k) = c_sa05(icol,k)+c_sc05(icol,k) & + +Nnatk(icol,k,1) * aerodry_prop%cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5) * aerodry_prop%cintbg05(icol,k,5) + c_s4125(icol,k) = c_sa125(icol,k)+c_sc125(icol,k) & + +Nnatk(icol,k,1) * aerodry_prop%cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & + +Nnatk(icol,k,5) * aerodry_prop%cintbg125(icol,k,5) + + c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) + c_mi(icol,k) + c_ss(icol,k) + c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) + c_mi125(icol,k) + c_ss125(icol,k) + c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) + c_mi05(icol,k) + c_ss05(icol,k) + c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) + c_pm1(icol,k) = c_tot05(icol,k) + + ! mass mixing ratio: + mmr_pm25(icol,k) = 1.e-9*c_pm25(icol,k)/rhoda(icol,k) + mmr_pm1(icol,k) = 1.e-9*c_pm1(icol,k)/rhoda(icol,k) + + ! converting from S to SO4 concentrations is no longer necessary, since + ! sc=H2SO4 and sa=(NH4)2SO4 now, not SO4 as in CAM4-Oslo + ! c_s4(icol,k)=c_s4(icol,k)/3._r8 + ! c_s405(icol,k)=c_s405(icol,k)/3._r8 + ! c_s4125(icol,k)=c_s4125(icol,k)/3._r8 + + c_s4_a(icol,k) = c_sa(icol,k)+c_sc(icol,k) + c_s4_1(icol,k) = Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) + c_s4_5(icol,k) = Nnatk(icol,k,5) * aerodry_prop%cintbg05(icol,k,5) + + end do ! icol + enddo ! k + + ! Total PM and PM2.5 (dry r>1.25um), surface values (ug/m3) + do icol=1,ncol + c_tots(icol) = c_tot(icol,pver) + c_tot125s(icol) = c_tot125(icol,pver) + c_pm25s(icol) = c_pm25(icol,pver) + enddo + + ! Effective, column integrated, radii for particles + ! smaller and greater than 0.5um, and for all radii + do icol=1,ncol + derlt05(icol)=3.0_r8*vaercols(icol)/(aaercols(icol)+eps) + dergt05(icol)=3.0_r8*vaercoll(icol)/(aaercoll(icol)+eps) + der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) /(aaercols(icol)+aaercoll(icol)+eps) + enddo + + do icol=1,ncol + dload_s4(icol)=0.0_r8 + dload_s4_a(icol)=0.0_r8 + dload_s4_1(icol)=0.0_r8 + dload_s4_5(icol)=0.0_r8 + dload_oc(icol)=0.0_r8 + dload_bc(icol)=0.0_r8 + dload_bc_ac(icol)=0.0_r8 + dload_bc_0(icol)=0.0_r8 + dload_bc_2(icol)=0.0_r8 + dload_bc_4(icol)=0.0_r8 + dload_bc_12(icol)=0.0_r8 + dload_bc_14(icol)=0.0_r8 + dload_oc_ac(icol)=0.0_r8 + dload_oc_4(icol)=0.0_r8 + dload_oc_14(icol)=0.0_r8 + do k=1,pver + ! Layer thickness, unit km + !- deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) + deltah=deltah_km(icol,k) + ! Modal and total mass concentrations for clean and dry aerosol, + ! i.e. not including coag./cond./Aq. BC,OC,SO4 or condensed water. + ! Units: ug/m3 for concentrations and mg/m2 (--> kg/m2 later) for mass loading. + do i=0,nmodes + ck(icol,k,i)=cknorm(icol,k,i)*Nnatk(icol,k,i) + dload3d(icol,k,i)=ck(icol,k,i)*deltah + dload(icol,i)=dload(icol,i)+dload3d(icol,k,i) + enddo + nnat_0(icol,k) =Nnatk(icol,k,0) + nnat_1(icol,k) =Nnatk(icol,k,1) + nnat_2(icol,k) =Nnatk(icol,k,2) + nnat_4(icol,k) =Nnatk(icol,k,4) + nnat_5(icol,k) =Nnatk(icol,k,5) + nnat_6(icol,k) =Nnatk(icol,k,6) + nnat_7(icol,k) =Nnatk(icol,k,7) + nnat_8(icol,k) =Nnatk(icol,k,8) + nnat_9(icol,k) =Nnatk(icol,k,9) + nnat_10(icol,k)=Nnatk(icol,k,10) + nnat_12(icol,k)=Nnatk(icol,k,12) + nnat_14(icol,k)=Nnatk(icol,k,14) + ! mineral and sea-salt mass concentrations + cmin(icol,k)=ck(icol,k,6)+ck(icol,k,7) + cseas(icol,k)=ck(icol,k,8)+ck(icol,k,9)+ck(icol,k,10) + ! Aerocom: Condensed water loading (mg_m2) + daerh2o(icol)=daerh2o(icol)+Cwater(icol,k)*deltah + ! just for checking purposes: + dload_s4(icol)=dload_s4(icol)+c_s4(icol,k)*deltah + dload_s4_a(icol)=dload_s4_a(icol)+c_s4_a(icol,k)*deltah + dload_s4_1(icol)=dload_s4_1(icol)+c_s4_1(icol,k)*deltah + dload_s4_5(icol)=dload_s4_5(icol)+c_s4_5(icol,k)*deltah + dload_oc(icol)=dload_oc(icol)+c_oc(icol,k)*deltah + dload_bc(icol)=dload_bc(icol)+c_bc(icol,k)*deltah + ! + dload_bc_ac(icol)=dload_bc_ac(icol)+c_bc_ac(icol,k)*deltah + dload_bc_0(icol)=dload_bc_0(icol)+c_bc_0(icol,k)*deltah + dload_bc_2(icol)=dload_bc_2(icol)+c_bc_2(icol,k)*deltah + dload_bc_4(icol)=dload_bc_4(icol)+c_bc_4(icol,k)*deltah + dload_bc_12(icol)=dload_bc_12(icol)+c_bc_12(icol,k)*deltah + dload_bc_14(icol)=dload_bc_14(icol)+c_bc_14(icol,k)*deltah + dload_oc_ac(icol)=dload_oc_ac(icol)+c_oc_ac(icol,k)*deltah + dload_oc_4(icol)=dload_oc_4(icol)+c_oc_4(icol,k)*deltah + dload_oc_14(icol)=dload_oc_14(icol)+c_oc_14(icol,k)*deltah + ! + end do ! k + dload_mi(icol)=dload(icol,6)+dload(icol,7) + dload_ss(icol)=dload(icol,8)+dload(icol,9)+dload(icol,10) + end do ! icol + + call outfld('PMTOT ',c_tots ,pcols,lchnk) + call outfld('PM25 ',c_pm25s ,pcols,lchnk) + call outfld('PM2P5 ',c_pm25 ,pcols,lchnk) + call outfld('MMRPM2P5',mmr_pm25,pcols,lchnk) + call outfld('MMRPM1 ',mmr_pm1 ,pcols,lchnk) + call outfld('MMRPM2P5_SRF',mmr_pm25(:pcols,pver),pcols,lchnk) + ! total (all r) dry concentrations (ug/m3) and loadings (mg/m2) + call outfld('DLOAD_MI',dload_mi,pcols,lchnk) + call outfld('DLOAD_SS',dload_ss,pcols,lchnk) + call outfld('DLOAD_S4',dload_s4,pcols,lchnk) + call outfld('DLOAD_OC',dload_oc,pcols,lchnk) + call outfld('DLOAD_BC',dload_bc,pcols,lchnk) + + call outfld('LOADBCAC',dload_bc_ac,pcols,lchnk) + call outfld('LOADBC0 ',dload_bc_0,pcols,lchnk) + call outfld('LOADBC2 ',dload_bc_2,pcols,lchnk) + call outfld('LOADBC4 ',dload_bc_4,pcols,lchnk) + call outfld('LOADBC12',dload_bc_12,pcols,lchnk) + call outfld('LOADBC14',dload_bc_14,pcols,lchnk) + call outfld('LOADOCAC',dload_oc_ac,pcols,lchnk) + call outfld('LOADOC4 ',dload_oc_4,pcols,lchnk) + call outfld('LOADOC14',dload_oc_14,pcols,lchnk) + ! condensed water mmr (kg/kg) + call outfld('MMR_AH2O',mmr_aerh2o,pcols,lchnk) + ! condensed water loading (mg/m2) + call outfld('DAERH2O ',daerh2o ,pcols,lchnk) + ! number concentrations (1/cm3) + call outfld('NNAT_0 ',nnat_0 ,pcols,lchnk) + call outfld('NNAT_1 ',nnat_1 ,pcols,lchnk) + call outfld('NNAT_2 ',nnat_2 ,pcols,lchnk) + !=0 call outfld('NNAT_3 ',nnat_3 ,pcols,lchnk) + call outfld('NNAT_4 ',nnat_4 ,pcols,lchnk) + call outfld('NNAT_5 ',nnat_5 ,pcols,lchnk) + call outfld('NNAT_6 ',nnat_6 ,pcols,lchnk) + call outfld('NNAT_7 ',nnat_7 ,pcols,lchnk) + call outfld('NNAT_8 ',nnat_8 ,pcols,lchnk) + call outfld('NNAT_9 ',nnat_9 ,pcols,lchnk) + call outfld('NNAT_10 ',nnat_10,pcols,lchnk) + !=0 call outfld('NNAT_11 ',nnat_11,pcols,lchnk) + call outfld('NNAT_12 ',nnat_12,pcols,lchnk) + !=0 call outfld('NNAT_13 ',nnat_13,pcols,lchnk) + call outfld('NNAT_14 ',nnat_14,pcols,lchnk) + !akc6 call outfld('AIRMASSL',airmassl,pcols,lchnk) + call outfld('AIRMASSL',airmassl,pcols,lchnk) + call outfld('AIRMASS ',airmass,pcols,lchnk) !akc6 + + !c_er3d + ! effective dry radii (um) in each layer + ! call outfld('ERLT053D',erlt053d,pcols,lchnk) + ! call outfld('ERGT053D',ergt053d,pcols,lchnk) + ! call outfld('ER3D ',er3d ,pcols,lchnk) + !c_er3d + ! column integrated effective dry radii (um) + call outfld('DERLT05 ',derlt05,pcols,lchnk) + call outfld('DERGT05 ',dergt05,pcols,lchnk) + call outfld('DER ',der ,pcols,lchnk) + ! + ! Extra AeroCom diagnostics requiring table look-ups with RH = constant + +#ifdef AEROCOM_INSITU + irfmax=6 +#else + irfmax=1 +#endif ! AEROCOM_INSITU + + ! Note: using xrhnull etc as proxy for constant RH input values (see opttab.F90) + do irf=1,irfmax + do k=1,pver + do icol=1,ncol + xrhnull(icol,k)=xrhrf(irf) + irh1null(icol,k)=irhrf1(irf) + end do + enddo + call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrhnull, irh1null, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) + end do ! irf + + end subroutine aerocom + + subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & + xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & + xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & + xfombg, ifombg1, vnbc, vaitbc, v_soana) + + ! Extra AeroCom diagnostics requiring table look-ups with constant/fixed RH, + ! i.e. for RH = (/"00","40","55","65","75","85" /) (see opttab.F90) + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_history, only: outfld + use constituents, only: pcnst + use opttab + use const + use aerosoldef + use commondefinitions + use physics_types, only: physics_state + use aeroopt_mod, only : extinction_coeffs, extinction_coeffsn + + implicit none + ! + ! Input arguments + ! + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) + real(r8), intent(in) :: rhoda(pcols,pver) ! Density of dry air (kg/m^3) + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration + real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) + integer, intent(in) :: irh1(pcols,pver) + integer, intent(in) :: irf + real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. + integer, intent(in) :: ict1(pcols,pver,nmodes) + real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations + integer, intent(in) :: ifaq1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbcbg(pcols,pver) + integer, intent(in) :: ifbcbg1(pcols,pver) + real(r8), intent(in) :: xfbcbgn(pcols,pver) + integer, intent(in) :: ifbcbgn1(pcols,pver) + real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! facm for use in the interpolations + integer, intent(in) :: ifac1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations + integer, intent(in) :: ifbc1(pcols,pver,nbmodes) + real(r8), intent(in) :: xfombg(pcols,pver) + integer, intent(in) :: ifombg1(pcols,pver) + real(r8), intent(in) :: vnbc(pcols,pver) + real(r8), intent(in) :: vaitbc(pcols,pver) + real(r8), intent(in) :: v_soana(pcols,pver) + ! + ! Local variables + ! + integer :: i, k, icol, mplus10, irh + integer :: iloop + real(r8) :: deltah + real(r8) :: dod550rh(pcols), abs550rh(pcols) + real(r8) :: ec550rh_aer(pcols,pver) + real(r8) :: abs550rh_aer(pcols,pver) + real(r8) :: bebglt1t(pcols,pver) + real(r8) :: bebclt1t(pcols,pver) + real(r8) :: beoclt1t(pcols,pver) + real(r8) :: bes4lt1t(pcols,pver) + real(r8) :: basu550tot(pcols,pver) + real(r8) :: babc550tot(pcols,pver) + real(r8) :: baoc550tot(pcols,pver) + real(r8) :: babc550xt(pcols,pver) + real(r8) :: baoc550xt(pcols,pver) + real(r8) :: ba550x(pcols,pver,nbmp1:nmodes) + real(r8) :: belt1x(pcols,pver,nbmp1:nmodes) + + ! Additionl AeroCom Phase III output: + real(r8) :: ec440rh_aer(pcols,pver) + real(r8) :: abs440rh_aer(pcols,pver) + real(r8) :: ec870rh_aer(pcols,pver) + real(r8) :: abs870rh_aer(pcols,pver) + real(r8) :: be550lt1_aer(pcols,pver,0:nbmodes) + real(r8) :: ec550rhlt1_aer(pcols,pver) + real(r8) :: abs550rh_bc(pcols,pver) + real(r8) :: abs550rh_oc(pcols,pver) + real(r8) :: abs550rh_su(pcols,pver) + real(r8) :: abs550rh_ss(pcols,pver) + real(r8) :: abs550rh_du(pcols,pver) + real(r8) :: ec550rhlt1_bc(pcols,pver) + real(r8) :: ec550rhlt1_oc(pcols,pver) + real(r8) :: ec550rhlt1_su(pcols,pver) + real(r8) :: ec550rhlt1_ss(pcols,pver) + real(r8) :: ec550rhlt1_du(pcols,pver) + real(r8) :: bedustlt1(pcols,pver) + real(r8) :: bedustgt1(pcols,pver) + real(r8) :: besslt1(pcols,pver) + real(r8) :: bessgt1(pcols,pver) + real(r8) :: bbclt1xt(pcols,pver) + real(r8) :: boclt1xt(pcols,pver) + real(r8) :: bocgt1xt(pcols,pver) + + character(len=10) :: modeString + character(len=20) :: varname + !-------------------------------------------------- + + belt1x(:,:,:) = 0._r8 + + do iloop=1,1 + + ! BC(ax) mode (hydrophobic, so no rhum needed here): + call extinction_coeffs%intaeropt0(lchnk, ncol, Nnatk) + + ! SO4(Ait), BC(Ait) and OC(Ait) modes: + mplus10=0 + call extinction_coeffs%intaeropt1(lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) + + mplus10=0 + call extinction_coeffs%intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1) + + ! BC&OC(Ait) (4), OC&BC(Ait) mode + mplus10=0 + call extinction_coeffs%intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1) + + ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: + call extinction_coeffs%intaeropt5to10(lchnk, ncol, xrh, irh1, Nnatk, & + xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) + + ! then to the externally mixed SO4(n), BC(n) and OC(n) modes: + mplus10=1 + call extinction_coeffsn%intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & + Nnatk, xct, ict1, xfac, ifac1) + + ! and finally the BC&OC(n) mode: + mplus10=1 + call extinction_coeffsn%intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & + xfbcbgn, ifbcbgn1, xct, ict1, xfac, ifac1, xfaq, ifaq1) + + end do ! iloop + + + ! Initialization + do k=1,pver + do icol=1,ncol + ec550rh_aer(icol,k) = 0.0_r8 + abs550rh_aer(icol,k) = 0.0_r8 + ec550rhlt1_aer(icol,k) = 0.0_r8 + abs550rh_bc(icol,k) = 0.0_r8 + abs550rh_oc(icol,k) = 0.0_r8 + abs550rh_su(icol,k) = 0.0_r8 + abs550rh_ss(icol,k) = 0.0_r8 + abs550rh_du(icol,k) = 0.0_r8 + ec440rh_aer(icol,k) = 0.0_r8 + abs440rh_aer(icol,k) = 0.0_r8 + ec870rh_aer(icol,k) = 0.0_r8 + abs870rh_aer(icol,k) = 0.0_r8 + basu550tot(icol,k) = 0.0_r8 + babc550tot(icol,k) = 0.0_r8 + baoc550tot(icol,k) = 0.0_r8 + bebglt1t(icol,k) = 0.0_r8 + bebclt1t(icol,k) = 0.0_r8 + beoclt1t(icol,k) = 0.0_r8 + bes4lt1t(icol,k) = 0.0_r8 + bedustlt1(icol,k) = 0.0_r8 + besslt1(icol,k) = 0.0_r8 + end do + end do + do icol=1,ncol + dod550rh(icol) = 0.0_r8 + abs550rh(icol) = 0.0_r8 + end do + + ! Calculation of extinction at given RH and absorption for all r and for r<0.5um + do k=1,pver + do icol=1,ncol + + do i=0,10 + ec550rh_aer(icol,k) = ec550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext550(icol,k,i) + abs550rh_aer(icol,k) = abs550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i) + ec440rh_aer(icol,k) = ec440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext440(icol,k,i) + abs440rh_aer(icol,k) = abs440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i) + ec870rh_aer(icol,k) = ec870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext870(icol,k,i) + abs870rh_aer(icol,k) = abs870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i) + basu550tot(icol,k) = basu550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%basu550(icol,k,i) + babc550tot(icol,k) = babc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babc550(icol,k,i) + baoc550tot(icol,k) = baoc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%baoc550(icol,k,i) + bes4lt1t(icol,k) = bes4lt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%besu550lt1(icol,k,i) + bebclt1t(icol,k) = bebclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebc550lt1(icol,k,i) + beoclt1t(icol,k) = beoclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%beoc550lt1(icol,k,i) + enddo + do i=11,14 + ec550rh_aer(icol,k) = ec550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext550(icol,k,i-10) + abs550rh_aer(icol,k) = abs550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs550(icol,k,i-10) + ec440rh_aer(icol,k) = ec440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext440(icol,k,i-10) + abs440rh_aer(icol,k) = abs440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs440(icol,k,i-10) + ec870rh_aer(icol,k) = ec870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext870(icol,k,i-10) + abs870rh_aer(icol,k) = abs870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs870(icol,k,i-10) + ba550x(icol,k,i) = extinction_coeffsn%babs550(icol,k,i-10) + belt1x(icol,k,i) = extinction_coeffs%bebg550lt1(icol,k,i-10) !??? + enddo + do i=6,7 + bedustlt1(icol,k) = bedustlt1(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebg550lt1(icol,k,i) + enddo + do i=8,10 + besslt1(icol,k) = besslt1(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebg550lt1(icol,k,i) + enddo + ec550rhlt1_du(icol,k) = bedustlt1(icol,k) + ec550rhlt1_ss(icol,k) = besslt1(icol,k) + + !soa: *(1-v_soan) for the sulfate volume fraction of mode 11 + bbclt1xt(icol,k) = Nnatk(icol,k,12)*belt1x(icol,k,12) & + + Nnatk(icol,k,14)*belt1x(icol,k,14)*vnbc(icol,k) + !soa + v_soan part of mode 11 for the OC volume fraction of that mode + boclt1xt(icol,k) = Nnatk(icol,k,13)*belt1x(icol,k,13) & + + Nnatk(icol,k,14)*belt1x(icol,k,14)*(1.0_r8-vnbc(icol,k)) + + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + ec550rhlt1_su(icol,k) = bes4lt1t(icol,k) & ! condensate + + Nnatk(icol,k,1)*extinction_coeffs%bebg550lt1(icol,k,1)*(1.0_r8-v_soana(icol,k))& ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%bebg550lt1(icol,k,5) ! background, SO4(Ait75) mode (5) + ec550rhlt1_bc(icol,k) = bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*extinction_coeffs%bebg550lt1(icol,k,2) & ! background, BC(Ait) mode (2) + + Nnatk(icol,k,4)*extinction_coeffs%bebg550lt1(icol,k,4)*vaitbc(icol,k) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%bebg550lt1(icol,k,0) ! background, BC(ax) mode (0) + + !soa + v_soan part of mode 11 for the OC volume fraction of that mode + ec550rhlt1_oc(icol,k) = beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC (13) + + Nnatk(icol,k,3)*extinction_coeffs%bebg550lt1(icol,k,3) & ! background, OC(Ait) mode (3) + + Nnatk(icol,k,4)*extinction_coeffs%bebg550lt1(icol,k,4)*(1.0_r8-vaitbc(icol,k))& ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,1)*extinction_coeffs%bebg550lt1(icol,k,1)*v_soana(icol,k) + + ec550rhlt1_aer(icol,k) = ec550rhlt1_su(icol,k)+ec550rhlt1_bc(icol,k) & + + ec550rhlt1_oc(icol,k) + ec550rhlt1_ss(icol,k)+ec550rhlt1_du(icol,k) + ec550rhlt1_aer(icol,k) = 1.e-3_r8*ec550rhlt1_aer(icol,k) + + abs550rh_du(icol,k) = Nnatk(icol,k,6)*extinction_coeffs%babg550(icol,k,6) & + + Nnatk(icol,k,7)*extinction_coeffs%babg550(icol,k,7) + abs550rh_ss(icol,k) = Nnatk(icol,k,8)*extinction_coeffs%babg550(icol,k,8) & + + Nnatk(icol,k,9)*extinction_coeffs%babg550(icol,k,9) & + + Nnatk(icol,k,10)*extinction_coeffs%babg550(icol,k,10) + + !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 + abs550rh_su(icol,k) = basu550tot(icol,k) & ! condensate:w + + (1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! background, SO4(Ait) mode (1) + + Nnatk(icol,k,5)*extinction_coeffs%babg550(icol,k,5) ! background, SO4(Ait75) mode (5) + + !soa: *(1-v_soan) for the sulfate volume fraction + babc550xt(icol,k) = Nnatk(icol,k,12)*ba550x(icol,k,12) & + + Nnatk(icol,k,14)*ba550x(icol,k,14)*vnbc(icol,k) + + baoc550xt(icol,k) = Nnatk(icol,k,13)*ba550x(icol,k,13) & + + Nnatk(icol,k,14)*ba550x(icol,k,14)*(1.0_r8-vnbc(icol,k)) + + abs550rh_bc(icol,k) = babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) + + Nnatk(icol,k,2)*extinction_coeffs%babg550(icol,k,2) & ! background, BC(Ait) mode (2) + + vaitbc(icol,k)*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) + + Nnatk(icol,k,0)*extinction_coeffs%babg550(icol,k,0) ! background, BC(ax) mode (0) + + abs550rh_oc(icol,k) = baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC (13) + + v_soana(icol,k)*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! SOA fraction of mode 1 + + Nnatk(icol,k,3)*extinction_coeffs%babg550(icol,k,3) & ! background, OC(Ait) mode (3) + + (1.0_r8-vaitbc(icol,k))*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) ! background in OC&BC(Ait) mode (4) + + deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) + dod550rh(icol) = dod550rh(icol)+ec550rh_aer(icol,k)*deltah + abs550rh(icol) = abs550rh(icol)+abs550rh_aer(icol,k)*deltah + + ec550rh_aer(icol,k) = 1.e-3_r8*ec550rh_aer(icol,k) + abs550rh_aer(icol,k) = 1.e-3_r8*abs550rh_aer(icol,k) + ec440rh_aer(icol,k) = 1.e-3_r8*ec440rh_aer(icol,k) + abs440rh_aer(icol,k) = 1.e-3_r8*abs440rh_aer(icol,k) + ec870rh_aer(icol,k) = 1.e-3_r8*ec870rh_aer(icol,k) + abs870rh_aer(icol,k) = 1.e-3_r8*abs870rh_aer(icol,k) + + abs550rh_bc(icol,k) = 1.e-3_r8*abs550rh_bc(icol,k) + abs550rh_oc(icol,k) = 1.e-3_r8*abs550rh_oc(icol,k) + abs550rh_su(icol,k) = 1.e-3_r8*abs550rh_su(icol,k) + abs550rh_ss(icol,k) = 1.e-3_r8*abs550rh_ss(icol,k) + abs550rh_du(icol,k) = 1.e-3_r8*abs550rh_du(icol,k) + + enddo + enddo + + if(irf.eq.1) then + + call outfld('ECDRYAER',ec550rh_aer,pcols,lchnk) + call outfld('ABSDRYAE',abs550rh_aer,pcols,lchnk) + call outfld('OD550DRY',dod550rh,pcols,lchnk) ! 2D variable + call outfld('AB550DRY',abs550rh,pcols,lchnk) ! 2D variable + call outfld('ECDRY440',ec440rh_aer,pcols,lchnk) + call outfld('ABSDR440',abs440rh_aer,pcols,lchnk) + call outfld('ECDRY870',ec870rh_aer,pcols,lchnk) + call outfld('ABSDR870',abs870rh_aer,pcols,lchnk) + call outfld('ECDRYLT1',ec550rhlt1_aer,pcols,lchnk) + ! Since we do not have enough look-up table info to take abs550rhlt1_aer, + ! instead take out abs550rh for each constituent: + call outfld('ABSDRYBC',abs550rh_bc,pcols,lchnk) + call outfld('ABSDRYOC',abs550rh_oc,pcols,lchnk) + call outfld('ABSDRYSU',abs550rh_su,pcols,lchnk) + call outfld('ABSDRYSS',abs550rh_ss,pcols,lchnk) + call outfld('ABSDRYDU',abs550rh_du,pcols,lchnk) + + elseif(irf.ge.2) then ! only happens for AEROCOM_INSITU + + irh=RF(irf) + + modeString=" " + write(modeString,"(I2)"),irh + if(RF(irf).eq.0) modeString="00" + varName = "EC55RH"//trim(modeString) + call outfld(varName,ec550rh_aer(:,:),pcols,lchnk) + varName = "AB55RH"//trim(modeString) + call outfld(varName,abs550rh_aer(:,:),pcols,lchnk) + + end if ! irf + + end subroutine opticsAtConstRh + + subroutine intfrh (lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relh, frh) + + ! Written by Alf Kirkevaag in November 2011, based on interpol1to3 in optinterpol.F90 + ! called by NorESM/physpkg + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use opttab, only: rh + use commondefinitions, only: nmodes + + implicit none + ! + ! Input arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric columns + real(r8), intent(in) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate + real(r8), intent(in) :: v3insol(pcols,pver,nmodes) ! Modal mass fraction of BC and dust + real(r8), intent(in) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) + real(r8), intent(in) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt + real(r8), intent(in) :: relh(pcols,pver) ! Ambient relatve humidity (fraction) + ! + ! Output arguments + real(r8), intent(out) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor + ! + ! Local variables + integer :: i, ierr, irelh, kcomp, k, icol + integer :: irh1(pcols,pver), irh2(pcols,pver) + real(r8) :: a, b, e, fso4, finsol, foc, fss + real(r8) :: xrh(pcols,pver) + integer :: t_irh1, t_irh2 + real(r8) :: t_xrh, t_rh1, t_rh2 + parameter (e=2.718281828) + + ! Relative humidity intries from opttab.F90: + ! rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, & + ! 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) + ! Humidity growth factors which are consistent with the aerosol optics look-up tables: + real(r8), dimension(10) :: fh_SO4 = & + (/ 1.00_r8, 1.34_r8, 1.40_r8, 1.53_r8, 1.64_r8, & + 1.71_r8, 1.81_r8, 1.98_r8, 2.39_r8, 5.04_r8 /) + real(r8), dimension(10) :: fh_insol = & + (/ 1.00_r8, 1.01_r8, 1.01_r8, 1.02_r8, 1.02_r8, & + 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8 /) + real(r8), dimension(10) :: fh_OC = & + (/ 1.00_r8, 1.02_r8, 1.05_r8, 1.14_r8, 1.19_r8, & + 1.22_r8, 1.27_r8, 1.36_r8, 1.59_r8, 3.18_r8 /) + real(r8), dimension(10) :: fh_SS = & + (/ 1.00_r8, 1.01_r8, 1.02_r8, 1.56_r8, 1.87_r8, & + 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 6.08_r8 /) + ! ----------------------------------------- + + ! write(*,*) 'Before xrh-loop' + do k=1,pver + do icol=1,ncol + !test xrh(icol,k) = 0.8 + xrh(icol,k) = min(max(relh(icol,k),rh(1)),rh(10)) + end do + end do + + ! write(*,*) 'Before rh-loop' + do irelh=1,9 + do k=1,pver + do icol=1,ncol + if(xrh(icol,k) >= rh(irelh).and. & + xrh(icol,k)<=rh(irelh+1)) then + irh1(icol,k)=irelh + irh2(icol,k)=irelh+1 + endif + end do + end do + end do + + ! Loop over all relevant modes (kcomp=1,2,4-11,13,14) + ! (mode 3 is no longer included, and 12 is insoluble) + + do kcomp=1,14 + + do icol=1,ncol + do k=1,pver + frh(icol,k,kcomp)=0.0_r8 + end do + end do + + if(kcomp.ne.3.and.kcomp.ne.12) then + + do k=1,pver + do icol=1,ncol + + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing + + t_irh1 = irh1(icol,k) + t_irh2 = irh2(icol,k) + + ! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 + + t_rh1 = rh(t_irh1) + t_rh2 = rh(t_irh2) + + t_xrh = xrh(icol,k) + + if(t_xrh <= 0.37) then ! linear averaging w.r.t. small RH: + fso4 = ((t_rh2-t_xrh)*fh_SO4(t_irh1)+(t_xrh-t_rh1)*fh_SO4(t_irh2)) /(t_rh2-t_rh1) + finsol= ((t_rh2-t_xrh)*fh_insol(t_irh1)+(t_xrh-t_rh1)*fh_insol(t_irh2)) /(t_rh2-t_rh1) + foc = ((t_rh2-t_xrh)*fh_OC(t_irh1)+(t_xrh-t_rh1)*fh_OC(t_irh2)) /(t_rh2-t_rh1) + fss = ((t_rh2-t_xrh)*fh_SS(t_irh1)+(t_xrh-t_rh1)*fh_SS(t_irh2)) /(t_rh2-t_rh1) + else ! exponential averaging w.r.t. large RH: + a = (log(fh_SO4(t_irh2))-log(fh_SO4(t_irh1)))/(t_rh2-t_rh1) + b = (t_rh2*log(fh_SO4(t_irh1))-t_rh1*log(fh_SO4(t_irh2)))/(t_rh2-t_rh1) + fso4 = e**(a*t_xrh+b) + a = (log(fh_insol(t_irh2))-log(fh_insol(t_irh1)))/(t_rh2-t_rh1) + b = (t_rh2*log(fh_insol(t_irh1))-t_rh1*log(fh_insol(t_irh2)))/(t_rh2-t_rh1) + finsol = e**(a*t_xrh+b) + a = (log(fh_OC(t_irh2))-log(fh_OC(t_irh1)))/(t_rh2-t_rh1) + b = (t_rh2*log(fh_OC(t_irh1))-t_rh1*log(fh_OC(t_irh2)))/(t_rh2-t_rh1) + foc = e**(a*t_xrh+b) + a = (log(fh_SS(t_irh2))-log(fh_SS(t_irh1)))/(t_rh2-t_rh1) + b = (t_rh2*log(fh_SS(t_irh1))-t_rh1*log(fh_SS(t_irh2)))/(t_rh2-t_rh1) + fss = e**(a*t_xrh+b) + endif + + ! linear interpolation w.r.t. mass fractions of each internally mixed component + ! (this assumption is only used here, while the full Koehler equation are solved + ! for the look-up tables for log-normal size distributions and aerosol optics): + + frh(icol,k,kcomp) = v3so4(icol,k,kcomp)*fso4 + v3insol(icol,k,kcomp)*finsol & + + v3oc(icol,k,kcomp) *foc + v3ss(icol,k,kcomp)*fss + + ! write(*,*) 'frh =', frh(icol,k,kcomp) + end do ! icol + end do ! k + endif ! kcomp.ne.3.and.kcomp.ne.12 + end do ! kcomp + + end subroutine intfrh + +#endif + +end module aerocom_mod diff --git a/src/physics/cam_oslo/aeroopt_mod.F90 b/src/physics/cam_oslo/aerocom_opt_mod.F90 similarity index 99% rename from src/physics/cam_oslo/aeroopt_mod.F90 rename to src/physics/cam_oslo/aerocom_opt_mod.F90 index 5b703ab375..986e81bc7e 100644 --- a/src/physics/cam_oslo/aeroopt_mod.F90 +++ b/src/physics/cam_oslo/aerocom_opt_mod.F90 @@ -1,4 +1,6 @@ -module aeroopt_mod +module aerocom_opt_mod + +#ifdef AEROCOM use shr_kind_mod , only : r8 => shr_kind_r8 use ppgrid , only : pcols, pver @@ -1273,4 +1275,21 @@ subroutine update(this, icol, k, kcomp, opt) +this%beoc550(icol,k,kcomp) + this%besu550(icol,k,kcomp) end subroutine update -end module aeroopt_mod + subroutine checkTableHeader (ifil) + ! Read the header-text in a look-up table (in file with iu=ifil). + + integer, intent(in) :: ifil + character*80 :: headertext + character*12 :: text0, text1 + + text0='X-CHECK LUT' + text1='none ' + do while (text1(2:12) .ne. text0(2:12)) + read(ifil,'(A)') headertext + text1 = headertext(2:12) + enddo + end subroutine checkTableHeader + +#endif + +end module aerocom_opt_mod diff --git a/src/physics/cam_oslo/checkTableHeader.F90 b/src/physics/cam_oslo/checkTableHeader.F90 deleted file mode 100644 index 20a8f3615a..0000000000 --- a/src/physics/cam_oslo/checkTableHeader.F90 +++ /dev/null @@ -1,25 +0,0 @@ - - subroutine checkTableHeader (ifil) - -! This subroutine reads the header-text in a look-up table (in file with iu=ifil). -! Later: use it to also check AeroTab - CAM5-Oslo consistency w.r.t. assumed modal -! radii, mass densities, etc... - - integer, intent(in) :: ifil - character*80 headertext - character*12 text0, text1 - - - text0='X-CHECK LUT' - text1='none ' - do while (text1(2:12).ne.text0(2:12)) - read(ifil,1000) headertext - text1=headertext(2:12) -! write(*,*) 'text0, text1 =', text0, text1 - enddo - - - 1000 format(A) - - return - end subroutine checkTableHeader \ No newline at end of file diff --git a/src/physics/cam_oslo/intfrh_mod.F90 b/src/physics/cam_oslo/intfrh_mod.F90 deleted file mode 100644 index 951b062339..0000000000 --- a/src/physics/cam_oslo/intfrh_mod.F90 +++ /dev/null @@ -1,140 +0,0 @@ -module intfrh_mod - -contains - - subroutine intfrh (lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relh, frh) - - ! Written by Alf Kirkevaag in November 2011, based on interpol1to3 in optinterpol.F90 - ! called by NorESM/physpkg - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: rh - use commondefinitions, only: nmodes - - implicit none - ! - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate - real(r8), intent(in) :: v3insol(pcols,pver,nmodes) ! Modal mass fraction of BC and dust - real(r8), intent(in) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) - real(r8), intent(in) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt - real(r8), intent(in) :: relh(pcols,pver) ! Ambient relatve humidity (fraction) - ! - ! Output arguments - real(r8), intent(out) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor - ! - ! Local variables - integer :: i, ierr, irelh, kcomp, k, icol - integer :: irh1(pcols,pver), irh2(pcols,pver) - real(r8) :: a, b, e, fso4, finsol, foc, fss - real(r8) :: xrh(pcols,pver) - integer :: t_irh1, t_irh2 - real(r8) :: t_xrh, t_rh1, t_rh2 - parameter (e=2.718281828) - - ! Relative humidity intries from opttab.F90: - ! rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, & - ! 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) - ! Humidity growth factors which are consistent with the aerosol optics look-up tables: - real(r8), dimension(10) :: fh_SO4 = & - (/ 1.00_r8, 1.34_r8, 1.40_r8, 1.53_r8, 1.64_r8, & - 1.71_r8, 1.81_r8, 1.98_r8, 2.39_r8, 5.04_r8 /) - real(r8), dimension(10) :: fh_insol = & - (/ 1.00_r8, 1.01_r8, 1.01_r8, 1.02_r8, 1.02_r8, & - 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8 /) - real(r8), dimension(10) :: fh_OC = & - (/ 1.00_r8, 1.02_r8, 1.05_r8, 1.14_r8, 1.19_r8, & - 1.22_r8, 1.27_r8, 1.36_r8, 1.59_r8, 3.18_r8 /) - real(r8), dimension(10) :: fh_SS = & - (/ 1.00_r8, 1.01_r8, 1.02_r8, 1.56_r8, 1.87_r8, & - 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 6.08_r8 /) - ! ----------------------------------------- - - ! write(*,*) 'Before xrh-loop' - do k=1,pver - do icol=1,ncol - !test xrh(icol,k) = 0.8 - xrh(icol,k) = min(max(relh(icol,k),rh(1)),rh(10)) - end do - end do - - ! write(*,*) 'Before rh-loop' - do irelh=1,9 - do k=1,pver - do icol=1,ncol - if(xrh(icol,k) >= rh(irelh).and. & - xrh(icol,k)<=rh(irelh+1)) then - irh1(icol,k)=irelh - irh2(icol,k)=irelh+1 - endif - end do - end do - end do - - ! Loop over all relevant modes (kcomp=1,2,4-11,13,14) - ! (mode 3 is no longer included, and 12 is insoluble) - - do kcomp=1,14 - - do icol=1,ncol - do k=1,pver - frh(icol,k,kcomp)=0.0_r8 - end do - end do - - if(kcomp.ne.3.and.kcomp.ne.12) then - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = irh2(icol,k) - - ! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - - t_xrh = xrh(icol,k) - - if(t_xrh <= 0.37) then ! linear averaging w.r.t. small RH: - fso4 = ((t_rh2-t_xrh)*fh_SO4(t_irh1)+(t_xrh-t_rh1)*fh_SO4(t_irh2)) /(t_rh2-t_rh1) - finsol= ((t_rh2-t_xrh)*fh_insol(t_irh1)+(t_xrh-t_rh1)*fh_insol(t_irh2)) /(t_rh2-t_rh1) - foc = ((t_rh2-t_xrh)*fh_OC(t_irh1)+(t_xrh-t_rh1)*fh_OC(t_irh2)) /(t_rh2-t_rh1) - fss = ((t_rh2-t_xrh)*fh_SS(t_irh1)+(t_xrh-t_rh1)*fh_SS(t_irh2)) /(t_rh2-t_rh1) - else ! exponential averaging w.r.t. large RH: - a = (log(fh_SO4(t_irh2))-log(fh_SO4(t_irh1)))/(t_rh2-t_rh1) - b = (t_rh2*log(fh_SO4(t_irh1))-t_rh1*log(fh_SO4(t_irh2)))/(t_rh2-t_rh1) - fso4 = e**(a*t_xrh+b) - a = (log(fh_insol(t_irh2))-log(fh_insol(t_irh1)))/(t_rh2-t_rh1) - b = (t_rh2*log(fh_insol(t_irh1))-t_rh1*log(fh_insol(t_irh2)))/(t_rh2-t_rh1) - finsol = e**(a*t_xrh+b) - a = (log(fh_OC(t_irh2))-log(fh_OC(t_irh1)))/(t_rh2-t_rh1) - b = (t_rh2*log(fh_OC(t_irh1))-t_rh1*log(fh_OC(t_irh2)))/(t_rh2-t_rh1) - foc = e**(a*t_xrh+b) - a = (log(fh_SS(t_irh2))-log(fh_SS(t_irh1)))/(t_rh2-t_rh1) - b = (t_rh2*log(fh_SS(t_irh1))-t_rh1*log(fh_SS(t_irh2)))/(t_rh2-t_rh1) - fss = e**(a*t_xrh+b) - endif - - ! linear interpolation w.r.t. mass fractions of each internally mixed component - ! (this assumption is only used here, while the full Koehler equation are solved - ! for the look-up tables for log-normal size distributions and aerosol optics): - - frh(icol,k,kcomp) = v3so4(icol,k,kcomp)*fso4 + v3insol(icol,k,kcomp)*finsol & - + v3oc(icol,k,kcomp) *foc + v3ss(icol,k,kcomp)*fss - - ! write(*,*) 'frh =', frh(icol,k,kcomp) - end do ! icol - end do ! k - endif ! kcomp.ne.3.and.kcomp.ne.12 - end do ! kcomp - - end subroutine intfrh -end module intfrh_mod diff --git a/src/physics/cam_oslo/opttab.F90 b/src/physics/cam_oslo/opttab.F90 index 3b588cf978..8f5eb85bc8 100644 --- a/src/physics/cam_oslo/opttab.F90 +++ b/src/physics/cam_oslo/opttab.F90 @@ -1,7 +1,7 @@ module opttab - ! Purpose: To read in SW look-up tables for calculation of aerosol optical properties, - ! and to define the grid for discrete input-values in these look-up tables. + ! Purpose: To read in SW look-up tables for calculation of aerosol optical properties, + ! and to define the grid for discrete input-values in these look-up tables. ! Purpose: To interpolate between look-up table entries for SW optical aerosol properties. ! Optimized for speed by Arild Burud and Egil Storen (NoSerC), June-July 2002 @@ -13,13 +13,13 @@ module opttab ! Modified for new wavelength bands and look-up tables - Alf Kirkevaag Dec. 2013. ! Updated for reading input files with extra header info - Alf Kirkevaag, May 2015. ! Extended for new SOA treatment - Alf Kirkevaag, August 2015. - ! Added output (ASCII) Jabuary 2016: #ifdef COLTST4INTCONS -> extinction - ! koefficients (wrt. all added mass including condensed water vapour) are - ! written out for checking against the look-up tables (using xmgrace), e.g. + ! Added output (ASCII) Jabuary 2016: #ifdef COLTST4INTCONS -> extinction + ! koefficients (wrt. all added mass including condensed water vapour) are + ! written out for checking against the look-up tables (using xmgrace), e.g. ! as function of RH (to be changed to whatever parameter the user is interested in) - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - ! Modified cate values for kcomp=2 (as in AeroTab) - Alf Kirkevaag October 2016. + ! Modified for optimized added masses and mass fractions for concentrations from + ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. + ! Modified cate values for kcomp=2 (as in AeroTab) - Alf Kirkevaag October 2016. use shr_kind_mod , only: r8 => shr_kind_r8 use ppgrid , only: pcols, pver @@ -30,7 +30,7 @@ module opttab implicit none - private + private ! Interfaces public :: initopt @@ -75,19 +75,19 @@ module opttab real(r8), public :: be5to10(nbands,10,6,6,6,6,5:10) real(r8), public :: ke5to10(nbands,10,6,6,6,6,5:10) - ! relative humidity (RH, as integer for output variable names) for use in AeroCom code + ! relative humidity (RH, as integer for output variable names) for use in AeroCom code integer, public, dimension(6) :: RF = (/0, 40, 55, 65, 75, 85 /) - ! AeroCom specific RH input variables for use in opticsAtConstRh.F90 + ! AeroCom specific RH input variables for use in opticsAtConstRh.F90 integer , public :: irhrf1(6) real(r8), public :: xrhrf(6) real(r8), public :: e, eps parameter (e=2.718281828_r8, eps=1.0e-30_r8) - ! Array bounds in the tabulated optical parameters + ! Array bounds in the tabulated optical parameters integer, public, parameter :: nlwbands=16 ! number of aerosol spectral bands in LW - + real(r8), public :: ka0(nlwbands) real(r8), public :: ka1(nlwbands,10,6,16,6) real(r8), public :: ka2to3(nlwbands,10,16,6,2:3) @@ -102,10 +102,10 @@ subroutine initopt() ! Modified by Egil Storen/NoSerC July 2002. ! The sequence of the indices in arrays om1, g1, be1 and ke1 ! (common block /tab1/) has been rearranged to avoid cache - ! problems while running subroutine interpol1. Files also + ! problems while running subroutine interpol1. Files also ! involved by this modification: interpol1.F and opttab.h. - ! Modified for new aerosol schemes by Alf Kirkevaag in January - ! 2006. Modified for new wavelength bands and look-up tables + ! Modified for new aerosol schemes by Alf Kirkevaag in January + ! 2006. Modified for new wavelength bands and look-up tables ! by Alf Kirkevaag in December 2013, and for SOA in August 2015. !--------------------------------------------------------------- @@ -124,30 +124,30 @@ subroutine initopt() character(len=dir_string_length) :: aerotab_table_dir !----------------------------------------------------------- - ! Defining array bounds for tabulated optical parameters (and r and sigma) + ! Defining array bounds for tabulated optical parameters (and r and sigma) ! relative humidity (only 0 value used for r and sigma tables): rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) - ! AeroCom specific RH input variables for use in opticsAtConstRh.F90 + ! AeroCom specific RH input variables for use in opticsAtConstRh.F90 do irf=1,6 xrhrf(irf) = real(RF(irf))*0.01_r8 enddo do irelh=1,9 do irf=1,6 if(xrhrf(irf)>=rh(irelh).and.xrhrf(irf)<=rh(irelh+1)) then - irhrf1(irf)=irelh + irhrf1(irf)=irelh endif end do end do - ! mass fractions internal mixtures in background (fombg and fbcbg) and mass added to the + ! mass fractions internal mixtures in background (fombg and fbcbg) and mass added to the ! background modes (fac, faq, faq) fombg = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) fac = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) faq = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) - ! with more weight on low fractions (thus a logaritmic f axis) for BC, - ! which is less ambundant than sulfate and OC, and the first value + ! with more weight on low fractions (thus a logaritmic f axis) for BC, + ! which is less ambundant than sulfate and OC, and the first value ! corresponding to a clean background mode: fbcbg(1)=1.e-10_r8 fbc(1)=1.e-10_r8 @@ -155,7 +155,7 @@ subroutine initopt() fbcbg(i)=10**((i-1)/4.0_r8-1.25_r8) fbc(i)=fbcbg(i) end do - ! and most weight on small concentrations for added mass onto the background: + ! and most weight on small concentrations for added mass onto the background: do kcomp=1,4 cate(kcomp,1)=1.e-10_r8 do i=2,16 @@ -220,7 +220,7 @@ subroutine initopt() linmax=nbands do lin = 1,linmax read(39+ifil,'(2I3,f8.3,4(x,e12.5))') kcomp, iwl, relh, ssa, ass, ext, spext - om0(iwl)=ssa + om0(iwl)=ssa g0 (iwl)=ass be0(iwl)=ext ! unit km^-1 ke0(iwl)=spext ! unit m^2/g @@ -238,7 +238,7 @@ subroutine initopt() endif enddo - write(iulog,*)'mode 0 ok' + write(iulog,*)'mode 0 ok' !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc @@ -246,7 +246,7 @@ subroutine initopt() !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc linmax = nbands*10*6*16*6 ! 14*10*6*16*6 - do lin = 1,linmax + do lin = 1,linmax read(40,'(2I3,f8.3,3(x,e10.3),4(x,e12.5))') kcomp, iwl, relh, frombg, catot, frac, ssa, ass, ext, spext @@ -275,7 +275,7 @@ subroutine initopt() endif end do - om1(iwl,irelh,ifombg,ictot,ifac)=ssa + om1(iwl,irelh,ifombg,ictot,ifac)=ssa g1 (iwl,irelh,ifombg,ictot,ifac)=ass be1(iwl,irelh,ifombg,ictot,ifac)=ext ! unit km^-1 ke1(iwl,irelh,ifombg,ictot,ifac)=spext ! unit m^2/g @@ -304,7 +304,7 @@ subroutine initopt() enddo enddo - write(iulog,*)'mode 1 ok' + write(iulog,*)'mode 1 ok' !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc ! Modes 2 to 3 (BC/OC + condensate from H2SO4 and SOA) @@ -334,7 +334,7 @@ subroutine initopt() endif end do - om2to3(iwl,irelh,ictot,ifac,kcomp)=ssa + om2to3(iwl,irelh,ictot,ifac,kcomp)=ssa g2to3 (iwl,irelh,ictot,ifac,kcomp)=ass be2to3(iwl,irelh,ictot,ifac,kcomp)=ext ! unit km^-1 ke2to3(iwl,irelh,ictot,ifac,kcomp)=spext ! unit m^2/g @@ -347,7 +347,7 @@ subroutine initopt() do irelh=1,10 do ictot=1,16 do ifac=1,6 - om2to3(iwl,irelh,ictot,ifac,kcomp)=0.999_r8 + om2to3(iwl,irelh,ictot,ifac,kcomp)=0.999_r8 g2to3 (iwl,irelh,ictot,ifac,kcomp)=0.5_r8 be2to3(iwl,irelh,ictot,ifac,kcomp)=0.0001_r8 ! unit km^-1 ke2to3(iwl,irelh,ictot,ifac,kcomp)=1.0_r8 ! unit m^2/g @@ -372,13 +372,13 @@ subroutine initopt() enddo enddo - write(iulog,*)'modes 2-3 ok' + write(iulog,*)'modes 2-3 ok' !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc ! Mode 4 (BC&OC + condensate from H2SO4 and SOA + wet phase (NH4)2SO4) !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - linmax = nbands*10*6*16*6*6 + linmax = nbands*10*6*16*6*6 do lin = 1,linmax read(43,'(2I3,f8.3,3(x,e10.3),f7.2,4(x,e12.5))') kcomp, iwl, relh, frbcbg, catot, frac, fraq, & ssa, ass, ext, spext @@ -414,7 +414,7 @@ subroutine initopt() endif end do - om4(iwl,irelh,ifbcbg,ictot,ifac,ifaq)=ssa + om4(iwl,irelh,ifbcbg,ictot,ifac,ifaq)=ssa g4 (iwl,irelh,ifbcbg,ictot,ifac,ifaq)=ass be4(iwl,irelh,ifbcbg,ictot,ifac,ifaq)=ext ! unit km^-1 ke4(iwl,irelh,ifbcbg,ictot,ifac,ifaq)=spext ! unit m^2/g @@ -445,7 +445,7 @@ subroutine initopt() enddo enddo - write(iulog,*)'mode 4 ok' + write(iulog,*)'mode 4 ok' !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.) @@ -453,7 +453,7 @@ subroutine initopt() linmax = nbands*10*6*6*6*6 ! 14*10*6*6*6*6 do ifil = 5,10 - do lin = 1,linmax + do lin = 1,linmax read(39+ifil,'(2I3,f8.3,3(x,e10.3),f7.2,4(x,e12.5))') & kcomp, iwl, relh, catot, frac, fabc, fraq, ssa, ass, ext, spext @@ -489,15 +489,15 @@ subroutine initopt() endif end do - om5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp)=ssa + om5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp)=ssa g5to10 (iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp)=ass be5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp)=ext ! unit km^-1 ke5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp)=spext ! unit m^2/g - ! write(iulog,*) 'kcomp, om =', kcomp, om5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) - ! write(iulog,*) 'kcomp, g =', kcomp, g5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) - ! write(iulog,*) 'kcomp, be =', kcomp, be5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) - ! write(iulog,*) 'kcomp, ke =', kcomp, ke5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) + ! write(iulog,*) 'kcomp, om =', kcomp, om5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) + ! write(iulog,*) 'kcomp, g =', kcomp, g5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) + ! write(iulog,*) 'kcomp, be =', kcomp, be5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) + ! write(iulog,*) 'kcomp, ke =', kcomp, ke5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) end do ! ifil end do ! lin @@ -521,7 +521,7 @@ subroutine initopt() enddo enddo - write(iulog,*)'modes 5-10 ok' + write(iulog,*)'modes 5-10 ok' do ifil=40,50 close (ifil) @@ -536,11 +536,11 @@ subroutine initopt_lw ! Modified by Egil Storen/NoSerC July 2002. ! The sequence of the indices in arrays om1, g1, be1 and ke1 ! (common block /tab1/) has been rearranged to avoid cache - ! problems while running subroutine interpol1. Files also + ! problems while running subroutine interpol1. Files also ! involved by this modification: interpol1.F and opttab.h. - ! Modified for new aerosol schemes by Alf Kirkevaag in January - ! 2006. Based on opttab.F90 and modified for new wavelength - ! bands and look-up tables by Alf Kirkevaag in January 2014, + ! Modified for new aerosol schemes by Alf Kirkevaag in January + ! 2006. Based on opttab.F90 and modified for new wavelength + ! bands and look-up tables by Alf Kirkevaag in January 2014, ! and for SOA in August 2015. !--------------------------------------------------------------- @@ -577,9 +577,9 @@ subroutine initopt_lw ,form="formatted",status="old") open(48,file=trim(aerotab_table_dir)//'/lwkcomp9.out' & ,form="formatted",status="old") - open(49,file=trim(aerotab_table_dir)//'/lwkcomp10.out'& + open(49,file=trim(aerotab_table_dir)//'/lwkcomp10.out'& ,form="formatted",status="old") - open(50,file=trim(aerotab_table_dir)//'/lwkcomp0.out'& + open(50,file=trim(aerotab_table_dir)//'/lwkcomp0.out'& ,form="formatted",status="old") ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) @@ -613,7 +613,7 @@ subroutine initopt_lw endif enddo - write(iulog,*)'lw mode 0 ok' + write(iulog,*)'lw mode 0 ok' !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc @@ -680,17 +680,17 @@ subroutine initopt_lw enddo enddo - write(iulog,*)'lw new mode 1 ok' + write(iulog,*)'lw new mode 1 ok' !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc ! Modes 2 to 3 (BC or OC + condensate from H2SO4 and SOA) !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - linmax = nlwbands*10*16*6 + linmax = nlwbands*10*16*6 ! do ifil = 2,3 do ifil = 2,2 - do lin = 1,linmax + do lin = 1,linmax read(39+ifil,994) kcomp, iwl, relh, catot, frac, spabs @@ -755,7 +755,7 @@ subroutine initopt_lw enddo enddo - write(iulog,*)'lw mode 2-3 ok' + write(iulog,*)'lw mode 2-3 ok' !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc @@ -763,7 +763,7 @@ subroutine initopt_lw !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc ifil = 4 - linmax = nlwbands*10*6*16*6*6 + linmax = nlwbands*10*6*16*6*6 do lin = 1,linmax read(39+ifil,995) kcomp, iwl, relh, frbcbg, catot, frac, fraq, spabs @@ -831,16 +831,16 @@ subroutine initopt_lw enddo enddo - write(iulog,*)'lw mode 4 ok' + write(iulog,*)'lw mode 4 ok' !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.) !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - linmax = nlwbands*10*6*6*6*6 + linmax = nlwbands*10*6*6*6*6 do ifil = 5,10 - do lin = 1,linmax + do lin = 1,linmax read(39+ifil,993) kcomp, iwl, relh, catot, frac, fabc, fraq, spabs @@ -888,7 +888,7 @@ subroutine initopt_lw ka5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp)=spabs ! unit m^2/g - ! write(*,*) 'kcomp, ka =', kcomp, ka5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) + ! write(*,*) 'kcomp, ka =', kcomp, ka5to10(iwl,irelh,ictot,ifac,ifbc,ifaq,kcomp) end do end do @@ -911,12 +911,12 @@ subroutine initopt_lw enddo enddo - write(iulog,*)'lw mode 5-10 ok' + write(iulog,*)'lw mode 5-10 ok' 993 format(2I3,f8.3,3(x,e10.3),f7.2,x,e12.5) ! 5-10 994 format(2I3,f8.3,2(x,e10.3),x,e12.5) ! 2-3 995 format(2I3,f8.3,3(x,e10.3),f7.2,x,e12.5) ! 4 -996 format(2I3,f8.3,x,e12.5) ! 0 +996 format(2I3,f8.3,x,e12.5) ! 0 997 format(2I3,f8.3,3(x,e10.3),x,e12.5) ! 1 do ifil=40,50 @@ -992,18 +992,18 @@ subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & do icol=1,ncol ! find common xfombg, ifombg1 and ifombg2 for use in the interpolation routines xfombg(icol,k) =min(max(f_soana(icol,k),fombg(1)),fombg(6)) - ifombg1(icol,k)=int(5.0_r8*xfombg(icol,k)-eps10)+1 ! Boer linkes til def. i opttab.F90 + ifombg1(icol,k)=int(5.0_r8*xfombg(icol,k)-eps10)+1 end do enddo do k=1,pver do icol=1,ncol ! find common xfbcbg, ifbcbg1 and ifbcbg2 for use in the interpolation routines - xfbcbg(icol,k) =min(max(faitbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 + xfbcbg(icol,k) =min(max(faitbc(icol,k),fbcbg(1)),fbcbg(6)) ifbcbg1(icol,k)=min(max(int(4*log10(xfbcbg(icol,k))+6),1),5) ! find common xfbcbgn, ifbcbgn1 and ifbcbgn2 for use in the interpolation routines - xfbcbgn(icol,k) =min(max(fnbc(icol,k),fbcbg(1)),fbcbg(6)) ! Boer linkes til def. i opttab.F90 + xfbcbgn(icol,k) =min(max(fnbc(icol,k),fbcbg(1)),fbcbg(6)) ifbcbgn1(icol,k)=min(max(int(4*log10(xfbcbgn(icol,k))+6),1),5) end do enddo @@ -1013,7 +1013,7 @@ subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & do icol=1,ncol ! find common xfac, ifac1 and ifac2 for use in the interpolation routines xfac(icol,k,i) =min(max(focm(icol,k,i),fac(1)),fac(6)) - ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 end do enddo enddo @@ -1022,7 +1022,7 @@ subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & do icol=1,ncol ! find common xfac, ifac1 and ifac2 for use in the interpolation routines xfac(icol,k,i) =min(max(fcm(icol,k,i),fac(1)),fac(6)) - ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 end do enddo enddo @@ -1031,7 +1031,7 @@ subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & do k=1,pver do icol=1,ncol ! find common xfbc, ifbc1 and ifbc2 for use in the interpolation routines - xfbc(icol,k,i) =min(max(fbcm(icol,k,i),fbc(1)),fbc(6)) ! Boer linkes til def. i opttab.F90 + xfbc(icol,k,i) =min(max(fbcm(icol,k,i),fbc(1)),fbc(6)) ifbc1(icol,k,i)=min(max(int(4*log10(xfbc(icol,k,i))+6),1),5) end do enddo @@ -1042,12 +1042,12 @@ subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & do icol=1,ncol ! find common xfaq, ifaq1 and ifaq2 for use in the interpolation routines xfaq(icol,k,i) =min(max(faqm(icol,k,i),faq(1)),faq(6)) - ifaq1(icol,k,i)=int(5.0_r8*xfaq(icol,k,i)-eps10)+1 ! Boer linkes til def. i opttab.F90 + ifaq1(icol,k,i)=int(5.0_r8*xfaq(icol,k,i)-eps10)+1 end do enddo enddo - ! find common xct, ict1 and ict2 for use in the interpolation routines ! Boer linkes til def. i opttab.F90 + ! find common xct, ict1 and ict2 for use in the interpolation routines do i=1,4 do k=1,pver do icol=1,ncol @@ -2769,5 +2769,20 @@ subroutine interpol5to10 (lchnk, ncol, daylight, xrh, irh1, Nnatk, xct, ict1, & end subroutine interpol5to10 -end module opttab + !******************************************************************************************** + subroutine checkTableHeader (ifil) + ! Read the header-text in a look-up table (in file with iu=ifil). + + integer, intent(in) :: ifil + character*80 :: headertext + character*12 :: text0, text1 + + text0='X-CHECK LUT' + text1='none ' + do while (text1(2:12) .ne. text0(2:12)) + read(ifil,'(A)') headertext + text1 = headertext(2:12) + enddo + end subroutine checkTableHeader +end module opttab diff --git a/src/physics/cam_oslo/oslo_control.F90 b/src/physics/cam_oslo/oslo_control.F90 index 42683bcc6e..c9cad9434d 100644 --- a/src/physics/cam_oslo/oslo_control.F90 +++ b/src/physics/cam_oslo/oslo_control.F90 @@ -1,197 +1,183 @@ module oslo_control -!----------------------------------------------------------------------- -! Purpose: -! -! Provides a control interface to CAM-Oslo packages -!----------------------------------------------------------------------- - -use spmd_utils, only: masterproc -use cam_logfile, only: iulog -use cam_abortutils, only: endrun -use shr_kind_mod, only: r8 => shr_kind_r8 -use cam_cpl_indices, only:index_x2a_Faoo_fdms_ocn - -implicit none -private -save - -public :: & - oslo_ctl_readnl, &! read namelist from file - oslo_getopts ! generic query method - -! Private module data - -integer, parameter,public :: dir_string_length=256 -character(len=16), parameter :: unset_str = 'UNSET' -integer, parameter :: unset_int = huge(1) - -! Namelist variables: -real(r8), private :: volc_fraction_coarse = 0.0_r8 !Fraction of volcanic aerosols in coarse mode -character(len=dir_string_length), private :: aerotab_table_dir = unset_str -! DMS/Ocean namelist variables -character(len=20), private :: dms_source = unset_str -character(len=32), private :: dms_source_type = unset_str -character(len=20), private :: opom_source = unset_str -character(len=32), private :: opom_source_type = unset_str -character(len=dir_string_length), private :: ocean_filename = unset_str -character(len=dir_string_length), private :: ocean_filepath = unset_str -integer, private :: dms_cycle_year = 0 ! =unset_int? -integer, private :: opom_cycle_year = 0 ! =unset_int? + !----------------------------------------------------------------------- + ! Purpose: + ! + ! Provides a control interface to CAM-Oslo packages + !----------------------------------------------------------------------- + + use spmd_utils, only: masterproc + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_cpl_indices, only:index_x2a_Faoo_fdms_ocn + + implicit none + private + + public :: oslo_ctl_readnl ! read namelist from file + public :: oslo_getopts ! generic query method + + ! Private module data + integer, parameter,public :: dir_string_length=256 + character(len=16), parameter :: unset_str = 'UNSET' + integer, parameter :: unset_int = huge(1) + + ! Namelist variables: + real(r8) :: volc_fraction_coarse = 0.0_r8 !Fraction of volcanic aerosols in coarse mode + character(len=dir_string_length) :: aerotab_table_dir = unset_str + + ! DMS/Ocean namelist variables + character(len=20) :: dms_source = unset_str + character(len=32) :: dms_source_type = unset_str + character(len=20) :: opom_source = unset_str + character(len=32) :: opom_source_type = unset_str + character(len=dir_string_length) :: ocean_filename = unset_str + character(len=dir_string_length) :: ocean_filepath = unset_str + integer :: dms_cycle_year = 0 ! =unset_int? + integer :: opom_cycle_year = 0 ! =unset_int? !======================================================================= contains !======================================================================= -subroutine oslo_ctl_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use mpishorthand - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'oslo_ctl_readnl' - logical :: dirExists=.FALSE. -!new - logical :: fileExists=.FALSE. - - namelist /oslo_ctl_nl/ volc_fraction_coarse, aerotab_table_dir, dms_source, & - dms_source_type, opom_source, opom_source_type, & - ocean_filename, ocean_filepath, dms_cycle_year, opom_cycle_year - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'oslo_ctl_nl', status=ierr) - if (ierr == 0) then - read(unitn, oslo_ctl_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if + subroutine oslo_ctl_readnl(nlfile) -#ifdef SPMD - ! Broadcast namelist variables - call mpibcast(volc_fraction_coarse, 1 , mpir8, 0, mpicom) - call mpibcast(aerotab_table_dir, len(aerotab_table_dir) , mpichar, 0, mpicom) -!new dms variables - call mpibcast(dms_source, len(dms_source) , mpichar, 0, mpicom) - call mpibcast(dms_source_type, len(dms_source_type) , mpichar, 0, mpicom) - call mpibcast(opom_source, len(opom_source) , mpichar, 0, mpicom) - call mpibcast(opom_source_type, len(opom_source_type) , mpichar, 0, mpicom) - call mpibcast(ocean_filename, len(ocean_filename) , mpichar, 0, mpicom) - call mpibcast(ocean_filepath, len(ocean_filepath) , mpichar, 0, mpicom) - call mpibcast(dms_cycle_year, 1 , mpiint, 0, mpicom) - call mpibcast(opom_cycle_year, 1 , mpiint, 0, mpicom) + use namelist_utils, only: find_group_name + use mpishorthand + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'oslo_ctl_readnl' + logical :: dirExists=.FALSE. + logical :: fileExists=.FALSE. + + namelist /oslo_ctl_nl/ volc_fraction_coarse, aerotab_table_dir, dms_source, & + dms_source_type, opom_source, opom_source_type, & + ocean_filename, ocean_filepath, dms_cycle_year, opom_cycle_year + !----------------------------------------------------------------------------- + if (masterproc) then + open(newunit=unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'oslo_ctl_nl', status=ierr) + if (ierr == 0) then + read(unitn, oslo_ctl_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + end if + +#ifdef SPMD + ! Broadcast namelist variables + call mpibcast(volc_fraction_coarse, 1 , mpir8, 0, mpicom) + call mpibcast(aerotab_table_dir, len(aerotab_table_dir) , mpichar, 0, mpicom) + + ! dms variables + call mpibcast(dms_source, len(dms_source) , mpichar, 0, mpicom) + call mpibcast(dms_source_type, len(dms_source_type) , mpichar, 0, mpicom) + call mpibcast(opom_source, len(opom_source) , mpichar, 0, mpicom) + call mpibcast(opom_source_type, len(opom_source_type) , mpichar, 0, mpicom) + call mpibcast(ocean_filename, len(ocean_filename) , mpichar, 0, mpicom) + call mpibcast(ocean_filepath, len(ocean_filepath) , mpichar, 0, mpicom) + call mpibcast(dms_cycle_year, 1 , mpiint, 0, mpicom) + call mpibcast(opom_cycle_year, 1 , mpiint, 0, mpicom) #endif - ! Error checking: + ! Error checking: - ! Defaults for PBL and microphysics are set in build-namelist. Check here that - ! values have been set to guard against problems with hand edited namelists. - if(volc_fraction_coarse .lt. 0.0_r8 .OR. volc_fraction_coarse .gt. 1.0_r8)then - write(iulog,*)'cam_oslo: illegal value of volc_fraction_coarse', volc_fraction_coarse - call endrun('cam_oslo: illegal value of volc_fraction_coarse') - end if + ! Defaults for PBL and microphysics are set in build-namelist. Check here that + ! values have been set to guard against problems with hand edited namelists. + if(volc_fraction_coarse .lt. 0.0_r8 .OR. volc_fraction_coarse .gt. 1.0_r8)then + write(iulog,*)'cam_oslo: illegal value of volc_fraction_coarse', volc_fraction_coarse + call endrun('cam_oslo: illegal value of volc_fraction_coarse') + end if #if defined CPRGNU || defined __GFORTRAN__ - inquire( file=trim(aerotab_table_dir), exist=dirExists ) + inquire( file=trim(aerotab_table_dir), exist=dirExists ) #elif defined CPRINTEL - inquire( directory=trim(aerotab_table_dir), exist=dirExists ) + inquire( directory=trim(aerotab_table_dir), exist=dirExists ) #else - !Don't know how to check this on other compilres.. Assume exists - !and let crash later.. - dirExists = .TRUE. + !Don't know how to check this on other compilres.. Assume exists + !and let crash later.. + dirExists = .TRUE. #endif - if(.not. dirExists)then - call endrun("cam_oslo: can not find aerotab table directory "//trim(aerotab_table_dir)) - else - write(iulog,*)"Reading aerosol tables from : " // trim(aerotab_table_dir) - endif - - ! Error check for OCEAN file - ! can ocean file be found? - inquire( file=trim(ocean_filepath)//'/'//trim(ocean_filename), exist=fileExists ) - if(.not. fileExists)then - call endrun("oslo_control: can not find ocean file "//trim(ocean_filepath)//'/'//trim(ocean_filename)) - else - write(iulog,*)"Reading ocean tracers from : " // trim(ocean_filepath)//'/'//trim(ocean_filename) - endif - - ! Error check for dms_source from namelist - if (dms_source=='ocean_flux')then - if (index_x2a_Faoo_fdms_ocn == 0) then - call endrun("cam_oslo: dms source set to "//trim(dms_source)//" but bgc is off") - else - write(iulog,*)"DMS emission source is : "// trim(dms_source) - endif - elseif(dms_source=='kettle' .or. dms_source=='lana' .or. dms_source=='emission_file')then - write(iulog,*)"DMS emission source is : "// trim(dms_source) - else - call endrun("oslo_control: no valid dms source from namelist: " //trim(dms_source)) - endif - - ! Error check for opom_source from namelist - if(opom_source=='no_file' .or. opom_source=='nilsson' .or. opom_source=='odowd')then - write(iulog,*)"Ocean POM emission source is : "// trim(opom_source) - else - call endrun("oslo_control: no valid opom source from namelist: " //trim(opom_source)) - endif - - - -! more security checks needed? - -! end of test - -end subroutine oslo_ctl_readnl - -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -subroutine oslo_getopts(volc_fraction_coarse_out, & - aerotab_table_dir_out, & - dms_source_out, & - dms_source_type_out, & - opom_source_out, & - opom_source_type_out, & - ocean_filename_out, & - ocean_filepath_out, & - opom_cycle_year_out, & - dms_cycle_year_out ) -!----------------------------------------------------------------------- -! Purpose: Return runtime settings -!----------------------------------------------------------------------- - - real(r8), intent(out), optional :: volc_fraction_coarse_out - character(len=dir_string_length), intent(out), optional :: aerotab_table_dir_out - - character(len=dir_string_length), intent(out), optional :: ocean_filename_out - character(len=dir_string_length), intent(out), optional :: ocean_filepath_out - character(len=20), intent(out), optional :: dms_source_out - character(len=32), intent(out), optional :: dms_source_type_out - integer , intent(out), optional :: dms_cycle_year_out - character(len=20), intent(out), optional :: opom_source_out - character(len=32), intent(out), optional :: opom_source_type_out - integer , intent(out), optional :: opom_cycle_year_out - - if ( present(volc_fraction_coarse_out) ) volc_fraction_coarse_out = volc_fraction_coarse - if ( present(aerotab_table_dir_out) ) aerotab_table_dir_out = aerotab_table_dir - - if ( present(ocean_filename_out) ) ocean_filename_out = ocean_filename - if ( present(ocean_filepath_out) ) ocean_filepath_out = ocean_filepath - if ( present(dms_source_out) ) dms_source_out = dms_source - if ( present(dms_source_type_out) )dms_source_type_out = dms_source_type - if ( present(dms_cycle_year_out) ) dms_cycle_year_out = dms_cycle_year - if ( present(opom_source_out) ) opom_source_out = opom_source - if ( present(opom_source_type_out))opom_source_type_out= opom_source_type - if ( present(opom_cycle_year_out) )opom_cycle_year_out = opom_cycle_year -end subroutine oslo_getopts - -!=============================================================================== + if(.not. dirExists)then + call endrun("cam_oslo: can not find aerotab table directory "//trim(aerotab_table_dir)) + else + write(iulog,*)"Reading aerosol tables from : " // trim(aerotab_table_dir) + endif + + ! Error check for OCEAN file + ! can ocean file be found? + inquire( file=trim(ocean_filepath)//'/'//trim(ocean_filename), exist=fileExists ) + if(.not. fileExists)then + call endrun("oslo_control: can not find ocean file "//trim(ocean_filepath)//'/'//trim(ocean_filename)) + else + write(iulog,*)"Reading ocean tracers from : " // trim(ocean_filepath)//'/'//trim(ocean_filename) + endif + + ! Error check for dms_source from namelist + if (dms_source=='ocean_flux')then + if (index_x2a_Faoo_fdms_ocn == 0) then + call endrun("cam_oslo: dms source set to "//trim(dms_source)//" but bgc is off") + else + write(iulog,*)"DMS emission source is : "// trim(dms_source) + endif + elseif(dms_source=='kettle' .or. dms_source=='lana' .or. dms_source=='emission_file')then + write(iulog,*)"DMS emission source is : "// trim(dms_source) + else + call endrun("oslo_control: no valid dms source from namelist: " //trim(dms_source)) + endif + + ! Error check for opom_source from namelist + if(opom_source=='no_file' .or. opom_source=='nilsson' .or. opom_source=='odowd')then + write(iulog,*)"Ocean POM emission source is : "// trim(opom_source) + else + call endrun("oslo_control: no valid opom source from namelist: " //trim(opom_source)) + endif + + end subroutine oslo_ctl_readnl + + subroutine oslo_getopts(volc_fraction_coarse_out, & + aerotab_table_dir_out, & + dms_source_out, & + dms_source_type_out, & + opom_source_out, & + opom_source_type_out, & + ocean_filename_out, & + ocean_filepath_out, & + opom_cycle_year_out, & + dms_cycle_year_out ) + + !----------------------------------------------------------------------- + ! Purpose: Return runtime settings + !----------------------------------------------------------------------- + + real(r8), intent(out), optional :: volc_fraction_coarse_out + character(len=dir_string_length), intent(out), optional :: aerotab_table_dir_out + + character(len=dir_string_length), intent(out), optional :: ocean_filename_out + character(len=dir_string_length), intent(out), optional :: ocean_filepath_out + character(len=20), intent(out), optional :: dms_source_out + character(len=32), intent(out), optional :: dms_source_type_out + integer , intent(out), optional :: dms_cycle_year_out + character(len=20), intent(out), optional :: opom_source_out + character(len=32), intent(out), optional :: opom_source_type_out + integer , intent(out), optional :: opom_cycle_year_out + + if ( present(volc_fraction_coarse_out ) ) volc_fraction_coarse_out = volc_fraction_coarse + if ( present(aerotab_table_dir_out ) ) aerotab_table_dir_out = aerotab_table_dir + if ( present(ocean_filename_out ) ) ocean_filename_out = ocean_filename + if ( present(ocean_filepath_out ) ) ocean_filepath_out = ocean_filepath + if ( present(dms_source_out ) ) dms_source_out = dms_source + if ( present(dms_source_type_out ) ) dms_source_type_out = dms_source_type + if ( present(dms_cycle_year_out ) ) dms_cycle_year_out = dms_cycle_year + if ( present(opom_source_out ) ) opom_source_out = opom_source + if ( present(opom_source_type_out ) ) opom_source_type_out= opom_source_type + if ( present(opom_cycle_year_out ) ) opom_cycle_year_out = opom_cycle_year + end subroutine oslo_getopts + end module oslo_control diff --git a/src/physics/cam_oslo/pmxsub.F90 b/src/physics/cam_oslo/pmxsub.F90 index 878ca43d2f..16e1808ffa 100644 --- a/src/physics/cam_oslo/pmxsub.F90 +++ b/src/physics/cam_oslo/pmxsub.F90 @@ -2,9 +2,9 @@ module pmxsub_mod implicit none - !=============================================================================== +!=============================================================================== contains - !=============================================================================== +!=============================================================================== subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & @@ -28,12 +28,10 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & use commondefinitions use physics_types, only: physics_state use wv_saturation, only: qsat_water - use aeroopt_mod, only: extinction_coeffs, extinction_coeffsn - use aerodry_mod, only: aerodry_prop ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns + integer , intent(in) :: lchnk ! chunk identifier + integer , intent(in) :: ncol ! number of atmospheric columns real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures (Pa) @@ -79,8 +77,6 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & real(r8) :: Cam(pcols,pver,nbmodes), fbcm(pcols,pver,nbmodes), fcm(pcols,pver,nbmodes) real(r8) :: faqm(pcols,pver,nbmodes), f_condm(pcols,pver,nbmodes) real(r8) :: f_soam(pcols, pver,nbmodes), faqm4(pcols,pver) - real(r8) :: xrh(pcols,pver) - integer :: irh1(pcols,pver) real(r8) :: focm(pcols,pver,4) real(r8) :: ssa(pcols,pver,0:nmodes,nbands), asym(pcols,pver,0:nmodes,nbands) real(r8) :: be(pcols,pver,0:nmodes,nbands), ke(pcols,pver,0:nmodes,nbands) @@ -94,11 +90,13 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & real(r8) :: volc_balw(pcols,0:pver,nlwbands) ! volcanic aerosol absorption coefficient for terrestrial bands, CMIP6 real(r8) :: rh0(pcols,pver), rhoda(pcols,pver) real(r8) :: ssavis(pcols,pver), asymmvis(pcols,pver), extvis(pcols,pver), dayfoc(pcols,pver) - real(r8) :: n_aerorig(pcols,pver), n_aer(pcols,pver) + real(r8) :: n_aer(pcols,pver) real(r8) :: es(pcols,pver) ! saturation vapor pressure real(r8) :: qs(pcols,pver) ! saturation specific humidity real(r8) :: rht(pcols,pver) ! relative humidity (fraction) (rh is already used in opptab) real(r8) :: rh_temp(pcols,pver) ! relative humidity (fraction) for input to LUT + real(r8) :: xrh(pcols,pver) + integer :: irh1(pcols,pver) real(r8) :: xfombg(pcols,pver) integer :: ifombg1(pcols,pver), ifombg2(pcols,pver) real(r8) :: xct(pcols,pver,nmodes) @@ -162,7 +160,6 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & end do do k=1,pver do icol=1,ncol - n_aerorig(icol,k) = 0.0_r8 n_aer(icol,k) = 0.0_r8 end do end do @@ -340,9 +337,8 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & + volc_ext_sun(1:ncol,1:pver,ib)*volc_omega_sun(1:ncol,1:pver,ib) & *volc_g_sun(1:ncol,1:pver,ib) enddo - !akc6+ bevisvolc(1:ncol,1:pver) = volc_ext_sun(1:ncol,1:pver,4) - !akc6- + ! and then calculate the total bulk optical parameters do ib=1,nbands do k=1,pver diff --git a/src/physics/cam_oslo/radiation.F90 b/src/physics/cam_oslo/radiation.F90 index 3a1d517b86..44a7132721 100644 --- a/src/physics/cam_oslo/radiation.F90 +++ b/src/physics/cam_oslo/radiation.F90 @@ -723,7 +723,6 @@ subroutine radiation_tend( & use commondefinitions use aerosoldef - use opttab, only: nbands, eps use constituents, only: pcnst use oslo_control, only: oslo_getopts use physics_buffer, only: pbuf_get_index From 99e950c6999fdb3314d188e76771bfd78bca1210 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 18 Aug 2023 11:26:25 +0200 Subject: [PATCH 15/71] fix for build problem --- src/chemistry/oslo_aero/intlog.F90 | 16 ++++++++++++++++ src/physics/cam_oslo/opttab.F90 | 15 +++++++++++++++ 2 files changed, 31 insertions(+) diff --git a/src/chemistry/oslo_aero/intlog.F90 b/src/chemistry/oslo_aero/intlog.F90 index ecbd016331..c6c598e89d 100644 --- a/src/chemistry/oslo_aero/intlog.F90 +++ b/src/chemistry/oslo_aero/intlog.F90 @@ -722,5 +722,21 @@ subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & end do ! lon end subroutine intlog5to10_sub + !******************************************************************************************** + subroutine checkTableHeader (ifil) + ! Read the header-text in a look-up table (in file with iu=ifil). + + integer, intent(in) :: ifil + character*80 :: headertext + character*12 :: text0, text1 + + text0='X-CHECK LUT' + text1='none ' + do while (text1(2:12) .ne. text0(2:12)) + read(ifil,'(A)') headertext + text1 = headertext(2:12) + enddo + end subroutine checkTableHeader + end module intlog diff --git a/src/physics/cam_oslo/opttab.F90 b/src/physics/cam_oslo/opttab.F90 index 8f5eb85bc8..951daef355 100644 --- a/src/physics/cam_oslo/opttab.F90 +++ b/src/physics/cam_oslo/opttab.F90 @@ -21,6 +21,21 @@ module opttab ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. ! Modified cate values for kcomp=2 (as in AeroTab) - Alf Kirkevaag October 2016. + ! Internal mixtures of process-tagged mass + ! cate : total added mass (µg/m3 per particle per cm3) from condensation + ! and wet phase chemistry/cloud processing, for kcomp = 1-2. + ! cate should be scaled up/down whenever the modal parameters (modal + ! radius and width) are increased/decreased a lot. + ! cat : total added mass (µg/m3 per particle per cm-3) from coagulation, condensation + ! and wet phase chemistry/cloud processing, for kcomp = 5-10. + ! cat should be scaled up/down whenever the modal parameters (modal + ! radius and width) are increased/decreased a lot. + ! fac : mass fraction of cat or cate from coagulating carbonaceous aerosols (BC+OM). + ! The remaining mass cate*(1-fac) or cat*(1-fac) is SO4. + ! fbc : mass fraction of BC from coagulating carbonaceous aerosols, BC/(BC+OM). + ! faq : mass fraction of sulfate which is produced in wet-phase, SO4aq/SO4. + ! The remaining SO4 mass, SO4*(1-faq), is from condensation. + use shr_kind_mod , only: r8 => shr_kind_r8 use ppgrid , only: pcols, pver use cam_logfile , only: iulog From 5c4c0b4b42ee6b087c916b98e7aed403c751bd1d Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 18 Aug 2023 14:13:59 +0200 Subject: [PATCH 16/71] moved duplicate files to physics/cam_oslo and kept oslo aero files in chemistry/oslo_aero --- .../oslo_aero}/aerocom_dry_mod.F90 | 0 .../oslo_aero}/aerocom_mod.F90 | 0 .../oslo_aero}/aerocom_opt_mod.F90 | 0 .../{aeronucl.F90 => aeronucl_mod.F90} | 368 +++++++----- src/chemistry/oslo_aero/appformrate.F90 | 58 -- .../oslo_aero}/lininterpol_mod.F90 | 0 src/chemistry/oslo_aero/modalapp2d.F90 | 169 ------ .../oslo_aero}/opttab.F90 | 0 .../oslo_aero}/oslo_control.F90 | 0 src/chemistry/oslo_aero/parmix_progncdnc.F90 | 553 +++++++++++------- .../oslo_aero}/pmxsub.F90 | 0 .../cam_oslo}/dust_model.F90 | 0 .../cam_oslo}/dust_sediment_mod.F90 | 0 .../cam_oslo}/hetfrz_classnuc_oslo.F90 | 0 .../cam_oslo}/microp_aero.F90 | 0 .../cam_oslo}/mo_chm_diags.F90 | 0 .../cam_oslo}/mo_drydep.F90 | 0 .../cam_oslo}/mo_extfrc.F90 | 0 .../cam_oslo}/mo_gas_phase_chemdr.F90 | 0 .../cam_oslo}/mo_neu_wetdep.F90 | 0 .../cam_oslo}/mo_setsox.F90 | 0 .../cam_oslo}/mo_srf_emissions.F90 | 0 .../cam_oslo}/mo_usrrxt.F90 | 0 .../cam_oslo}/modal_aero_data.F90 | 0 .../cam_oslo}/modal_aero_deposition.F90 | 0 .../cam_oslo}/seasalt_model.F90 | 0 .../cam_oslo}/sox_cldaero_mod.F90 | 0 .../cam_oslo}/vertical_diffusion.F90 | 0 .../cam_oslo}/zm_microphysics.F90 | 0 29 files changed, 560 insertions(+), 588 deletions(-) rename src/{physics/cam_oslo => chemistry/oslo_aero}/aerocom_dry_mod.F90 (100%) rename src/{physics/cam_oslo => chemistry/oslo_aero}/aerocom_mod.F90 (100%) rename src/{physics/cam_oslo => chemistry/oslo_aero}/aerocom_opt_mod.F90 (100%) rename src/chemistry/oslo_aero/{aeronucl.F90 => aeronucl_mod.F90} (51%) delete mode 100644 src/chemistry/oslo_aero/appformrate.F90 rename src/{physics/cam_oslo => chemistry/oslo_aero}/lininterpol_mod.F90 (100%) delete mode 100644 src/chemistry/oslo_aero/modalapp2d.F90 rename src/{physics/cam_oslo => chemistry/oslo_aero}/opttab.F90 (100%) rename src/{physics/cam_oslo => chemistry/oslo_aero}/oslo_control.F90 (100%) rename src/{physics/cam_oslo => chemistry/oslo_aero}/pmxsub.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/dust_model.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/dust_sediment_mod.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/hetfrz_classnuc_oslo.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/microp_aero.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/mo_chm_diags.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/mo_drydep.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/mo_extfrc.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/mo_gas_phase_chemdr.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/mo_neu_wetdep.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/mo_setsox.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/mo_srf_emissions.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/mo_usrrxt.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/modal_aero_data.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/modal_aero_deposition.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/seasalt_model.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/sox_cldaero_mod.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/vertical_diffusion.F90 (100%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/zm_microphysics.F90 (100%) diff --git a/src/physics/cam_oslo/aerocom_dry_mod.F90 b/src/chemistry/oslo_aero/aerocom_dry_mod.F90 similarity index 100% rename from src/physics/cam_oslo/aerocom_dry_mod.F90 rename to src/chemistry/oslo_aero/aerocom_dry_mod.F90 diff --git a/src/physics/cam_oslo/aerocom_mod.F90 b/src/chemistry/oslo_aero/aerocom_mod.F90 similarity index 100% rename from src/physics/cam_oslo/aerocom_mod.F90 rename to src/chemistry/oslo_aero/aerocom_mod.F90 diff --git a/src/physics/cam_oslo/aerocom_opt_mod.F90 b/src/chemistry/oslo_aero/aerocom_opt_mod.F90 similarity index 100% rename from src/physics/cam_oslo/aerocom_opt_mod.F90 rename to src/chemistry/oslo_aero/aerocom_opt_mod.F90 diff --git a/src/chemistry/oslo_aero/aeronucl.F90 b/src/chemistry/oslo_aero/aeronucl_mod.F90 similarity index 51% rename from src/chemistry/oslo_aero/aeronucl.F90 rename to src/chemistry/oslo_aero/aeronucl_mod.F90 index 360d1680f3..3c4673ab0d 100644 --- a/src/chemistry/oslo_aero/aeronucl.F90 +++ b/src/chemistry/oslo_aero/aeronucl_mod.F90 @@ -1,28 +1,33 @@ -subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuclso4, nuclorg, zm, pblht) - -! Subroutine to calculate nucleation (formation) rates of new particles -! At the moment, the final nucleation rate consists of -! (1) Binary sulphuric acid-water nucleation in whole atmosphere (Vehkamaki et al., 2002, JGR) -! JGR, vol 107, No D22, http://onlinelibrary.wiley.com/doi/10.1029/2002JD002184/abstract -! (2) Boundary-layer nucleation -! Paasonen et al (2010), ACP, vol 10, pp 11223: http://www.atmos-chem-phys.net/10/11223/2010/acp-10-11223-2010.html -! (3) First version published ACP (Risto Makkonen) -! ACP, vol 14, no 10, pp 5127 http://www.atmos-chem-phys.net/14/5127/2014/acp-14-5127-2014.html -! Modified Spring 2015, cka - - use shr_kind_mod, only: r8 => shr_kind_r8 - use wv_saturation, only: qsat_water - use physconst, only: avogad, rair - use ppgrid, only: pcols, pver, pverp - use aerosoldef, only : MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na - use commondefinitions, only: originalNumberMedianRadius - use cam_history, only: outfld - use phys_control, only: phys_getopts - use chem_mods, only: adv_mass - use m_spc_id, only : id_H2SO4, id_soa_lv - use const, only : volumeToNumber - - implicit none +module aeronucl_mod + + use shr_kind_mod, only: r8 => shr_kind_r8 + use wv_saturation, only: qsat_water + use physconst, only: avogad, rair + use ppgrid, only: pcols, pver, pverp + use aerosoldef, only : MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na + use commondefinitions, only: originalNumberMedianRadius + use cam_history, only: outfld + use phys_control, only: phys_getopts + use chem_mods, only: adv_mass + use m_spc_id, only : id_H2SO4, id_soa_lv + use const, only : volumeToNumber + + implicit none + +contains + + subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuclso4, nuclorg, zm, pblht) + + ! Subroutine to calculate nucleation (formation) rates of new particles + ! At the moment, the final nucleation rate consists of + ! (1) Binary sulphuric acid-water nucleation in whole atmosphere (Vehkamaki et al., 2002, JGR) + ! JGR, vol 107, No D22, http://onlinelibrary.wiley.com/doi/10.1029/2002JD002184/abstract + ! (2) Boundary-layer nucleation + ! Paasonen et al (2010), ACP, vol 10, pp 11223: http://www.atmos-chem-phys.net/10/11223/2010/acp-10-11223-2010.html + ! (3) First version published ACP (Risto Makkonen) + ! ACP, vol 14, no 10, pp 5127 http://www.atmos-chem-phys.net/14/5127/2014/acp-14-5127-2014.html + ! Modified Spring 2015, cka + !-- Arguments integer, intent(in) :: lchnk ! chunk identifier @@ -39,7 +44,7 @@ subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuc real(r8), intent(in) :: pblht(pcols) ! Planetary boundary layer height (m) !-- Local variables - + real(r8), parameter :: pi=3.141592654_r8 !cka+ real(r8), parameter :: gasconst_R=8.314472_r8 ! universal gas constant [J mol-1 K-1] @@ -75,11 +80,11 @@ subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuc real(r8) :: molmass_h2so4 ! molecular mass of h2so4 [g/mol] real(r8) :: molmass_soa ! molecular mass of soa [g/mol] - ! Variables for binary nucleation parameterization - real(r8) :: zrhoa, zrh, zt, zt2, zt3, zlogrh, zlogrh2, zlogrh3, zlogrhoa, zlogrhoa2, zlogrhoa3, x, zxmole, zix - real(r8) :: zjnuc, zntot, zrc, zrxc + ! Variables for binary nucleation parameterization + real(r8) :: zrhoa, zrh, zt, zt2, zt3, zlogrh, zlogrh2, zlogrh3, zlogrhoa, zlogrhoa2, zlogrhoa3, x, zxmole, zix + real(r8) :: zjnuc, zntot, zrc, zrxc -!cka: OBS call phys_getopts(pbl_nucleation_out=pbl_nucleation, atm_nucleation_out=atm_nucleation) + !cka: OBS call phys_getopts(pbl_nucleation_out=pbl_nucleation, atm_nucleation_out=atm_nucleation) !cka: testing by setting these flags: pbl_nucleation = 2 atm_nucleation = 1 @@ -92,7 +97,7 @@ subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuc formrate_pbl(:,:)=0._r8 !-- The highest level in planetary boundary layer do i=1,ncol - pblht_lim(i)=MIN(MAX(pblht(i),500._r8),7000._r8) + pblht_lim(i)=MIN(MAX(pblht(i),500._r8),7000._r8) end do !-- Get molecular mass of h2so4 and soa_lv (cka) @@ -105,66 +110,66 @@ subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuc !-- Conversion of H2SO4 from kg/kg to #/cm3 !-- and calculation of relative humidity (needed by binary nucleation parameterization) do k=1,pver - do i=1,ncol - rhoair(i,k)=pmid(i,k)/(t(i,k)*rair) - !avogad*1.e-3_r8 to get molec/mol instead of molec/kmol - h2so4(i,k)=(1.e-6_r8*h2so4pc(i,k)*avogad*1.e-3_r8*rhoair(i,k))/(molmass_h2so4*1.E-3_r8) - orgforgrowth(i,k)=(1.e-6_r8*oxidorg(i,k)*avogad*1.e-3_r8*rhoair(i,k))/(molmass_soa*1.E-3_r8) - orgforgrowth(i,k)=MAX(MIN(orgforgrowth(i,k),1.E10_r8),0._r8) - - call qsat_water(t(i,k),pmid(i,k),dummy,qs(i,k)) - - relhum(i,k) = h2ommr(i,k)/qs(i,k) - relhum(i,k) = max(relhum(i,k),0.0_r8) - relhum(i,k) = min(relhum(i,k),1.0_r8) - end do !ncol + do i=1,ncol + rhoair(i,k)=pmid(i,k)/(t(i,k)*rair) + !avogad*1.e-3_r8 to get molec/mol instead of molec/kmol + h2so4(i,k)=(1.e-6_r8*h2so4pc(i,k)*avogad*1.e-3_r8*rhoair(i,k))/(molmass_h2so4*1.E-3_r8) + orgforgrowth(i,k)=(1.e-6_r8*oxidorg(i,k)*avogad*1.e-3_r8*rhoair(i,k))/(molmass_soa*1.E-3_r8) + orgforgrowth(i,k)=MAX(MIN(orgforgrowth(i,k),1.E10_r8),0._r8) + + call qsat_water(t(i,k),pmid(i,k),dummy,qs(i,k)) + + relhum(i,k) = h2ommr(i,k)/qs(i,k) + relhum(i,k) = max(relhum(i,k),0.0_r8) + relhum(i,k) = min(relhum(i,k),1.0_r8) + end do !ncol end do !layers - + !-- Binary sulphuric acid-water nucleation rate if(atm_nucleation .EQ. 1) then - do k=1,pver - do i=1,ncol + do k=1,pver + do i=1,ncol + + ! Calculate nucleation only for valid thermodynamic conditions: + zrhoa = max(h2so4(i,k),1.E+4_r8) + zrhoa = min(zrhoa,1.E11_r8) + + zrh = max(relhum(i,k),1.E-4_r8) + zrh = min(zrh,1.0_r8) - ! Calculate nucleation only for valid thermodynamic conditions: - zrhoa = max(h2so4(i,k),1.E+4_r8) - zrhoa = min(zrhoa,1.E11_r8) - - zrh = max(relhum(i,k),1.E-4_r8) - zrh = min(zrh,1.0_r8) - - zt = max(t(i,k),190.15_r8) - zt = min(zt,300.15_r8) + zt = max(t(i,k),190.15_r8) + zt = min(zt,300.15_r8) - zt2 = zt*zt - zt3 = zt2*zt + zt2 = zt*zt + zt3 = zt2*zt - ! Equation (11) - molefraction of H2SO4 in the critical cluster + ! Equation (11) - molefraction of H2SO4 in the critical cluster - zlogrh = LOG(zrh) - zlogrh2 = zlogrh*zlogrh - zlogrh3 = zlogrh2*zlogrh + zlogrh = LOG(zrh) + zlogrh2 = zlogrh*zlogrh + zlogrh3 = zlogrh2*zlogrh - zlogrhoa = LOG(zrhoa) - zlogrhoa2 = zlogrhoa*zlogrhoa - zlogrhoa3 = zlogrhoa2*zlogrhoa + zlogrhoa = LOG(zrhoa) + zlogrhoa2 = zlogrhoa*zlogrhoa + zlogrhoa3 = zlogrhoa2*zlogrhoa - x=0.7409967177282139_r8 - 0.002663785665140117_r8*zt & - + 0.002010478847383187_r8*zlogrh & - - 0.0001832894131464668_r8*zt*zlogrh & - + 0.001574072538464286_r8*zlogrh2 & - - 0.00001790589121766952_r8*zt*zlogrh2 & - + 0.0001844027436573778_r8*zlogrh3 & - - 1.503452308794887e-6_r8*zt*zlogrh3 & - - 0.003499978417957668_r8*zlogrhoa & - + 0.0000504021689382576_r8*zt*zlogrhoa + x=0.7409967177282139_r8 - 0.002663785665140117_r8*zt & + + 0.002010478847383187_r8*zlogrh & + - 0.0001832894131464668_r8*zt*zlogrh & + + 0.001574072538464286_r8*zlogrh2 & + - 0.00001790589121766952_r8*zt*zlogrh2 & + + 0.0001844027436573778_r8*zlogrh3 & + - 1.503452308794887e-6_r8*zt*zlogrh3 & + - 0.003499978417957668_r8*zlogrhoa & + + 0.0000504021689382576_r8*zt*zlogrhoa - zxmole=x + zxmole=x - zix = 1.0_r8/x + zix = 1.0_r8/x - ! Equation (12) - nucleation rate in 1/cm3s + ! Equation (12) - nucleation rate in 1/cm3s - zjnuc=0.1430901615568665_r8 + 2.219563673425199_r8*zt - & + zjnuc=0.1430901615568665_r8 + 2.219563673425199_r8*zt - & 0.02739106114964264_r8*zt2 + & 0.00007228107239317088_r8*zt3 + 5.91822263375044_r8*zix + & 0.1174886643003278_r8*zlogrh + 0.4625315047693772_r8*zt*zlogrh - & @@ -212,11 +217,11 @@ subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuc 5.004267665960894e-9_r8*zt3*zlogrhoa3 - & (0.01270805101481648_r8*zlogrhoa3)*zix - zjnuc=EXP(zjnuc) ! add. Eq. (12) [1/(cm^3s)] + zjnuc=EXP(zjnuc) ! add. Eq. (12) [1/(cm^3s)] - ! Equation (13) - total number of molecules in the critical cluster + ! Equation (13) - total number of molecules in the critical cluster - zntot=-0.002954125078716302_r8 - 0.0976834264241286_r8*zt + & + zntot=-0.002954125078716302_r8 - 0.0976834264241286_r8*zt + & 0.001024847927067835_r8*zt2 - 2.186459697726116e-6_r8*zt3 - & 0.1017165718716887_r8*zix - 0.002050640345231486_r8*zlogrh - & 0.007585041382707174_r8*zt*zlogrh + & @@ -264,104 +269,104 @@ subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuc 1.421771723004557e-11_r8*zt3*zlogrhoa3 + & (0.0001357509859501723_r8*zlogrhoa3)*zix - zntot=EXP(zntot) ! add. Eq. (13) - - ! Equation (14) - radius of the critical cluster in nm + zntot=EXP(zntot) ! add. Eq. (13) - zrc=EXP(-1.6524245_r8+0.42316402_r8*x+0.33466487_r8*LOG(zntot)) ! [nm] + ! Equation (14) - radius of the critical cluster in nm - !----1.2) Limiter + zrc=EXP(-1.6524245_r8+0.42316402_r8*x+0.33466487_r8*LOG(zntot)) ! [nm] - IF(zjnuc<1.e-7_r8 .OR. zntot<4.0_r8) zjnuc=0.0_r8 + !----1.2) Limiter - ! limitation to 1E+10 [1/cm3s] + IF(zjnuc<1.e-7_r8 .OR. zntot<4.0_r8) zjnuc=0.0_r8 - nuclrate_bin(i,k)=MAX(MIN(zjnuc,1.E10_r8),0._r8) - nuclsize_bin(i,k)=MAX(MIN(zrc,1.E2_r8),0.01_r8) + ! limitation to 1E+10 [1/cm3s] - end do - end do + nuclrate_bin(i,k)=MAX(MIN(zjnuc,1.E10_r8),0._r8) + nuclsize_bin(i,k)=MAX(MIN(zrc,1.E2_r8),0.01_r8) + + end do + end do else !No atmospheric nucleation - nuclrate_bin(:,:)=0._r8 - nuclsize_bin(:,:)=1._r8 + nuclrate_bin(:,:)=0._r8 + nuclsize_bin(:,:)=1._r8 end if !-- Boundary layer nucleation do k=1,pver - do i=1,ncol - - !-- Nucleation rate #/cm3/s - if(pblht_lim(i)>zm(i,k) .AND. pbl_nucleation>0) then - - if(pbl_nucleation .EQ. 1) then + do i=1,ncol + + !-- Nucleation rate #/cm3/s + if(pblht_lim(i)>zm(i,k) .AND. pbl_nucleation>0) then + + if(pbl_nucleation .EQ. 1) then - !-- Paasonen et al. (2010), eqn 10, Table 4 - nuclrate_pbl(i,k)=(1.7E-6_r8)*h2so4(i,k) + !-- Paasonen et al. (2010), eqn 10, Table 4 + nuclrate_pbl(i,k)=(1.7E-6_r8)*h2so4(i,k) - else if(pbl_nucleation .EQ. 2) then + else if(pbl_nucleation .EQ. 2) then - !-- Paasonen et al. (2010) - !values from Table 3 in Paasonen et al (2010), modified version of eqn 14 - nuclrate_pbl(i,k)=(6.1E-7_r8)*h2so4(i,k)+(0.39E-7_r8)*orgforgrowth(i,k) + !-- Paasonen et al. (2010) + !values from Table 3 in Paasonen et al (2010), modified version of eqn 14 + nuclrate_pbl(i,k)=(6.1E-7_r8)*h2so4(i,k)+(0.39E-7_r8)*orgforgrowth(i,k) - end if + end if - nuclrate_pbl(i,k)=MAX(MIN(nuclrate_pbl(i,k),1.E10_r8),0._r8) + nuclrate_pbl(i,k)=MAX(MIN(nuclrate_pbl(i,k),1.E10_r8),0._r8) - else !Not using PBL-nucleation - nuclrate_pbl(i,k)=0._r8 - end if - !Size [nm] of particles in PBL - nuclsize_pbl(i,k)=2._r8 + else !Not using PBL-nucleation + nuclrate_pbl(i,k)=0._r8 + end if + !Size [nm] of particles in PBL + nuclsize_pbl(i,k)=2._r8 - end do !horizontal points + end do !horizontal points end do !levels !-- Calculate total nucleated mass do k=1,pver - do i=1,ncol - - ! Molecular speed and growth rate: H2SO4. Eq. 21 in Kerminen and Kulmala 2002 - vmolh2so4=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_h2so4*1.E-3_r8)) - grh2so4(i,k)=(3.E-9_r8/h2so4_dens)*(vmolh2so4*molmass_h2so4*h2so4(i,k)) - grh2so4(i,k)=MAX(MIN(grh2so4(i,k),10000._r8),1.E-10_r8) - - ! Molecular speed and growth rate: ORG. Eq. 21 in Kerminen and Kulmala 2002 - vmolorg=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_soa*1.E-3_r8)) - grorg(i,k)=(3.E-9_r8/org_dens)*(vmolorg*molmass_soa*orgforgrowth(i,k)) - grorg(i,k)=MAX(MIN(grorg(i,k),10000._r8),1.E-10_r8) - - ! Combined growth rate (cka) - gr(i,k)=grh2so4(i,k)+grorg(i,k) - - !-- Lehtinen 2007 parameterization for apparent formation rate - ! diameters in nm, growth rate in nm h-1, coagulation in s-1 - - call appformrate(nuclsize_bin(i,k), d_form*1.E9_r8, nuclrate_bin(i,k), formrate_bin(i,k), coagnuc(i,k), gr(i,k)) - call appformrate(nuclsize_pbl(i,k), d_form*1.E9_r8, nuclrate_pbl(i,k), formrate_pbl(i,k), coagnuc(i,k), gr(i,k)) - - formrate_bin(i,k)=MAX(MIN(formrate_bin(i,k),1.E3_r8),0._r8) - formrate_pbl(i,k)=MAX(MIN(formrate_pbl(i,k),1.E3_r8),0._r8) - - ! Number of mol nucleated per g air per second. - nuclvolume(i,k) = (formrate_bin(i,k) + formrate_pbl(i,k)) & ![particles/cm3] - *1.0e6_r8 & !==> [particles / m3 /] - /volumeToNumber(MODE_IDX_SO4SOA_AIT) & !==> [m3_{aer} / m3_{air} / sec] - / rhoair(i,k) !==> m3_{aer} / kg_{air} /sec - - !Estimate how much is organic based on growth-rate - if(gr(i,k)>1.E-10_r8) then - frach2so4=grh2so4(i,k)/gr(i,k) - else - frach2so4=1._r8 - end if - - ! Nucleated so4 and soa mass mixing ratio per second [kg kg-1 s-1] - ! used density of particle phase, not of condensing gas - nuclso4(i,k)=rhopart(l_so4_na)*nuclvolume(i,k)*frach2so4 - nuclorg(i,k)=rhopart(l_soa_na)*nuclvolume(i,k)*(1.0_r8-frach2so4) - - end do + do i=1,ncol + + ! Molecular speed and growth rate: H2SO4. Eq. 21 in Kerminen and Kulmala 2002 + vmolh2so4=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_h2so4*1.E-3_r8)) + grh2so4(i,k)=(3.E-9_r8/h2so4_dens)*(vmolh2so4*molmass_h2so4*h2so4(i,k)) + grh2so4(i,k)=MAX(MIN(grh2so4(i,k),10000._r8),1.E-10_r8) + + ! Molecular speed and growth rate: ORG. Eq. 21 in Kerminen and Kulmala 2002 + vmolorg=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_soa*1.E-3_r8)) + grorg(i,k)=(3.E-9_r8/org_dens)*(vmolorg*molmass_soa*orgforgrowth(i,k)) + grorg(i,k)=MAX(MIN(grorg(i,k),10000._r8),1.E-10_r8) + + ! Combined growth rate (cka) + gr(i,k)=grh2so4(i,k)+grorg(i,k) + + !-- Lehtinen 2007 parameterization for apparent formation rate + ! diameters in nm, growth rate in nm h-1, coagulation in s-1 + + call appformrate(nuclsize_bin(i,k), d_form*1.E9_r8, nuclrate_bin(i,k), formrate_bin(i,k), coagnuc(i,k), gr(i,k)) + call appformrate(nuclsize_pbl(i,k), d_form*1.E9_r8, nuclrate_pbl(i,k), formrate_pbl(i,k), coagnuc(i,k), gr(i,k)) + + formrate_bin(i,k)=MAX(MIN(formrate_bin(i,k),1.E3_r8),0._r8) + formrate_pbl(i,k)=MAX(MIN(formrate_pbl(i,k),1.E3_r8),0._r8) + + ! Number of mol nucleated per g air per second. + nuclvolume(i,k) = (formrate_bin(i,k) + formrate_pbl(i,k)) & ![particles/cm3] + *1.0e6_r8 & !==> [particles / m3 /] + /volumeToNumber(MODE_IDX_SO4SOA_AIT) & !==> [m3_{aer} / m3_{air} / sec] + / rhoair(i,k) !==> m3_{aer} / kg_{air} /sec + + !Estimate how much is organic based on growth-rate + if(gr(i,k)>1.E-10_r8) then + frach2so4=grh2so4(i,k)/gr(i,k) + else + frach2so4=1._r8 + end if + + ! Nucleated so4 and soa mass mixing ratio per second [kg kg-1 s-1] + ! used density of particle phase, not of condensing gas + nuclso4(i,k)=rhopart(l_so4_na)*nuclvolume(i,k)*frach2so4 + nuclorg(i,k)=rhopart(l_soa_na)*nuclvolume(i,k)*(1.0_r8-frach2so4) + + end do end do !-- Diagnostic output @@ -373,5 +378,52 @@ subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuc call outfld('GR', gr, pcols ,lchnk) return -end + end subroutine aeronucl + + subroutine appformrate(d1, dx, j1, jx, CoagS_dx, gr) + !-- appformrate calculates the formation rate jx of dx sized particles from the nucleation rate j1 (d1 sized particles) + !-- Formation rate is parameterized according to Lehtinen et al. (2007), JAS 38:988-994 + !-- Parameterization takes into account the loss of particles due to coagulation + !-- Growth by self-coagulation is not accounted for + !-- Typically, 1% of 1 nm nuclei make it to 12 nm + !-- Written by Risto Makkonen + ! First estimate: 99% of particles are lost during growth from 1 nm to 12 nm + + !-- Arguments + + real(r8), intent(in) :: d1 ! Size of nucleation-sized particles (nm) + real(r8), intent(in) :: dx ! Size of calculated apparent formation rate (nm) + real(r8), intent(in) :: j1 ! Nucleation rate of d1 sized particles (# cm-3 s-1) + real(r8), intent(out) :: jx ! Formation rate of dx sized particles (# cm-3 s-1) + real(r8), intent(in) :: CoagS_dx ! Coagulation term for nucleating particles (s-1) + real(r8), intent(in) :: gr ! Particle growth rate (nm h-1) + + !-- Local variables + + real(r8) :: m + real(r8) :: gamma + real(r8) :: CoagS_d1 ! Coagulation term for nucleating particles, calculated from CoagS_dx + + ! In Hyytiala, typically 80% of the nuclei are scavenged onto larger background particles while they grow from 1 to 3 nm + + !-- (Eq. 6) Exponent m, depends on background distribution + ! m=log(CoagS_dx/CoagS_d1)/log(dx/d1) + ! Or, if we dont want to calculate CoagS_d1, lets assume a typical value for m (-1.5 -- -1.9) and calculate CoagS_d1 from Eq.5 + m=-1.6_r8 + CoagS_d1=CoagS_dx*(d1/dx)**m + CoagS_d1=MAX(MIN(CoagS_d1,1.E2_r8),1.E-10_r8) + + gamma=(1._r8/(m+1._r8))*((dx/d1)**(m+1._r8)-1._r8) + gamma=MAX(MIN(gamma,1.E2_r8),1.E-10_r8) + + !gr=MAX(MIN(gr,1.E3_r8),1.E-5_r8) + + !-- (Eq. 7) CoagS_d1 is multiplied with 3600 to get units h-1 + !WRITE(*,*) 'gammaym:',gamma,exp(-gamma*d1*CoagS_d1*3600/gr) + jx=j1*exp(-gamma*d1*CoagS_d1*3600._r8/gr) + + return + + end subroutine appformrate +end module aeronucl_mod diff --git a/src/chemistry/oslo_aero/appformrate.F90 b/src/chemistry/oslo_aero/appformrate.F90 deleted file mode 100644 index 53ef08c64d..0000000000 --- a/src/chemistry/oslo_aero/appformrate.F90 +++ /dev/null @@ -1,58 +0,0 @@ -subroutine appformrate(d1, dx, j1, jx, CoagS_dx, gr) - !-- appformrate calculates the formation rate jx of dx sized particles from the nucleation rate j1 (d1 sized particles) - !-- Formation rate is parameterized according to Lehtinen et al. (2007), JAS 38:988-994 - !-- Parameterization takes into account the loss of particles due to coagulation - !-- Growth by self-coagulation is not accounted for - !-- Typically, 1% of 1 nm nuclei make it to 12 nm - !-- Written by Risto Makkonen - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - - !-- Arguments - - real(r8), intent(in) :: d1 ! Size of nucleation-sized particles (nm) - real(r8), intent(in) :: dx ! Size of calculated apparent formation rate (nm) - real(r8), intent(in) :: j1 ! Nucleation rate of d1 sized particles (# cm-3 s-1) - real(r8), intent(out) :: jx ! Formation rate of dx sized particles (# cm-3 s-1) - real(r8), intent(in) :: CoagS_dx ! Coagulation term for nucleating particles (s-1) - real(r8), intent(in) :: gr ! Particle growth rate (nm h-1) - - !-- Local variables - - real(r8) :: m - real(r8) :: gamma - real(r8) :: CoagS_d1 ! Coagulation term for nucleating particles, calculated from CoagS_dx - - ! In Hyytiala, typically 80% of the nuclei are scavenged onto larger background particles while they grow from 1 to 3 nm - - !-- (Eq. 6) Exponent m, depends on background distribution - ! m=log(CoagS_dx/CoagS_d1)/log(dx/d1) - ! Or, if we dont want to calculate CoagS_d1, lets assume a typical value for m (-1.5 -- -1.9) and calculate CoagS_d1 from Eq.5 - m=-1.6_r8 - CoagS_d1=CoagS_dx*(d1/dx)**m - CoagS_d1=MAX(MIN(CoagS_d1,1.E2_r8),1.E-10_r8) - - gamma=(1._r8/(m+1._r8))*((dx/d1)**(m+1._r8)-1._r8) - gamma=MAX(MIN(gamma,1.E2_r8),1.E-10_r8) - - !gr=MAX(MIN(gr,1.E3_r8),1.E-5_r8) - - !-- (Eq. 7) CoagS_d1 is multiplied with 3600 to get units h-1 - !WRITE(*,*) 'gammaym:',gamma,exp(-gamma*d1*CoagS_d1*3600/gr) - jx=j1*exp(-gamma*d1*CoagS_d1*3600._r8/gr) - - return - -end - - ! First estimate: 99% of particles are lost during growth from 1 nm to 12 nm - - ! Koagtendista: - ! Siis lasketaan siella koagulaatio SO4_N -moodille. - ! Condtend lasketaan ennen coagtendia, eli naita ei ole saatavilla!! Voisiko vaihtaa jarjestysta - ! Nama on constants.F90:ssa - ! rhob(0) = rhopart(l_bc_ax) ! mostly not in use (rhorbc in stead) - ! rk(1) = effsize(l_so4_n)*1.e6_r8 - ! Pitaisko siis koagsubissa laskea oma Kp12s4 nukleaatiokoon hiukkasille, vai olettaako samaksi kuin 10nm, vai onko joku kaava diff --git a/src/physics/cam_oslo/lininterpol_mod.F90 b/src/chemistry/oslo_aero/lininterpol_mod.F90 similarity index 100% rename from src/physics/cam_oslo/lininterpol_mod.F90 rename to src/chemistry/oslo_aero/lininterpol_mod.F90 diff --git a/src/chemistry/oslo_aero/modalapp2d.F90 b/src/chemistry/oslo_aero/modalapp2d.F90 deleted file mode 100644 index 31a21aa3e5..0000000000 --- a/src/chemistry/oslo_aero/modalapp2d.F90 +++ /dev/null @@ -1,169 +0,0 @@ -module modalapp2d - public - save -contains - - subroutine modalapp2d_sub(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm,fbcm,faqm,fso4condm,fsoam) - -! Calculation of the apportionment of internally mixed SO4, BC and OC -! mass between the various background mineral and sea-salt modes. Separated -! from pmxsub into a independent subroutine by Alf Kirkevåg on September -! 12'th, 2005, and converted to 2D for use in parmix on September 15'th. -! Modified for new aerosol schemes by Alf Kirkevaag in January 2006: Now -! also Aitken-modes are subject to condensation of H2SO4, and both n and -! Aitken modes may coagulate onto the mineral/sea-salt background aerosol. -!SOA -! May 2013: The SO4(Ait) mode now takes into account condensed SOA in addition -! to H2SO4, but as long as SOA is not allowed to condense on more than one -! mode, no changes are necessary here. NB: to allow SOA to condense also on -! the BC(Ait) and/or other modes, change this code accordingly! Without any -! changes, Cam(pcols,1) = condensed SO4 onto the SO4(ait) mode still. -!SOA -! Alf Grini, february 2014 : Added info about units, -! used values calculated at initialization. -! changed in-out variables to components of derived data types (modedefs) -! defined in microphysics_oslo.F90, and corrected for mass balance error -! for SO4 due to lumping of coagulate and condensate. - - - use ppgrid, only : pcols, pver - use shr_kind_mod, only: r8 => shr_kind_r8 - - use commondefinitions - use aerosoldef - use const, only: smallNumber - use koagsub, only: normalizedCoagulationSink - use condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV - - implicit none -! -! Input arguments -! - integer , intent(in) :: ncol ! number of columns used - real(r8), intent(in) :: Nnatkbg(pcols,pver,nbmodes) ! aerosol background mode number concentration #/m3 - real(r8), intent(in) :: Ca(pcols,pver) ! internally mixed mass, tot=SO4+OC+BC - real(r8), intent(in) :: f_c(pcols,pver) ! mass fraction (OC+BC)/tot - real(r8), intent(in) :: f_bc(pcols,pver) ! mass fraction BC/(OC+BC) - real(r8), intent(in) :: f_aq(pcols,pver) ! mass fraction SO4(aq)/SO4 - real(r8), intent(in) :: f_soa(pcols,pver) ! mass fraction SOA/(POM+SOA) - real(r8), intent(in) :: f_so4_cond(pcols,pver) ! mass fraction SO4_COND/(COND+COAG) - ! - ! Output arguments - ! - real(r8), intent(out) :: Cam(pcols,pver,nbmodes) ! modal internal mass, tot=SO4+BC+OC - real(r8), intent(out) :: fcm(pcols,pver,nbmodes) ! modal mass fraction (OC+BC)/tot - real(r8), intent(out) :: fbcm(pcols,pver,nbmodes) ! modal mass fraction BC/(OC+BC) - real(r8), intent(out) :: faqm(pcols,pver,nbmodes) ! modal mass fraction SO4(aq)/SO4 - real(r8), intent(out) :: fso4condm(pcols,pver,nbmodes) !modal mass fraction (SO4(cond)/SO4(cond+coag)) - real(r8), intent(out) :: fsoam(pcols,pver,nbmodes)! modal mass fraction SOA / (POM+SOA) - - ! - ! Local variables - real(r8) condensationSinkSO4(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode - real(r8) condensationSinkOA(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode - real(r8) coagulationSink(pcols,pver,nbmodes) ![1/s] loss rate of BC through coagulation on any mode - real(r8) aquousPhaseSink(pcols,pver,nbmodes) ![-] fraction of particles available for aq. phase in any mode - - real(r8) sumCondensationSinkSO4(pcols,pver) ![1/s] sum condensation sink to all modes - real(r8) sumCondensationSinkOA(pcols,pver) ![1/s] sum condensation sink to all modes - real(r8) sumCoagulationSink(pcols,pver) ![1/s] sum coagulation sink to all modes - real(r8) sumAquousPhaseSink(pcols,pver) ![1/s] sum aquous phase sink to all modes - - real(r8) fcondkSO4(pcols,pver,nbmodes) - real(r8) fcondkOA(pcols,pver,nbmodes) - real(r8) fcoagk(pcols,pver,nbmodes) - real(r8) faqk(pcols,pver,nbmodes) - - real(r8) cabck(pcols,pver,nbmodes) ![kg/m3] bc distributed to each mode - real(r8) caock(pcols,pver,nbmodes) ![kg/m3] pom coagulate distributed to each mode - real(r8) csoacondsk(pcols,pver,nbmodes) - real(r8) caqsk(pcols,pver,nbmodes) ![kg/m3] aq phase sulfate distributed to each mode - real(r8) cso4condsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode - real(r8) cso4coagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode - real(r8) cso4condcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode - real(r8) coccondcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode - - integer :: i !counter for modes - integer :: k !counter for levels - - !Find the sink on any mode (0 is omitted here, WHY??, it does receive matter in koagsub/condtend!!)) - !Should either remove it from there or add something to it here! - do i=1,nbmodes - do k=1,pver - condensationSinkSO4(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_H2SO4)*Nnatkbg(:ncol,k,i) - condensationSinkOA(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_ORG_SV)*Nnatkbg(:ncol,k,i) - coagulationSink(:ncol,k,i) = normalizedCoagulationSink(i,MODE_IDX_BC_NUC)*Nnatkbg(:ncol,k,i) !use a typical coagulator (BC_NUC) - aquousPhaseSink(:ncol,k,i) = numberFractionAvailableAqChem(i)*Nnatkbg(:ncol,k,i) !aq phase sink to this mode - end do - enddo - - !Sum the sinks - sumCondensationSinkSO4(:,:) = 0.0_r8 - sumCondensationSinkOA(:,:) = 0.0_r8 - sumCoagulationSink(:,:) = 0.0_r8 - sumAquousPhaseSink(:,:) = 0.0_r8 - do i=1,nbmodes - do k=1,pver - sumCondensationSinkSO4(:ncol,k) = sumCondensationSinkSO4(:ncol,k) + condensationSinkSO4(:ncol,k,i) - sumCondensationSinkOA(:ncol,k) = sumCondensationSinkOA(:ncol,k) + condensationSinkOA(:ncol,k,i) - sumCoagulationSink(:ncol,k) = sumCoagulationSink(:ncol,k) + coagulationSink(:ncol,k,i) - sumAquousPhaseSink(:ncol,k) = sumAquousPhaseSink(:ncol,k) + aquousPhaseSink(:ncol,k,i) - end do - end do - - ! And finally the contribution from each mode relative to the totals are calculated, - ! assuming that the apportionment of mass for the first iteration (in time) is representative - ! for the whole apportionment process (which is ok for small and moderate masses added): - do i=1,nbmodes - do k=1,pver - !Get the fraction of contribution per process per mode - fcondkSO4(:ncol,k,i)=condensationSinkSO4(:ncol,k,i)/(sumCondensationSinkSO4(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode - fcondkOA(:ncol,k,i)=condensationSinkOA(:ncol,k,i)/(sumCondensationSinkOA(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode - fcoagk(:ncol,k,i)=coagulationSink(:ncol,k,i)/(sumCoagulationSink(:ncol,k)+1.e-100_r8) !fraction of coagulation sink in this mode - faqk(:ncol,k,i)=aquousPhaseSink(:ncol,k,i)/(sumAquousPhaseSink(:ncol,k)+1.e-100_r8) !fraction of aquous phase sink in this mode - - !BC coagulate to this mode [kg/m3] - cabck(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*f_bc(:ncol,k)*Ca(:ncol,k) - - !OC coagulate to this mode [kg/m3] - caock(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*(1.0_r8-f_soa(:ncol,k))*Ca(:ncol,k) - - !SOA condensate to this mode [kg/m3] - csoacondsk(:ncol,k,i) = fcondkOA(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*f_soa(:ncol,k)*Ca(:ncol,k) - - !Aquous phase SO4 to this mode [kg/m3] - caqsk(:ncol,k,i)=faqk(:ncol,k,i)*f_aq(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) - - !so4 condensate - cso4condsk(:ncol,k,i)=fcondkSO4(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*f_so4_cond(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) - - !soa coagulate - cso4coagsk(:ncol,k,i) = fcoagk(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*(1.0_r8-f_so4_cond(:ncol,k))*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) ![kg/m3] so4 coagulate - end do - enddo - - !The tables take as input the combined coagulate and condensate (both POM and SOA) - !The activation needs them separately for mass balance! - cso4condcoagsk(:ncol,:,:) = cso4condsk(:ncol,:,:) + cso4coagsk(:ncol,:,:) - coccondcoagsk(:ncol,:,:) = caock(:ncol,:,:) + csoacondsk(:ncol,:,:) - - do i=1,nbmodes - do k=1,pver - Cam(:ncol,k,i)= cabck(:ncol,k,i) & !BC - + coccondcoagsk(:ncol,k,i) & !OM - + caqsk(:ncol,k,i) + cso4condcoagsk(:ncol,k,i) + smallNumber!SO4 ==> !total process mode mass to mode i - - fcm(:ncol,k,i)=(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i))/(Cam(:ncol,k,i)+smallNumber) !fraction of mass being carbon (oc or bc) - fbcm(:ncol,k,i)=cabck(:ncol,k,i)/(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i)+smallNumber) !fraction of carbon mass being bc - faqm(:ncol,k,i)=caqsk(:ncol,k,i)/(caqsk(:ncol,k,i)+cso4condcoagsk(:ncol,k,i)+smallNumber) !fraction of sulfate being aq phase - - !Not needed for tables, but for mass balances in activation - fso4condm(:ncol,k,i) = cso4condsk(:ncol,k,i)/(cso4condcoagsk(:ncol,k,i) + smallNumber) !fraction of cond+coag which is coag - fsoam(:ncol,k,i) = csoacondsk(:ncol,k,i)/(coccondcoagsk(:ncol,k,i) + smallNumber) !fraction of OC which is SOA - end do - enddo - - return -end subroutine modalapp2d_sub - -end module modalapp2d diff --git a/src/physics/cam_oslo/opttab.F90 b/src/chemistry/oslo_aero/opttab.F90 similarity index 100% rename from src/physics/cam_oslo/opttab.F90 rename to src/chemistry/oslo_aero/opttab.F90 diff --git a/src/physics/cam_oslo/oslo_control.F90 b/src/chemistry/oslo_aero/oslo_control.F90 similarity index 100% rename from src/physics/cam_oslo/oslo_control.F90 rename to src/chemistry/oslo_aero/oslo_control.F90 diff --git a/src/chemistry/oslo_aero/parmix_progncdnc.F90 b/src/chemistry/oslo_aero/parmix_progncdnc.F90 index 22e621d9b8..c8279e8bca 100644 --- a/src/chemistry/oslo_aero/parmix_progncdnc.F90 +++ b/src/chemistry/oslo_aero/parmix_progncdnc.F90 @@ -1,23 +1,22 @@ module parmix_progncdnc - use const, only : volumeToNumber,smallNumber - use modalapp2d - use physconst, only: density_water =>rhoh2o, molecularWeightWater=>mwh2o - use ppgrid, only : pcols, pver - use shr_kind_mod, only: r8 => shr_kind_r8 + use const , only : volumeToNumber,smallNumber + use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o + use ppgrid , only : pcols, pver + use shr_kind_mod , only: r8 => shr_kind_r8 use commondefinitions use aerosoldef - use physconst, only: pi - use constituents, only: pcnst, cnst_name - use intlog, only : intlog1to3_sub, intlog4_sub, intlog5to10_sub - use constituents, only: cnst_name + use physconst , only: pi + use constituents , only: pcnst, cnst_name + use intlog , only : intlog1to3_sub, intlog4_sub, intlog5to10_sub + use constituents , only: cnst_name implicit none public - save !Size of molecule-layer which defines when particles are coated real(r8), parameter :: coatingLimit = 2.e-9_r8 ![m] + !The fraction of soluble material required in a components before it !will add to any coating real(r8), parameter :: solubleMassFractionCoatingLimit=0.50_r8 @@ -50,14 +49,10 @@ subroutine parmix_progncdnc_sub( & ,hygroscopicity & !O [mol/mol] ,lnsigma & !O [-] log sigma ,hasAerosol & !I [t/f] do we have this type of aerosol here? -!++ MH_2015/04/10 ,volumeCore & ,volumeCoat & -!-- MH_2015/04/10 ) - implicit none - !input integer, intent(in) :: ncol !Number of columns used in chunk real(r8), intent(in) :: mmr(pcols,pver,pcnst) @@ -81,10 +76,8 @@ subroutine parmix_progncdnc_sub( & real(r8),intent(out) :: f_bc(pcols,pver) real(r8),intent(out) :: f_so4_cond(pcols,pver) real(r8),intent(out) :: f_soa(pcols,pver) -!++ MH_2015/04/10 real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) -!-- MH_2015/04/10 real(r8) :: f_aitbc(pcols,pver) ! [-] bc fraction in the coated bc-oc mode real(r8) :: f_nbc(pcols,pver) ! [-] mass fraction of bc in uncoated bc/oc mode @@ -139,10 +132,8 @@ subroutine parmix_progncdnc_sub( & ,hasAerosol & ,hygroscopicity & ,volumeConcentration & -!++ MH_2015/04/10 ,volumeCore & ,volumeCoat & -!-- MH_2015/04/10 ) !Do the interpolation to new modes @@ -156,8 +147,8 @@ subroutine parmix_progncdnc_sub( & ,f_bcm & ,f_aqm & ,f_aitbc & !I [frc] bc fraction in int mix bc/oc mode - ,lnSigma & - ) + ,lnSigma & + ) end subroutine parmix_progncdnc_sub @@ -346,10 +337,8 @@ subroutine calculateHygroscopicity( ncol & ,hasAerosol & ,hygroscopicity & ,volumeConcentration & -!++ MH_2015/04/10 ,volumeCore & ,volumeCoat & -!-- MH_2015/04/10 ) !All theory in this subroutine is from @@ -377,21 +366,16 @@ subroutine calculateHygroscopicity( ncol & real(r8) :: hygroscopicityAvg(pcols,pver) real(r8) :: hygroscopicityCoat(pcols,pver) real(r8) :: massConcentrationTracerInMode(pcols,pver) - !++ MH_2015/04/10 real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) ![m3] real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) ![m3] - !-- MH_2015/04/10 real(r8) :: averageRadiusCore(pcols,pver) ![m] real(r8) :: averageRadiusTotal(pcols,pver) ![m] integer :: kcomp !counter for modes integer :: l !counter for components integer :: tracerIndex - integer :: k !counter for levels - integer :: i - !initialize hygroscopicity(:,:,:) = 0.0_r8 volumeConcentration(:,:,:)=0.0_r8 @@ -639,194 +623,357 @@ end subroutine addModeHygroscopicity !**************************************************************** subroutine doLognormalInterpolation(ncol & - ,numberConcentration & - ,hasAerosol & - ,cam & - ,volumeConcentration & - ,f_c & - ,f_acm & - ,f_bcm & - ,f_aqm & - ,f_aitbc & - ,lnSigma & - ) - - implicit none - - !input - integer, intent(in) :: ncol - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) - logical, intent(in) :: hasAerosol(pcols,pver,nmodes) - real(r8), intent(in) :: cam(pcols,pver,nbmodes) ![kg/m3] total added mass per mode - real(r8), intent(in) :: f_c(pcols,pver) ![frc] fraction of carbon in total add-on - real(r8), intent(in) :: f_acm(pcols,pver,nbmodes) ![frc] fraction of carbon per mode (in add-on) - real(r8), intent(in) :: f_bcm(pcols,pver,nbmodes) ![frc] fraction of bc in carbon per mode - real(r8), intent(in) :: f_aqm(pcols,pver,nbmodes) ![frc] fraction of aq in sulfate added - real(r8), intent(in) :: f_aitbc(pcols,pver) ![frc] fraction of bc in coated bc/oc mode - - !output - real(r8), intent(inout) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration - real(r8), intent(out) :: lnsigma(pcols,pver,nmodes) ![-] log (base e) of std. dev - - - !work arrays - real(r8) :: nconccm3(pcols,pver) - real(r8) :: camUg(pcols,pver) - real(r8) :: log10sig(pcols,pver) ![-] logarithm (base 10) of look up tables - real(r8), dimension(pcols,pver,nbmodes) :: cxs ![ug/m3] NOTE NON-SI UNITS non-allocated mass - !real(r8), dimension(pcols,pver) :: cxstot ![kg/m3] non allocated mass - integer, dimension(pcols) :: ind ![idx] index in mapping (not really used) - real(r8), dimension(pcols,pver) :: radius_tmp ![m] radius in look up tables - real(r8) :: f_ocm(pcols,pver,4) ! [-] fraction of added mass which is either SOA condensate or OC coagulate - integer :: iloop - integer :: kcomp - integer :: i - integer :: k - - - !total mass not allocated to any mode - !this is non-zero if the look-up table can not cope with all the add-on mass - !cxstot(:,:) = 0.0_r8 - - !Remove this later! - do i=1,ncol - ind(i)=i - end do - -! calculate fraction of added mass which is either SOA condensate or OC coagulate, -! which in AeroTab are both treated as condensate for kcomp=1-4 - do kcomp=1,4 + ,numberConcentration & + ,hasAerosol & + ,cam & + ,volumeConcentration & + ,f_c & + ,f_acm & + ,f_bcm & + ,f_aqm & + ,f_aitbc & + ,lnSigma & + ) + + implicit none + + !input + integer, intent(in) :: ncol + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) + logical, intent(in) :: hasAerosol(pcols,pver,nmodes) + real(r8), intent(in) :: cam(pcols,pver,nbmodes) ![kg/m3] total added mass per mode + real(r8), intent(in) :: f_c(pcols,pver) ![frc] fraction of carbon in total add-on + real(r8), intent(in) :: f_acm(pcols,pver,nbmodes) ![frc] fraction of carbon per mode (in add-on) + real(r8), intent(in) :: f_bcm(pcols,pver,nbmodes) ![frc] fraction of bc in carbon per mode + real(r8), intent(in) :: f_aqm(pcols,pver,nbmodes) ![frc] fraction of aq in sulfate added + real(r8), intent(in) :: f_aitbc(pcols,pver) ![frc] fraction of bc in coated bc/oc mode + + !output + real(r8), intent(inout) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration + real(r8), intent(out) :: lnsigma(pcols,pver,nmodes) ![-] log (base e) of std. dev + + + !work arrays + real(r8) :: nconccm3(pcols,pver) + real(r8) :: camUg(pcols,pver) + real(r8) :: log10sig(pcols,pver) ![-] logarithm (base 10) of look up tables + real(r8), dimension(pcols,pver,nbmodes) :: cxs ![ug/m3] NOTE NON-SI UNITS non-allocated mass + !real(r8), dimension(pcols,pver) :: cxstot ![kg/m3] non allocated mass + integer, dimension(pcols) :: ind ![idx] index in mapping (not really used) + real(r8), dimension(pcols,pver) :: radius_tmp ![m] radius in look up tables + real(r8) :: f_ocm(pcols,pver,4) ! [-] fraction of added mass which is either SOA condensate or OC coagulate + integer :: iloop + integer :: kcomp + integer :: i + integer :: k + + + !total mass not allocated to any mode + !this is non-zero if the look-up table can not cope with all the add-on mass + !cxstot(:,:) = 0.0_r8 + + !Remove this later! + do i=1,ncol + ind(i)=i + end do + + ! calculate fraction of added mass which is either SOA condensate or OC coagulate, + ! which in AeroTab are both treated as condensate for kcomp=1-4 + do kcomp=1,4 do k=1,pver - do i=1,ncol - f_ocm(i,k,kcomp) = f_acm(i,k,kcomp)*(1.0_r8-f_bcm(i,k,kcomp)) - enddo + do i=1,ncol + f_ocm(i,k,kcomp) = f_acm(i,k,kcomp)*(1.0_r8-f_bcm(i,k,kcomp)) + enddo enddo - enddo - - do iloop=1,1 ! loop over i>1 for testing CPU use in intlog* - - !Go through all "background" size-modes (kcomp=1-10) - do kcomp=1,nbmodes - - camUg(:,:) = cam(:,:,kcomp)*1.e9_r8 - nConccm3(:,:) = 1e-6_r8*numberConcentration(:,:,kcomp) - - !Calculate growth from knowing added process specific internally mixed mass to each background mode - !(level sent but not needed, and kcomp not needed for intlog4_sub) - - if( kcomp .ge. MODE_IDX_SO4SOA_AIT .and. kcomp .le. MODE_IDX_BC_AIT)then ! kcomp=1,2 + enddo + + do iloop=1,1 ! loop over i>1 for testing CPU use in intlog* + + !Go through all "background" size-modes (kcomp=1-10) + do kcomp=1,nbmodes + + camUg(:,:) = cam(:,:,kcomp)*1.e9_r8 + nConccm3(:,:) = 1e-6_r8*numberConcentration(:,:,kcomp) + + !Calculate growth from knowing added process specific internally mixed mass to each background mode + !(level sent but not needed, and kcomp not needed for intlog4_sub) + + if( kcomp .ge. MODE_IDX_SO4SOA_AIT .and. kcomp .le. MODE_IDX_BC_AIT)then ! kcomp=1,2 + + do k=1,pver + call intlog1to3_sub( & + ncol & !I number of points + , ind & !I [idx] mappoing of points to use + , kcomp & !I [idx] mode index + , camUg(:,k) & !I [ug/m3] mass concentration + , nConccm3(:,k) & !I [#/cm3] number concentration + , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. + , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table + , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance + , radius_tmp(:,k) & !O [m] Number median radius + ) + + end do !loop on levels + + else if(kcomp .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT)then ! kcomp=4 + + do k=1,pver + call intlog4_sub( & + ncol & !I number of points + , ind & !I [idx] mappoing of points to use + , kcomp & !I [idx] mode index + , camUg(:,k) & !I [ug/m3] mass concentration + , nConccm3(:,k) & !I [#/cm3] number concentration + , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. + , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous + , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table + , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance + , radius_tmp(:,k) & !O [m] Number median radius + ) + end do + + else if (kcomp .ge. MODE_IDX_SO4_AC .and. kcomp .le. MODE_IDX_SS_A3)then ! kcomp=5-10 + + do k=1,pver + call intlog5to10_sub( & + ncol & !I [nbr] number of points used + , ind & !I [mapping] (not used) + , kcomp & !I [mode index] + , camUg(:,k) & !I [ug/m3] mass concentration + , nConccm3(:,k) & !I [#/cm3] number concentration + , f_acm(:,k,kcomp) & !I [frc] fraction of aerosol which is carbon + , f_bcm(:,k,kcomp) & !I [frc] fraction of carbon which is bc + , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous + , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table (not given to any mode) + , log10sig(:,k) & !O logarithm (base 10) sigma, is later thrown away begause of volume balance + , radius_tmp(:,k) & !O [m] Number median radius + ) + end do ! k + + endif + + !initialize + lnsigma(:,:,kcomp) = log(2.0_r8) + + !The whole point of the interpolation routines is to get the new sigma ==> so trust the sigma + + !This means that in order to conserve the volume (which is known), we have to throw away + !the number concentration. Should create a diagnostic or a warning if number concenration is very different + !from the original number concentration since in principal, the number concentration is + !also conserved! + do k=1,pver + !Don't change number concentration unless "hasAerosol" is true + where(hasAerosol(:ncol,k,kcomp)) + + lnsigma(:ncol,k,kcomp) = ln10*log10sig(:ncol,k) + + numberConcentration(:ncol,k,kcomp) = volumeConcentration(:ncol,k,kcomp)*6.0_r8/pi & + /(2.0_r8*radius_tmp(:ncol,k))**3 & + *DEXP(-4.5_r8*lnsigma(:ncol,k,kcomp)*lnsigma(:ncol,k,kcomp)) + + !==> Now we have a set of n, vol, sigma which is consistent and gives back whatever the + !lookup tables told us! If the look up tables were conserving volume we didn't have to do + !the step just above!! + + !Sum up all mass which was not added to any mode (mass exceeding the max limit in the look-up tables) + !cxstot(:ncol,k) = cxstot(:ncol,k) + cxs(:ncol,k,kcomp)*1.e-9_r8 ! ug/m3 ==> kg/m3 + + end where + end do + + end do !kcomp + + !The modes which do not have any added aerosol: + do kcomp=nbmodes+1,nmodes + do k=1,pver + lnsigma(:ncol,k,kcomp) = log(originalSigma(kcomp)) + end do + end do + + !AK (fxm): "unactivated" code below... + !Excessive internally mixed process mass added to the background modes (exceeding the max limit in the look-up tables) + !is instead added to / lumped with the externally mixed non-background modes (kcomp=11,12,14) + !numberConcentration(:,:,MODE_IDX_SO4_NUC) = numberConcentration(:,:,MODE_IDX_SO4_NUC) & + ! + (volumeToNumber(MODE_IDX_SO4_NUC) & !excess sulfate mass is moved to this mode + ! *RESHAPE(cxstot,(/pcols,pver/)) & + ! *(1.0_r8-f_c(:,:))/rhopart(l_so4_n)) + + !numberConcentration(:,:,MODE_IDX_BC_NUC) = numberConcentration(:,:,MODE_IDX_BC_NUC) & + ! + (volumeToNumber(MODE_IDX_BC_NUC) & !excess carbon mass is moved to this mode + ! * RESHAPE(cxstot,(/pcols,pver/)) & + ! * f_c(:,:)/rhopart(l_bc_n)) + + !SKIP LUMPING OF OC-MODE TO MODE MODE_IDX_LUMPED ORGANICS SINCE THIS WILL MESS UP THE HASAEROSOL-MASK! + ! modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) = efact_omn & !excess OM mass is moved to this mode (originally kcomp=13) + ! * (modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) + cxstot(i)*modedefs(i)%f_c*(1.0_r8-modedefs(i)%f_bc)) + + + enddo ! iloop - do k=1,pver - call intlog1to3_sub( & - ncol & !I number of points - , ind & !I [idx] mappoing of points to use - , kcomp & !I [idx] mode index - , camUg(:,k) & !I [ug/m3] mass concentration - , nConccm3(:,k) & !I [#/cm3] number concentration - , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. - , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table - , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance - , radius_tmp(:,k) & !O [m] Number median radius - ) - - end do !loop on levels - - else if(kcomp .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT)then ! kcomp=4 - - do k=1,pver - call intlog4_sub( & - ncol & !I number of points - , ind & !I [idx] mappoing of points to use - , kcomp & !I [idx] mode index - , camUg(:,k) & !I [ug/m3] mass concentration - , nConccm3(:,k) & !I [#/cm3] number concentration - , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. - , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous - , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table - , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance - , radius_tmp(:,k) & !O [m] Number median radius - ) - end do - - else if (kcomp .ge. MODE_IDX_SO4_AC .and. kcomp .le. MODE_IDX_SS_A3)then ! kcomp=5-10 - - do k=1,pver - call intlog5to10_sub( & - ncol & !I [nbr] number of points used - , ind & !I [mapping] (not used) - , kcomp & !I [mode index] - , camUg(:,k) & !I [ug/m3] mass concentration - , nConccm3(:,k) & !I [#/cm3] number concentration - , f_acm(:,k,kcomp) & !I [frc] fraction of aerosol which is carbon - , f_bcm(:,k,kcomp) & !I [frc] fraction of carbon which is bc - , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous - , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table (not given to any mode) - , log10sig(:,k) & !O logarithm (base 10) sigma, is later thrown away begause of volume balance - , radius_tmp(:,k) & !O [m] Number median radius - ) - end do ! k - - endif - - !initialize - lnsigma(:,:,kcomp) = log(2.0_r8) - - !The whole point of the interpolation routines is to get the new sigma ==> so trust the sigma - - !This means that in order to conserve the volume (which is known), we have to throw away - !the number concentration. Should create a diagnostic or a warning if number concenration is very different - !from the original number concentration since in principal, the number concentration is - !also conserved! - do k=1,pver - !Don't change number concentration unless "hasAerosol" is true - where(hasAerosol(:ncol,k,kcomp)) + end subroutine doLognormalInterpolation - lnsigma(:ncol,k,kcomp) = ln10*log10sig(:ncol,k) - numberConcentration(:ncol,k,kcomp) = volumeConcentration(:ncol,k,kcomp)*6.0_r8/pi & - /(2.0_r8*radius_tmp(:ncol,k))**3 & - *DEXP(-4.5_r8*lnsigma(:ncol,k,kcomp)*lnsigma(:ncol,k,kcomp)) + subroutine modalapp2d_sub(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm,fbcm,faqm,fso4condm,fsoam) + + ! Calculation of the apportionment of internally mixed SO4, BC and OC + ! mass between the various background mineral and sea-salt modes. Separated + ! from pmxsub into a independent subroutine by Alf Kirkevåg on September + ! 12'th, 2005, and converted to 2D for use in parmix on September 15'th. + ! Modified for new aerosol schemes by Alf Kirkevaag in January 2006: Now + ! also Aitken-modes are subject to condensation of H2SO4, and both n and + ! Aitken modes may coagulate onto the mineral/sea-salt background aerosol. + !SOA + ! May 2013: The SO4(Ait) mode now takes into account condensed SOA in addition + ! to H2SO4, but as long as SOA is not allowed to condense on more than one + ! mode, no changes are necessary here. NB: to allow SOA to condense also on + ! the BC(Ait) and/or other modes, change this code accordingly! Without any + ! changes, Cam(pcols,1) = condensed SO4 onto the SO4(ait) mode still. + !SOA + ! Alf Grini, february 2014 : Added info about units, + ! used values calculated at initialization. + ! changed in-out variables to components of derived data types (modedefs) + ! defined in microphysics_oslo.F90, and corrected for mass balance error + ! for SO4 due to lumping of coagulate and condensate. + + + use ppgrid, only : pcols, pver + use shr_kind_mod, only: r8 => shr_kind_r8 + + use commondefinitions + use aerosoldef + use const, only: smallNumber + use koagsub, only: normalizedCoagulationSink + use condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV + + implicit none + ! + ! Input arguments + ! + integer , intent(in) :: ncol ! number of columns used + real(r8), intent(in) :: Nnatkbg(pcols,pver,nbmodes) ! aerosol background mode number concentration #/m3 + real(r8), intent(in) :: Ca(pcols,pver) ! internally mixed mass, tot=SO4+OC+BC + real(r8), intent(in) :: f_c(pcols,pver) ! mass fraction (OC+BC)/tot + real(r8), intent(in) :: f_bc(pcols,pver) ! mass fraction BC/(OC+BC) + real(r8), intent(in) :: f_aq(pcols,pver) ! mass fraction SO4(aq)/SO4 + real(r8), intent(in) :: f_soa(pcols,pver) ! mass fraction SOA/(POM+SOA) + real(r8), intent(in) :: f_so4_cond(pcols,pver) ! mass fraction SO4_COND/(COND+COAG) + ! + ! Output arguments + ! + real(r8), intent(out) :: Cam(pcols,pver,nbmodes) ! modal internal mass, tot=SO4+BC+OC + real(r8), intent(out) :: fcm(pcols,pver,nbmodes) ! modal mass fraction (OC+BC)/tot + real(r8), intent(out) :: fbcm(pcols,pver,nbmodes) ! modal mass fraction BC/(OC+BC) + real(r8), intent(out) :: faqm(pcols,pver,nbmodes) ! modal mass fraction SO4(aq)/SO4 + real(r8), intent(out) :: fso4condm(pcols,pver,nbmodes) !modal mass fraction (SO4(cond)/SO4(cond+coag)) + real(r8), intent(out) :: fsoam(pcols,pver,nbmodes)! modal mass fraction SOA / (POM+SOA) + + ! + ! Local variables + real(r8) condensationSinkSO4(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode + real(r8) condensationSinkOA(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode + real(r8) coagulationSink(pcols,pver,nbmodes) ![1/s] loss rate of BC through coagulation on any mode + real(r8) aquousPhaseSink(pcols,pver,nbmodes) ![-] fraction of particles available for aq. phase in any mode + + real(r8) sumCondensationSinkSO4(pcols,pver) ![1/s] sum condensation sink to all modes + real(r8) sumCondensationSinkOA(pcols,pver) ![1/s] sum condensation sink to all modes + real(r8) sumCoagulationSink(pcols,pver) ![1/s] sum coagulation sink to all modes + real(r8) sumAquousPhaseSink(pcols,pver) ![1/s] sum aquous phase sink to all modes + + real(r8) fcondkSO4(pcols,pver,nbmodes) + real(r8) fcondkOA(pcols,pver,nbmodes) + real(r8) fcoagk(pcols,pver,nbmodes) + real(r8) faqk(pcols,pver,nbmodes) + + real(r8) cabck(pcols,pver,nbmodes) ![kg/m3] bc distributed to each mode + real(r8) caock(pcols,pver,nbmodes) ![kg/m3] pom coagulate distributed to each mode + real(r8) csoacondsk(pcols,pver,nbmodes) + real(r8) caqsk(pcols,pver,nbmodes) ![kg/m3] aq phase sulfate distributed to each mode + real(r8) cso4condsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode + real(r8) cso4coagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode + real(r8) cso4condcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode + real(r8) coccondcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode + + integer :: i !counter for modes + integer :: k !counter for levels + + !Find the sink on any mode (0 is omitted here, WHY??, it does receive matter in koagsub/condtend!!)) + !Should either remove it from there or add something to it here! + do i=1,nbmodes + do k=1,pver + condensationSinkSO4(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_H2SO4)*Nnatkbg(:ncol,k,i) + condensationSinkOA(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_ORG_SV)*Nnatkbg(:ncol,k,i) + coagulationSink(:ncol,k,i) = normalizedCoagulationSink(i,MODE_IDX_BC_NUC)*Nnatkbg(:ncol,k,i) !use a typical coagulator (BC_NUC) + aquousPhaseSink(:ncol,k,i) = numberFractionAvailableAqChem(i)*Nnatkbg(:ncol,k,i) !aq phase sink to this mode + end do + enddo + + !Sum the sinks + sumCondensationSinkSO4(:,:) = 0.0_r8 + sumCondensationSinkOA(:,:) = 0.0_r8 + sumCoagulationSink(:,:) = 0.0_r8 + sumAquousPhaseSink(:,:) = 0.0_r8 + do i=1,nbmodes + do k=1,pver + sumCondensationSinkSO4(:ncol,k) = sumCondensationSinkSO4(:ncol,k) + condensationSinkSO4(:ncol,k,i) + sumCondensationSinkOA(:ncol,k) = sumCondensationSinkOA(:ncol,k) + condensationSinkOA(:ncol,k,i) + sumCoagulationSink(:ncol,k) = sumCoagulationSink(:ncol,k) + coagulationSink(:ncol,k,i) + sumAquousPhaseSink(:ncol,k) = sumAquousPhaseSink(:ncol,k) + aquousPhaseSink(:ncol,k,i) + end do + end do + + ! And finally the contribution from each mode relative to the totals are calculated, + ! assuming that the apportionment of mass for the first iteration (in time) is representative + ! for the whole apportionment process (which is ok for small and moderate masses added): + do i=1,nbmodes + do k=1,pver + !Get the fraction of contribution per process per mode + fcondkSO4(:ncol,k,i)=condensationSinkSO4(:ncol,k,i)/(sumCondensationSinkSO4(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode + fcondkOA(:ncol,k,i)=condensationSinkOA(:ncol,k,i)/(sumCondensationSinkOA(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode + fcoagk(:ncol,k,i)=coagulationSink(:ncol,k,i)/(sumCoagulationSink(:ncol,k)+1.e-100_r8) !fraction of coagulation sink in this mode + faqk(:ncol,k,i)=aquousPhaseSink(:ncol,k,i)/(sumAquousPhaseSink(:ncol,k)+1.e-100_r8) !fraction of aquous phase sink in this mode - !==> Now we have a set of n, vol, sigma which is consistent and gives back whatever the - !lookup tables told us! If the look up tables were conserving volume we didn't have to do - !the step just above!! + !BC coagulate to this mode [kg/m3] + cabck(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*f_bc(:ncol,k)*Ca(:ncol,k) - !Sum up all mass which was not added to any mode (mass exceeding the max limit in the look-up tables) - !cxstot(:ncol,k) = cxstot(:ncol,k) + cxs(:ncol,k,kcomp)*1.e-9_r8 ! ug/m3 ==> kg/m3 - - end where - end do + !OC coagulate to this mode [kg/m3] + caock(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*(1.0_r8-f_soa(:ncol,k))*Ca(:ncol,k) - end do !kcomp + !SOA condensate to this mode [kg/m3] + csoacondsk(:ncol,k,i) = fcondkOA(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*f_soa(:ncol,k)*Ca(:ncol,k) - !The modes which do not have any added aerosol: - do kcomp=nbmodes+1,nmodes - do k=1,pver - lnsigma(:ncol,k,kcomp) = log(originalSigma(kcomp)) - end do - end do - - !AK (fxm): "unactivated" code below... - !Excessive internally mixed process mass added to the background modes (exceeding the max limit in the look-up tables) - !is instead added to / lumped with the externally mixed non-background modes (kcomp=11,12,14) - !numberConcentration(:,:,MODE_IDX_SO4_NUC) = numberConcentration(:,:,MODE_IDX_SO4_NUC) & - ! + (volumeToNumber(MODE_IDX_SO4_NUC) & !excess sulfate mass is moved to this mode - ! *RESHAPE(cxstot,(/pcols,pver/)) & - ! *(1.0_r8-f_c(:,:))/rhopart(l_so4_n)) - - !numberConcentration(:,:,MODE_IDX_BC_NUC) = numberConcentration(:,:,MODE_IDX_BC_NUC) & - ! + (volumeToNumber(MODE_IDX_BC_NUC) & !excess carbon mass is moved to this mode - ! * RESHAPE(cxstot,(/pcols,pver/)) & - ! * f_c(:,:)/rhopart(l_bc_n)) - - !SKIP LUMPING OF OC-MODE TO MODE MODE_IDX_LUMPED ORGANICS SINCE THIS WILL MESS UP THE HASAEROSOL-MASK! - ! modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) = efact_omn & !excess OM mass is moved to this mode (originally kcomp=13) - ! * (modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) + cxstot(i)*modedefs(i)%f_c*(1.0_r8-modedefs(i)%f_bc)) + !Aquous phase SO4 to this mode [kg/m3] + caqsk(:ncol,k,i)=faqk(:ncol,k,i)*f_aq(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) + !so4 condensate + cso4condsk(:ncol,k,i)=fcondkSO4(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*f_so4_cond(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) - enddo ! iloop + !soa coagulate + cso4coagsk(:ncol,k,i) = fcoagk(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*(1.0_r8-f_so4_cond(:ncol,k))*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) ![kg/m3] so4 coagulate + end do + enddo + !The tables take as input the combined coagulate and condensate (both POM and SOA) + !The activation needs them separately for mass balance! + cso4condcoagsk(:ncol,:,:) = cso4condsk(:ncol,:,:) + cso4coagsk(:ncol,:,:) + coccondcoagsk(:ncol,:,:) = caock(:ncol,:,:) + csoacondsk(:ncol,:,:) - end subroutine doLognormalInterpolation + do i=1,nbmodes + do k=1,pver + Cam(:ncol,k,i)= cabck(:ncol,k,i) & !BC + + coccondcoagsk(:ncol,k,i) & !OM + + caqsk(:ncol,k,i) + cso4condcoagsk(:ncol,k,i) + smallNumber!SO4 ==> !total process mode mass to mode i + + fcm(:ncol,k,i)=(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i))/(Cam(:ncol,k,i)+smallNumber) !fraction of mass being carbon (oc or bc) + fbcm(:ncol,k,i)=cabck(:ncol,k,i)/(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i)+smallNumber) !fraction of carbon mass being bc + faqm(:ncol,k,i)=caqsk(:ncol,k,i)/(caqsk(:ncol,k,i)+cso4condcoagsk(:ncol,k,i)+smallNumber) !fraction of sulfate being aq phase + + !Not needed for tables, but for mass balances in activation + fso4condm(:ncol,k,i) = cso4condsk(:ncol,k,i)/(cso4condcoagsk(:ncol,k,i) + smallNumber) !fraction of cond+coag which is coag + fsoam(:ncol,k,i) = csoacondsk(:ncol,k,i)/(coccondcoagsk(:ncol,k,i) + smallNumber) !fraction of OC which is SOA + end do + enddo + + return + end subroutine modalapp2d_sub end module parmix_progncdnc diff --git a/src/physics/cam_oslo/pmxsub.F90 b/src/chemistry/oslo_aero/pmxsub.F90 similarity index 100% rename from src/physics/cam_oslo/pmxsub.F90 rename to src/chemistry/oslo_aero/pmxsub.F90 diff --git a/src/chemistry/oslo_aero/dust_model.F90 b/src/physics/cam_oslo/dust_model.F90 similarity index 100% rename from src/chemistry/oslo_aero/dust_model.F90 rename to src/physics/cam_oslo/dust_model.F90 diff --git a/src/chemistry/oslo_aero/dust_sediment_mod.F90 b/src/physics/cam_oslo/dust_sediment_mod.F90 similarity index 100% rename from src/chemistry/oslo_aero/dust_sediment_mod.F90 rename to src/physics/cam_oslo/dust_sediment_mod.F90 diff --git a/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 b/src/physics/cam_oslo/hetfrz_classnuc_oslo.F90 similarity index 100% rename from src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 rename to src/physics/cam_oslo/hetfrz_classnuc_oslo.F90 diff --git a/src/chemistry/oslo_aero/microp_aero.F90 b/src/physics/cam_oslo/microp_aero.F90 similarity index 100% rename from src/chemistry/oslo_aero/microp_aero.F90 rename to src/physics/cam_oslo/microp_aero.F90 diff --git a/src/chemistry/oslo_aero/mo_chm_diags.F90 b/src/physics/cam_oslo/mo_chm_diags.F90 similarity index 100% rename from src/chemistry/oslo_aero/mo_chm_diags.F90 rename to src/physics/cam_oslo/mo_chm_diags.F90 diff --git a/src/chemistry/oslo_aero/mo_drydep.F90 b/src/physics/cam_oslo/mo_drydep.F90 similarity index 100% rename from src/chemistry/oslo_aero/mo_drydep.F90 rename to src/physics/cam_oslo/mo_drydep.F90 diff --git a/src/chemistry/oslo_aero/mo_extfrc.F90 b/src/physics/cam_oslo/mo_extfrc.F90 similarity index 100% rename from src/chemistry/oslo_aero/mo_extfrc.F90 rename to src/physics/cam_oslo/mo_extfrc.F90 diff --git a/src/chemistry/oslo_aero/mo_gas_phase_chemdr.F90 b/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 similarity index 100% rename from src/chemistry/oslo_aero/mo_gas_phase_chemdr.F90 rename to src/physics/cam_oslo/mo_gas_phase_chemdr.F90 diff --git a/src/chemistry/oslo_aero/mo_neu_wetdep.F90 b/src/physics/cam_oslo/mo_neu_wetdep.F90 similarity index 100% rename from src/chemistry/oslo_aero/mo_neu_wetdep.F90 rename to src/physics/cam_oslo/mo_neu_wetdep.F90 diff --git a/src/chemistry/oslo_aero/mo_setsox.F90 b/src/physics/cam_oslo/mo_setsox.F90 similarity index 100% rename from src/chemistry/oslo_aero/mo_setsox.F90 rename to src/physics/cam_oslo/mo_setsox.F90 diff --git a/src/chemistry/oslo_aero/mo_srf_emissions.F90 b/src/physics/cam_oslo/mo_srf_emissions.F90 similarity index 100% rename from src/chemistry/oslo_aero/mo_srf_emissions.F90 rename to src/physics/cam_oslo/mo_srf_emissions.F90 diff --git a/src/chemistry/oslo_aero/mo_usrrxt.F90 b/src/physics/cam_oslo/mo_usrrxt.F90 similarity index 100% rename from src/chemistry/oslo_aero/mo_usrrxt.F90 rename to src/physics/cam_oslo/mo_usrrxt.F90 diff --git a/src/chemistry/oslo_aero/modal_aero_data.F90 b/src/physics/cam_oslo/modal_aero_data.F90 similarity index 100% rename from src/chemistry/oslo_aero/modal_aero_data.F90 rename to src/physics/cam_oslo/modal_aero_data.F90 diff --git a/src/chemistry/oslo_aero/modal_aero_deposition.F90 b/src/physics/cam_oslo/modal_aero_deposition.F90 similarity index 100% rename from src/chemistry/oslo_aero/modal_aero_deposition.F90 rename to src/physics/cam_oslo/modal_aero_deposition.F90 diff --git a/src/chemistry/oslo_aero/seasalt_model.F90 b/src/physics/cam_oslo/seasalt_model.F90 similarity index 100% rename from src/chemistry/oslo_aero/seasalt_model.F90 rename to src/physics/cam_oslo/seasalt_model.F90 diff --git a/src/chemistry/oslo_aero/sox_cldaero_mod.F90 b/src/physics/cam_oslo/sox_cldaero_mod.F90 similarity index 100% rename from src/chemistry/oslo_aero/sox_cldaero_mod.F90 rename to src/physics/cam_oslo/sox_cldaero_mod.F90 diff --git a/src/chemistry/oslo_aero/vertical_diffusion.F90 b/src/physics/cam_oslo/vertical_diffusion.F90 similarity index 100% rename from src/chemistry/oslo_aero/vertical_diffusion.F90 rename to src/physics/cam_oslo/vertical_diffusion.F90 diff --git a/src/chemistry/oslo_aero/zm_microphysics.F90 b/src/physics/cam_oslo/zm_microphysics.F90 similarity index 100% rename from src/chemistry/oslo_aero/zm_microphysics.F90 rename to src/physics/cam_oslo/zm_microphysics.F90 From 8930894667032c2626c581ab28869acdf0a6c09c Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 18 Aug 2023 16:18:15 +0200 Subject: [PATCH 17/71] incorporate aeronucl_mod subroutines into condtend.F90 module --- src/chemistry/oslo_aero/aero_model.F90 | 985 ++++++-------- src/chemistry/oslo_aero/aeronucl_mod.F90 | 429 ------ src/chemistry/oslo_aero/condtend.F90 | 1582 ++++++++++++++-------- src/chemistry/oslo_aero/constants.F90 | 123 -- 4 files changed, 1367 insertions(+), 1752 deletions(-) delete mode 100644 src/chemistry/oslo_aero/aeronucl_mod.F90 delete mode 100644 src/chemistry/oslo_aero/constants.F90 diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index a1ebc14e02..d1ef32f6fd 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -3,89 +3,58 @@ !=============================================================================== module aero_model - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst, cnst_name, cnst_get_ind - use ppgrid, only: pcols, pver, pverp - use phys_control, only: phys_getopts, cam_physpkg_is - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use perf_mod, only: t_startf, t_stopf - use camsrfexch, only: cam_in_t, cam_out_t - use aerodep_flx, only: aerodep_flx_prescribed - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc - use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field - use physconst, only: gravit, rair, rhoh2o - use spmd_utils, only: masterproc - use infnan, only: nan, assignment(=) - use cam_history, only: outfld, fieldname_len - use chem_mods, only: gas_pcnst, adv_mass - use mo_tracname, only: solsym - use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName - use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub - use koagsub, only: coagtend, clcoag + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, cnst_name, cnst_get_ind + use ppgrid, only: pcols, pver, pverp + use phys_control, only: phys_getopts, cam_physpkg_is + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use perf_mod, only: t_startf, t_stopf + use camsrfexch, only: cam_in_t, cam_out_t + use aerodep_flx, only: aerodep_flx_prescribed + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc + use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field + use physconst, only: gravit, rair, rhoh2o + use spmd_utils, only: masterproc + use infnan, only: nan, assignment(=) + use cam_history, only: outfld, fieldname_len + use chem_mods, only: gas_pcnst, adv_mass + use mo_tracname, only: solsym + use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName + use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub + use koagsub, only: coagtend, clcoag use sox_cldaero_mod, only: sox_cldaero_init - use intlog, only: initlogn + use intlog, only: initlogn + use ref_pres, only: top_lev => clim_modal_aero_top_lev + use mo_setsox, only: setsox + use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri #ifdef AEROCOM - use aerocom_opt_mod, only: initaeropt - use aerocom_dry_mod, only: initdryp + use aerocom_opt_mod, only: initaeropt + use aerocom_dry_mod, only: initdryp #endif - !use modal_aero_data,only: cnst_name_cw, lptr_so4_cw_amode - !use modal_aero_data,only: ntot_amode, modename_amode, nspec_max - - use ref_pres, only: top_lev => clim_modal_aero_top_lev - - !use modal_aero_wateruptake, only: modal_strat_sulfate - use mo_setsox, only: setsox - use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri - implicit none private - public :: aero_model_readnl public :: aero_model_register public :: aero_model_init - public :: aero_model_gasaerexch ! create, grow, change, and shrink aerosols. - public :: aero_model_drydep ! aerosol dry deposition and sediment - public :: aero_model_wetdep ! aerosol wet removal - public :: aero_model_emissions ! aerosol emissions - public :: aero_model_surfarea ! tropopspheric aerosol wet surface area for chemistry + public :: aero_model_gasaerexch ! create, grow, change, and shrink aerosols. + public :: aero_model_drydep ! aerosol dry deposition and sediment + public :: aero_model_wetdep ! aerosol wet removal + public :: aero_model_emissions ! aerosol emissions + public :: aero_model_surfarea ! tropopspheric aerosol wet surface area for chemistry public :: aero_model_strat_surfarea ! stratospheric aerosol wet surface area for chemistry - ! Misc private data - - ! number of modes - integer :: nmodes - integer :: pblh_idx = 0 - integer :: dgnum_idx = 0 - integer :: dgnumwet_idx = 0 - integer :: rate1_cw2pr_st_idx = 0 - - integer :: wetdens_ap_idx = 0 - integer :: qaerwat_idx = 0 - - integer :: fracis_idx = 0 - integer :: prain_idx = 0 - integer :: rprddp_idx = 0 - integer :: rprdsh_idx = 0 - integer :: nevapr_shcu_idx = 0 - integer :: nevapr_dpcu_idx = 0 - - integer :: sulfeq_idx = -1 - - ! variables for table lookup of aerosol impaction/interception scavenging rates - integer, parameter :: nimptblgrow_mind=-7, nimptblgrow_maxd=12 - real(r8) :: dlndg_nimptblgrow - real(r8),allocatable :: scavimptblnum(:,:) - real(r8),allocatable :: scavimptblvol(:,:) - - ! for surf_area_dens - integer,allocatable :: num_idx(:) - integer,allocatable :: index_tot_mass(:,:) - integer,allocatable :: index_chm_mass(:,:) + private :: constants - integer :: ndx_h2so4, ndx_soa_lv, ndx_soa_sv + ! Misc private data + integer :: nmodes ! number of modes + integer :: pblh_idx= 0 + integer :: ndx_h2so4, ndx_soa_lv, ndx_soa_sv ! for surf_area_dens + integer :: ndrydep = 0 + integer :: nwetdep = 0 + logical :: convproc_do_aer ! Namelist variables character(len=16) :: wetdep_list(pcnst) = ' ' @@ -95,16 +64,6 @@ module aero_model real(r8) :: sol_factic_interstitial = 0.4_r8 real(r8) :: seasalt_emis_scale - integer :: ndrydep = 0 - integer,allocatable :: drydep_indices(:) - integer :: nwetdep = 0 - integer,allocatable :: wetdep_indices(:) - logical :: drydep_lq(pcnst) - logical :: wetdep_lq(pcnst) - - - logical :: convproc_do_aer - contains !============================================================================= @@ -113,28 +72,23 @@ module aero_model subroutine aero_model_readnl(nlfile) use namelist_utils, only: find_group_name - use units, only: getunit, freeunit use mpishorthand character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input ! Local variables integer :: unitn, ierr + character(len=16) :: aer_wetdep_list(pcnst) = ' ' ! Namelist variable + character(len=16) :: aer_drydep_list(pcnst) = ' ' ! Namelist variable character(len=*), parameter :: subname = 'aero_model_readnl' - ! Namelist variables - character(len=16) :: aer_wetdep_list(pcnst) = ' ' - character(len=16) :: aer_drydep_list(pcnst) = ' ' - namelist /aerosol_nl/ aer_wetdep_list, aer_drydep_list, sol_facti_cloud_borne, & - sol_factb_interstitial, sol_factic_interstitial - + sol_factb_interstitial, sol_factic_interstitial !----------------------------------------------------------------------------- ! Read namelist if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) + open(newunit=unitn, file=trim(nlfile), status='old' ) call find_group_name(unitn, 'aerosol_nl', status=ierr) if (ierr == 0) then read(unitn, aerosol_nl, iostat=ierr) @@ -143,17 +97,16 @@ subroutine aero_model_readnl(nlfile) end if end if close(unitn) - call freeunit(unitn) end if #ifdef SPMD ! Broadcast namelist variables - call mpibcast(aer_wetdep_list, len(aer_wetdep_list(1))*pcnst, mpichar, 0, mpicom) - call mpibcast(aer_drydep_list, len(aer_drydep_list(1))*pcnst, mpichar, 0, mpicom) - call mpibcast(sol_facti_cloud_borne, 1, mpir8, 0, mpicom) - call mpibcast(sol_factb_interstitial, 1, mpir8, 0, mpicom) - call mpibcast(sol_factic_interstitial, 1, mpir8, 0, mpicom) - call mpibcast(seasalt_emis_scale, 1, mpir8, 0, mpicom) + call mpibcast(aer_wetdep_list, len(aer_wetdep_list(1))*pcnst, mpichar, 0, mpicom) + call mpibcast(aer_drydep_list, len(aer_drydep_list(1))*pcnst, mpichar, 0, mpicom) + call mpibcast(sol_facti_cloud_borne, 1, mpir8, 0, mpicom) + call mpibcast(sol_factb_interstitial, 1, mpir8, 0, mpicom) + call mpibcast(sol_factic_interstitial, 1, mpir8, 0, mpicom) + call mpibcast(seasalt_emis_scale, 1, mpir8, 0, mpicom) #endif wetdep_list = aer_wetdep_list @@ -161,7 +114,6 @@ subroutine aero_model_readnl(nlfile) end subroutine aero_model_readnl - !============================================================================= !============================================================================= subroutine aero_model_register() use aerosoldef, only: aero_register @@ -172,37 +124,21 @@ subroutine aero_model_register() end subroutine aero_model_register - !============================================================================= !============================================================================= subroutine aero_model_init( pbuf2d ) - !use mo_chem_utls, only: get_inv_ndx - use cam_history, only: addfld, add_default, horiz_only - use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx - !use modal_aero_data, only: cnst_name_cw - !use modal_aero_data, only: modal_aero_data_init - !use rad_constituents,only: rad_cnst_get_info - use dust_model, only: dust_init, dust_active - use seasalt_model, only: seasalt_init, seasalt_active - use drydep_mod, only: inidrydep - use wetdep, only: wetdep_init - - use condtend, only: initializeCondensation - use oslo_ocean_intr, only: oslo_ocean_init - use oslo_aerosols_intr, only: oslo_aero_initialize - - use opttab, only : initopt, initopt_lw - + use cam_history, only: addfld, add_default, horiz_only + use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx + use dust_model, only: dust_init, dust_active + use seasalt_model, only: seasalt_init, seasalt_active + use drydep_mod, only: inidrydep + use wetdep, only: wetdep_init + use condtend, only: initializeCondensation + use oslo_ocean_intr, only: oslo_ocean_init + use oslo_aerosols_intr, only: oslo_aero_initialize + use opttab, only: initopt, initopt_lw use modal_aero_deposition , only: modal_aero_deposition_init - !use modal_aero_calcsize, only: modal_aero_calcsize_init - !use modal_aero_coag, only: modal_aero_coag_init - !use modal_aero_deposition, only: modal_aero_deposition_init - !use modal_aero_gasaerexch, only: modal_aero_gasaerexch_init - !use modal_aero_newnuc, only: modal_aero_newnuc_init - !use modal_aero_rename, only: modal_aero_rename_init - !use modal_aero_convproc, only: ma_convproc_init - ! args type(physics_buffer_desc), pointer :: pbuf2d(:,:) @@ -225,24 +161,21 @@ subroutine aero_model_init( pbuf2d ) character(len=32) :: spec_type character(len=32) :: mode_type integer :: nspec + !------------------------------------ - call phys_getopts(history_aerosol_out = history_aerosol, & - convproc_do_aer_out = convproc_do_aer) + call phys_getopts(history_aerosol_out=history_aerosol, convproc_do_aer_out=convproc_do_aer) - call constants - call initopt - call initlogn - call initopt_lw + call constants + call initopt + call initlogn + call initopt_lw #ifdef AEROCOM - call initaeropt() - call initdryp() + call initaeropt() + call initdryp() #endif - call initializeCondensation() call oslo_ocean_init() - call oslo_aero_initialize(pbuf2d) - call dust_init() call seasalt_init() !seasalt_emis_scale) call wetdep_init() @@ -263,8 +196,8 @@ subroutine aero_model_init( pbuf2d ) call add_default (dummy, 1, ' ') endif - !Get height of boundary layer for boundary layer nucleation - pblh_idx = pbuf_get_index('pblh') + ! Get height of boundary layer for boundary layer nucleation + pblh_idx = pbuf_get_index('pblh') call cnst_get_ind ( "H2SO4", ndx_h2so4, abort=.true. ) ndx_h2so4 = chemistryIndex(ndx_h2so4) @@ -274,29 +207,29 @@ subroutine aero_model_init( pbuf2d ) ndx_soa_sv = chemistryIndex(ndx_soa_sv) do m = 1,gas_pcnst - - unit_basename = 'kg' ! Units 'kg' or '1' call addfld( 'GS_'//trim(solsym(m)),horiz_only, 'A', unit_basename//'/m2/s ', & - trim(solsym(m))//' gas chemistry/wet removal (for gas species)') + trim(solsym(m))//' gas chemistry/wet removal (for gas species)') + call addfld( 'AQ_'//trim(solsym(m)),horiz_only, 'A', unit_basename//'/m2/s ', & - trim(solsym(m))//' aqueous chemistry (for gas species)') + trim(solsym(m))//' aqueous chemistry (for gas species)') + if(physicsIndex(m).le.pcnst) then - if (getCloudTracerIndexDirect(physicsIndex(m)) .gt. 0)then - call addfld( 'AQ_'//getCloudTracerName(physicsIndex(m)),horiz_only, 'A', unit_basename//'/m2/s ', & - trim(solsym(m))//' aqueous chemistry (for cloud species)') - end if + if (getCloudTracerIndexDirect(physicsIndex(m)) .gt. 0)then + call addfld( 'AQ_'//getCloudTracerName(physicsIndex(m)),horiz_only, 'A', unit_basename//'/m2/s ', & + trim(solsym(m))//' aqueous chemistry (for cloud species)') + end if end if if ( history_aerosol ) then call add_default( 'GS_'//trim(solsym(m)), 1, ' ') call add_default( 'AQ_'//trim(solsym(m)), 1, ' ') - if(physicsIndex(m).le.pcnst) then - if(getCloudTracerIndexDirect(physicsIndex(m)).gt.0)then - call add_default( 'AQ_'//getCloudTracerName(physicsIndex(m)),1,' ') + if(physicsIndex(m).le.pcnst) then + if(getCloudTracerIndexDirect(physicsIndex(m)).gt.0)then + call add_default( 'AQ_'//getCloudTracerName(physicsIndex(m)),1,' ') + end if end if - end if endif enddo @@ -330,11 +263,8 @@ subroutine aero_model_init( pbuf2d ) call add_default ('AQSO4_O3', 1, ' ') endif + end subroutine aero_model_init - -end subroutine aero_model_init - - !============================================================================= !============================================================================= subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend ) @@ -343,7 +273,7 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, use aerosoldef , only : numberOfProcessModeTracers use commondefinitions, only: oslo_nmodes=>nmodes - ! args + ! args type(physics_state), intent(in) :: state ! Physics state variables real(r8), intent(in) :: obklen(:) real(r8), intent(in) :: ustar(:) ! sfc fric vel @@ -353,7 +283,7 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies type(physics_buffer_desc), pointer :: pbuf(:) - ! local vars + ! local vars integer :: ncol real(r8), dimension(pcols, pver, 0:oslo_nmodes) :: oslo_dgnumwet real(r8), dimension(pcols, pver, 0:oslo_nmodes) :: oslo_wetdens @@ -362,21 +292,15 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ncol = state%ncol oslo_wetdens(:,:,:) = 0._r8 - call calcaersize_sub( ncol, & - state%t, state%q(1,1,1), state%pmid, state%pdel & - ,oslo_dgnumwet , oslo_wetdens & - ,oslo_dgnumwet_processmodes, oslo_wetdens_processmodes & - ) - - call oslo_aero_dry_intr(state, pbuf, obklen, ustar, cam_in, dt, cam_out,ptend & - , oslo_dgnumwet, oslo_wetdens & - , oslo_dgnumwet_processmodes, oslo_wetdens_processmodes, & - cam_in%cflx ) !++alfgr - - return + call calcaersize_sub( ncol, state%t, state%q(1,1,1), state%pmid, state%pdel, & + oslo_dgnumwet, oslo_wetdens, oslo_dgnumwet_processmodes, oslo_wetdens_processmodes) + + call oslo_aero_dry_intr(state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend, & + oslo_dgnumwet, oslo_wetdens, oslo_dgnumwet_processmodes, oslo_wetdens_processmodes, & + cam_in%cflx ) + endsubroutine aero_model_drydep - !============================================================================= !============================================================================= subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) @@ -393,13 +317,15 @@ subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) endsubroutine aero_model_wetdep - !------------------------------------------------------------------------- - ! provides wet tropospheric aerosol surface area info for modal aerosols - ! called from mo_usrrxt - !------------------------------------------------------------------------- + !============================================================================= subroutine aero_model_surfarea( & - mmr, radmean, relhum, pmid, temp, strato_sad, sulfate, rho, ltrop, & - dlat, het1_ndx, pbuf, ncol, sfc, dm_aer, sad_trop, reff_trop ) + mmr, radmean, relhum, pmid, temp, strato_sad, sulfate, rho, ltrop, & + dlat, het1_ndx, pbuf, ncol, sfc, dm_aer, sad_trop, reff_trop ) + + !------------------------------------------------------------------------- + ! provides wet tropospheric aerosol surface area info for modal aerosols + ! called from mo_usrrxt + !------------------------------------------------------------------------- use commondefinitions, only: nmodes_oslo => nmodes use const , only: numberToSurface @@ -434,7 +360,7 @@ subroutine aero_model_surfarea( & integer :: l,m integer :: i,k - !Get air density + !Get air density do k=1,pver do i=1,ncol rho_air(i,k) = pmid(i,k)/(temp(i,k)*287.04_r8) @@ -449,31 +375,31 @@ subroutine aero_model_surfarea( & sad_trop = 0._r8 do m=1,nmodes_oslo do k=1,pver - sad_mode(:ncol,k,m) = numberConcentration(:ncol,k,m)*numberToSurface(m)*1.e-2_r8 !m2/m3 ==> cm2/cm3 - sad_trop(:ncol,k) = sad_trop(:ncol,k) + sad_mode(:ncol,k,m) + sad_mode(:ncol,k,m) = numberConcentration(:ncol,k,m)*numberToSurface(m)*1.e-2_r8 !m2/m3 ==> cm2/cm3 + sad_trop(:ncol,k) = sad_trop(:ncol,k) + sad_mode(:ncol,k,m) end do end do do m=1,nmodes_oslo do k=1,pver - sfc(:ncol,k,m) = sad_mode(:ncol,k,m) ! aitken_idx:aitken_idx) - dm_aer(:ncol,k,m) = 2.0_r8*lifeCycleNumberMedianRadius(m) + sfc(:ncol,k,m) = sad_mode(:ncol,k,m) ! aitken_idx:aitken_idx) + dm_aer(:ncol,k,m) = 2.0_r8*lifeCycleNumberMedianRadius(m) end do end do !++ need to implement reff_trop here - reff_trop(:,:)=1.0e-6_r8 - !-- - + reff_trop(:,:)=1.0e-6_r8 end subroutine aero_model_surfarea - !------------------------------------------------------------------------- - ! provides WET stratospheric aerosol surface area info for modal aerosols - ! if modal_strat_sulfate = TRUE -- called from mo_gas_phase_chemdr - !------------------------------------------------------------------------- + !============================================================================= subroutine aero_model_strat_surfarea( ncol, mmr, pmid, temp, ltrop, pbuf, strato_sad, reff_strat ) + !------------------------------------------------------------------------- + ! provides WET stratospheric aerosol surface area info for modal aerosols + ! if modal_strat_sulfate = TRUE -- called from mo_gas_phase_chemdr + !------------------------------------------------------------------------- + ! dummy args integer, intent(in) :: ncol real(r8), intent(in) :: mmr(:,:,:) @@ -496,17 +422,17 @@ subroutine aero_model_strat_surfarea( ncol, mmr, pmid, temp, ltrop, pbuf, strato end subroutine aero_model_strat_surfarea - !============================================================================= !============================================================================= subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_rates, & - tfld, pmid, pdel, mbar, relhum, & - zm, qh2o, cwat, cldfr, cldnum, & - airdens, invariants, del_h2so4_gasprod, & - vmr0, vmr, pbuf ) + tfld, pmid, pdel, mbar, relhum, & + zm, qh2o, cwat, cldfr, cldnum, & + airdens, invariants, del_h2so4_gasprod, & + vmr0, vmr, pbuf ) use time_manager, only : get_nstep use condtend, only : condtend_sub use aerosoldef, only: getCloudTracerName + !----------------------------------------------------------------------- ! ... dummy arguments !----------------------------------------------------------------------- @@ -584,22 +510,22 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ ! calculate tendency due to gas phase chemistry and processes dvmrdt(:ncol,:,:) = (vmr(:ncol,:,:) - vmr0(:ncol,:,:)) / delt do m = 1, gas_pcnst - wrk(:) = 0._r8 - do k = 1,pver - wrk(:ncol) = wrk(:ncol) + dvmrdt(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit - end do - name = 'GS_'//trim(solsym(m)) - call outfld( name, wrk(:ncol), ncol, lchnk ) + wrk(:) = 0._r8 + do k = 1,pver + wrk(:ncol) = wrk(:ncol) + dvmrdt(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + end do + name = 'GS_'//trim(solsym(m)) + call outfld( name, wrk(:ncol), ncol, lchnk ) enddo -! Get mass mixing ratios at start of time step - call vmr2mmr( vmr0, mmr_tend_ncols, mbar, ncol ) - mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_H2SO4) = mmr_tend_ncols(1:ncol,:,ndx_h2so4) - mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) = mmr_tend_ncols(1:ncol,:,ndx_soa_lv) - mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) = mmr_tend_ncols(1:ncol,:,ndx_soa_sv) -! -! Aerosol processes ... -! + ! Get mass mixing ratios at start of time step + call vmr2mmr( vmr0, mmr_tend_ncols, mbar, ncol ) + mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_H2SO4) = mmr_tend_ncols(1:ncol,:,ndx_h2so4) + mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) = mmr_tend_ncols(1:ncol,:,ndx_soa_lv) + mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) = mmr_tend_ncols(1:ncol,:,ndx_soa_sv) + ! + ! Aerosol processes ... + ! call qqcw2vmr( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) ! save h2so4 change by gas phase chem (for later new particle nucleation) @@ -611,173 +537,164 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ del_soa_sv_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_soa_sv) - vmr0(1:ncol,:,ndx_soa_sv) if (.not. is_spcam_m2005) then ! regular CAM - dvmrdt(:ncol,:,:) = vmr(:ncol,:,:) - dvmrcwdt(:ncol,:,:) = vmrcw(:ncol,:,:) - - !Save intermediate concentrations - dvmrdt_sv1 = vmr - dvmrcwdt_sv1 = vmrcw - - ! aqueous chemistry ... - - call setsox( & - ncol, & - lchnk, & - loffset, & - delt, & - pmid, & - pdel, & - tfld, & - mbar, & - cwat, & - cldfr, & - cldnum, & - airdens, & - invariants, & - vmrcw, & - vmr, & - xphlwc, & - aqso4, & - aqh2so4, & - aqso4_h2o2, & - aqso4_o3 & - ) - - call outfld( 'AQSO4_H2O2', aqso4_h2o2(:ncol), ncol, lchnk) - call outfld( 'AQSO4_O3', aqso4_o3(:ncol), ncol, lchnk) - call outfld( 'XPH_LWC', xphlwc(:ncol,:), ncol, lchnk ) - - - ! vmr tendency from aqchem and soa routines - dvmrdt_sv1 = (vmr - dvmrdt_sv1)/delt - dvmrcwdt_sv1 = (vmrcw - dvmrcwdt_sv1)/delt - - if(ndx_h2so4 .gt. 0)then - del_h2so4_aqchem(:ncol,:) = dvmrdt_sv1(:ncol,:,ndx_h2so4)*delt !"production rate" of H2SO4 - else - del_h2so4_aqchem(:ncol,:) = 0.0_r8 - end if - - do m = 1,gas_pcnst - wrk(:ncol) = 0._r8 - do k = 1,pver - wrk(:ncol) = wrk(:ncol) + dvmrdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit - end do - name = 'AQ_'//trim(solsym(m)) - call outfld( name, wrk(:ncol), ncol, lchnk ) + dvmrdt(:ncol,:,:) = vmr(:ncol,:,:) + dvmrcwdt(:ncol,:,:) = vmrcw(:ncol,:,:) + + !Save intermediate concentrations + dvmrdt_sv1 = vmr + dvmrcwdt_sv1 = vmrcw + + ! aqueous chemistry ... + + call setsox( & + ncol, & + lchnk, & + loffset, & + delt, & + pmid, & + pdel, & + tfld, & + mbar, & + cwat, & + cldfr, & + cldnum, & + airdens, & + invariants, & + vmrcw, & + vmr, & + xphlwc, & + aqso4, & + aqh2so4, & + aqso4_h2o2, & + aqso4_o3 & + ) + + call outfld( 'AQSO4_H2O2', aqso4_h2o2(:ncol), ncol, lchnk) + call outfld( 'AQSO4_O3', aqso4_o3(:ncol), ncol, lchnk) + call outfld( 'XPH_LWC', xphlwc(:ncol,:), ncol, lchnk ) + + + ! vmr tendency from aqchem and soa routines + dvmrdt_sv1 = (vmr - dvmrdt_sv1)/delt + dvmrcwdt_sv1 = (vmrcw - dvmrcwdt_sv1)/delt + + if(ndx_h2so4 .gt. 0)then + del_h2so4_aqchem(:ncol,:) = dvmrdt_sv1(:ncol,:,ndx_h2so4)*delt !"production rate" of H2SO4 + else + del_h2so4_aqchem(:ncol,:) = 0.0_r8 + end if - !In oslo aero also write out the tendencies for the - !cloud borne aerosols... - n = physicsIndex(m) - if (n.le.pcnst) then - if(getCloudTracerIndexDirect(n) .gt. 0)then - name = 'AQ_'//trim(getCloudTracerName(n)) - wrk(:ncol)=0.0_r8 - do k=1,pver - wrk(:ncol) = wrk(:ncol) + dvmrcwdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + do m = 1,gas_pcnst + wrk(:ncol) = 0._r8 + do k = 1,pver + wrk(:ncol) = wrk(:ncol) + dvmrdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit end do + name = 'AQ_'//trim(solsym(m)) call outfld( name, wrk(:ncol), ncol, lchnk ) - end if - end if - enddo - else if (is_spcam_m2005) then ! SPCAM ECPP -! when ECPP is used, aqueous chemistry is done in ECPP, -! and not updated here. -! Minghuai Wang, 2010-02 (Minghuai.Wang@pnl.gov) -! - dvmrdt = 0.0_r8 - dvmrcwdt = 0.0_r8 - endif - - !condensation - call vmr2mmr( vmr, mmr_tend_ncols, mbar, ncol ) - do k = 1,pver - mmr_cond_vap_gasprod(:ncol,k,COND_VAP_H2SO4) = adv_mass(ndx_h2so4) * (del_h2so4_gasprod(:ncol,k)+del_h2so4_aqchem(:ncol,k)) / mbar(:ncol,k)/delt - mmr_cond_vap_gasprod(:ncol,k,COND_VAP_ORG_LV) = adv_mass(ndx_soa_lv) * del_soa_lv_gasprod(:ncol,k) / mbar(:ncol,k)/delt !cka - mmr_cond_vap_gasprod(:ncol,k,COND_VAP_ORG_SV) = adv_mass(ndx_soa_sv) * del_soa_sv_gasprod(:ncol,k) / mbar(:ncol,k)/delt !cka - end do - - !This should not happen since there are only - !production terms for these gases!! - do cond_vap_idx=1,N_COND_VAP - where(mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx).lt. 0.0_r8) - mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx) = 0.0_r8 - end where - end do - mmr_tend_ncols(:ncol,:,ndx_h2so4) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_H2SO4) - mmr_tend_ncols(:ncol,:,ndx_soa_lv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) - mmr_tend_ncols(:ncol,:,ndx_soa_sv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) - - !Rest of microphysics have pcols dimension - mmr_tend_pcols(:ncol,:,:) = mmr_tend_ncols(:ncol,:,:) - !Note use of "zm" here. In CAM5.3-implementation "zi" was used.. - !zm is passed through the generic interface, and it should not change much - !to check if "zm" is below boundary layer height instead of zi - call condtend_sub( lchnk, mmr_tend_pcols, mmr_cond_vap_gasprod,tfld, pmid, & - pdel, delt, ncol, pblh, zm, qh2o) !cka - - - !coagulation - ! OS 280415 Concentratiions in cloud water is in vmr space and as a - ! temporary variable (vmrcw) Coagulation between aerosol and cloud - ! droplets moved to after vmrcw is moved into qqcw (in mmr spac) - - call coagtend( mmr_tend_pcols, pmid, pdel, tfld, delt_inverse, ncol, lchnk) - - !Convert cloud water to mmr again ==> values in buffer - call vmr2qqcw( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) - - !Call cloud coagulation routines (all in mass mixing ratios) - call clcoag( mmr_tend_pcols, pmid, pdel, tfld, cldnum ,cldfr, delt_inverse, ncol, lchnk,loffset,pbuf) - - !Make sure mmr==> vmr is done correctly - mmr_tend_ncols(:ncol,:,:) = mmr_tend_pcols(:ncol,:,:) - - !Go back to volume mixing ratio for chemistry - call mmr2vmr( mmr_tend_ncols, vmr, mbar, ncol ) + !In oslo aero also write out the tendencies for the + !cloud borne aerosols... + n = physicsIndex(m) + if (n.le.pcnst) then + if(getCloudTracerIndexDirect(n) .gt. 0)then + name = 'AQ_'//trim(getCloudTracerName(n)) + wrk(:ncol)=0.0_r8 + do k=1,pver + wrk(:ncol) = wrk(:ncol) + dvmrcwdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + end do + call outfld( name, wrk(:ncol), ncol, lchnk ) + end if + end if + enddo - return + else if (is_spcam_m2005) then ! SPCAM ECPP + ! when ECPP is used, aqueous chemistry is done in ECPP, + ! and not updated here. + ! Minghuai Wang, 2010-02 (Minghuai.Wang@pnl.gov) + ! + dvmrdt = 0.0_r8 + dvmrcwdt = 0.0_r8 + endif + + ! condensation + call vmr2mmr( vmr, mmr_tend_ncols, mbar, ncol ) + do k = 1,pver + mmr_cond_vap_gasprod(:ncol,k,COND_VAP_H2SO4) = adv_mass(ndx_h2so4) & + * (del_h2so4_gasprod(:ncol,k)+del_h2so4_aqchem(:ncol,k)) / mbar(:ncol,k)/delt + mmr_cond_vap_gasprod(:ncol,k,COND_VAP_ORG_LV) = adv_mass(ndx_soa_lv) & + * del_soa_lv_gasprod(:ncol,k) / mbar(:ncol,k)/delt + mmr_cond_vap_gasprod(:ncol,k,COND_VAP_ORG_SV) = adv_mass(ndx_soa_sv) & + * del_soa_sv_gasprod(:ncol,k) / mbar(:ncol,k)/delt + end do + + ! This should not happen since there are only + ! production terms for these gases! ! + do cond_vap_idx=1,N_COND_VAP + where(mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx).lt. 0.0_r8) + mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx) = 0.0_r8 + end where + end do + mmr_tend_ncols(:ncol,:,ndx_h2so4) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_H2SO4) + mmr_tend_ncols(:ncol,:,ndx_soa_lv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) + mmr_tend_ncols(:ncol,:,ndx_soa_sv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) + + ! Rest of microphysics have pcols dimension + mmr_tend_pcols(:ncol,:,:) = mmr_tend_ncols(:ncol,:,:) + ! Note use of "zm" here. In CAM5.3-implementation "zi" was used.. + ! zm is passed through the generic interface, and it should not change much + ! to check if "zm" is below boundary layer height instead of zi + call condtend_sub( lchnk, mmr_tend_pcols, mmr_cond_vap_gasprod,tfld, pmid, & + pdel, delt, ncol, pblh, zm, qh2o) ! cka + + + ! coagulation + ! OS 280415 Concentratiions in cloud water is in vmr space and as a + ! temporary variable (vmrcw) Coagulation between aerosol and cloud + ! droplets moved to after vmrcw is moved into qqcw (in mmr spac) + + call coagtend( mmr_tend_pcols, pmid, pdel, tfld, delt_inverse, ncol, lchnk) + + ! Convert cloud water to mmr again ==> values in buffer + call vmr2qqcw( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) + + ! Call cloud coagulation routines (all in mass mixing ratios) + call clcoag( mmr_tend_pcols, pmid, pdel, tfld, cldnum ,cldfr, delt_inverse, ncol, lchnk,loffset,pbuf) + + ! Make sure mmr==> vmr is done correctly + mmr_tend_ncols(:ncol,:,:) = mmr_tend_pcols(:ncol,:,:) + + ! Go back to volume mixing ratio for chemistry + call mmr2vmr( mmr_tend_ncols, vmr, mbar, ncol ) end subroutine aero_model_gasaerexch - !============================================================================= !============================================================================= subroutine aero_model_emissions( state, cam_in ) - use seasalt_model, only: oslo_salt_emis_intr, seasalt_active, OMOceanSource - use dust_model, only: oslo_dust_emis_intr, dust_active - use oslo_ocean_intr, only: oslo_dms_emis_intr - use aerosoldef, only: l_om_ni - use physics_types, only: physics_state - ! Arguments: + use seasalt_model , only: oslo_salt_emis_intr, seasalt_active, OMOceanSource + use dust_model , only: oslo_dust_emis_intr, dust_active + use oslo_ocean_intr , only: oslo_dms_emis_intr + use aerosoldef , only: l_om_ni + use physics_types , only: physics_state + ! Arguments: type(physics_state), intent(in) :: state ! Physics state variables type(cam_in_t), intent(inout) :: cam_in ! import state ! local vars - - integer :: lchnk, ncol - real(r8) :: sflx(pcols) ! accumulate over all bins for output - real (r8), parameter :: z0=0.0001_r8 ! m roughness length over oceans--from ocean model - - lchnk = state%lchnk - ncol = state%ncol + integer :: ncol if (dust_active) then - call oslo_dust_emis_intr( state, cam_in) - ! some dust emis diagnostics ... endif if (seasalt_active) then - call oslo_salt_emis_intr(state, cam_in) - endif !Add whatever OM ocean source was calculated in the seasalt module + ncol = state%ncol cam_in%cflx(:ncol,l_om_ni) = cam_in%cflx(:ncol,l_om_ni) + OMOceanSource(:ncol) !Pick up correct DMS emissions (replace values from file if requested) @@ -785,265 +702,19 @@ subroutine aero_model_emissions( state, cam_in ) end subroutine aero_model_emissions - !=============================================================================== - ! private methods - - !============================================================================= + ! private methods !============================================================================= - subroutine surf_area_dens( ncol, mmr, pmid, temp, diam, beglev, endlev, sad, sfc ) - use mo_constants, only : pi - - ! dummy args - integer, intent(in) :: ncol - real(r8), intent(in) :: mmr(:,:,:) - real(r8), intent(in) :: pmid(:,:) - real(r8), intent(in) :: temp(:,:) - real(r8), intent(in) :: diam(:,:,:) - integer, intent(in) :: beglev(:) - integer, intent(in) :: endlev(:) - real(r8), intent(out) :: sad(:,:) - real(r8),optional, intent(out) :: sfc(:,:,:) - - ! local vars - - ! - ! Compute surface aero for each mode. - ! Total over all modes as the surface area for chemical reactions. - ! - - !oslo: do nothing for now - return - - end subroutine surf_area_dens - - !=============================================================================== - !=============================================================================== - subroutine modal_aero_bcscavcoef_init - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Computes lookup table for aerosol impaction/interception scavenging rates - ! - ! Authors: R. Easter - ! - !----------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - use modal_aero_data - use cam_abortutils, only: endrun - - implicit none - - ! oslo : do nothing for now - return - end subroutine modal_aero_bcscavcoef_init - - !=============================================================================== - !=============================================================================== - subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & - radius_part, density_part, sig_part, moment, lchnk ) - -! calculates surface deposition velocity of particles -! L. Zhang, S. Gong, J. Padro, and L. Barrie -! A size-seggregated particle dry deposition scheme for an atmospheric aerosol module -! Atmospheric Environment, 35, 549-560, 2001. -! -! Authors: X. Liu - - ! - ! !USES - ! - use physconst, only: pi,boltz, gravit, rair - use mo_drydep, only: n_land_type, fraction_landuse - - ! !ARGUMENTS: - ! - implicit none - ! - real(r8), intent(in) :: t(pcols,pver) !atm temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) !atm pressure (Pa) - real(r8), intent(in) :: fv(pcols) !friction velocity (m/s) - real(r8), intent(in) :: ram1(pcols) !aerodynamical resistance (s/m) - real(r8), intent(in) :: radius_part(pcols,pver) ! mean (volume/number) particle radius (m) - real(r8), intent(in) :: density_part(pcols,pver) ! density of particle material (kg/m3) - real(r8), intent(in) :: sig_part(pcols,pver) ! geometric standard deviation of particles - integer, intent(in) :: moment ! moment of size distribution (0 for number, 2 for surface area, 3 for volume) - integer, intent(in) :: ncol - integer, intent(in) :: lchnk - - real(r8), intent(out) :: vlc_trb(pcols) !Turbulent deposn velocity (m/s) - real(r8), intent(out) :: vlc_grv(pcols,pver) !grav deposn velocity (m/s) - real(r8), intent(out) :: vlc_dry(pcols,pver) !dry deposn velocity (m/s) - !------------------------------------------------------------------------ - - !------------------------------------------------------------------------ - ! Local Variables - integer :: m,i,k,ix !indices - real(r8) :: rho !atm density (kg/m**3) - real(r8) :: vsc_dyn_atm(pcols,pver) ![kg m-1 s-1] Dynamic viscosity of air - real(r8) :: vsc_knm_atm(pcols,pver) ![m2 s-1] Kinematic viscosity of atmosphere - real(r8) :: shm_nbr ![frc] Schmidt number - real(r8) :: stk_nbr ![frc] Stokes number - real(r8) :: mfp_atm(pcols,pver) ![m] Mean free path of air - real(r8) :: dff_aer ![m2 s-1] Brownian diffusivity of particle - real(r8) :: slp_crc(pcols,pver) ![frc] Slip correction factor - real(r8) :: rss_trb ![s m-1] Resistance to turbulent deposition - real(r8) :: rss_lmn ![s m-1] Quasi-laminar layer resistance - real(r8) :: brownian ! collection efficiency for Browning diffusion - real(r8) :: impaction ! collection efficiency for impaction - real(r8) :: interception ! collection efficiency for interception - real(r8) :: stickfrac ! fraction of particles sticking to surface - real(r8) :: radius_moment(pcols,pver) ! median radius (m) for moment - real(r8) :: lnsig ! ln(sig_part) - real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity - ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) - - integer :: lt - real(r8) :: lnd_frc - real(r8) :: wrk1, wrk2, wrk3 - - ! constants - real(r8) gamma(11) ! exponent of schmidt number -! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & -! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & -! 0.50d+00/ - data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & - 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & - 0.54e+00_r8/ - save gamma - - real(r8) alpha(11) ! parameter for impaction -! data alpha/50.00d+00, 0.95d+00, 0.80d+00, 1.20d+00, 1.30d+00, & -! 0.80d+00, 50.00d+00, 50.00d+00, 2.00d+00, 1.50d+00, & -! 100.00d+00/ - data alpha/1.50e+00_r8, 1.20e+00_r8, 1.20e+00_r8, 0.80e+00_r8, 1.00e+00_r8, & - 0.80e+00_r8, 100.00e+00_r8, 50.00e+00_r8, 2.00e+00_r8, 1.20e+00_r8, & - 50.00e+00_r8/ - save alpha - - real(r8) radius_collector(11) ! radius (m) of surface collectors -! data radius_collector/-1.00d+00, 5.10d-03, 3.50d-03, 3.20d-03, 10.00d-03, & -! 5.00d-03, -1.00d+00, -1.00d+00, 10.00d-03, 10.00d-03, & -! -1.00d+00/ - data radius_collector/10.00e-03_r8, 3.50e-03_r8, 3.50e-03_r8, 5.10e-03_r8, 2.00e-03_r8, & - 5.00e-03_r8, -1.00e+00_r8, -1.00e+00_r8, 10.00e-03_r8, 3.50e-03_r8, & - -1.00e+00_r8/ - save radius_collector - - integer :: iwet(11) ! flag for wet surface = 1, otherwise = -1 -! data iwet/1, -1, -1, -1, -1, & -! -1, -1, -1, 1, -1, & -! 1/ - data iwet/-1, -1, -1, -1, -1, & - -1, 1, -1, 1, -1, & - -1/ - save iwet - - - !------------------------------------------------------------------------ - do k=1,pver - do i=1,ncol - - lnsig = log(sig_part(i,k)) -! use a maximum radius of 50 microns when calculating deposition velocity - radius_moment(i,k) = min(50.0e-6_r8,radius_part(i,k))* & - exp((float(moment)-1.5_r8)*lnsig*lnsig) - dispersion = exp(2._r8*lnsig*lnsig) - - rho=pmid(i,k)/rair/t(i,k) - - ! Quasi-laminar layer resistance: call rss_lmn_get - ! Size-independent thermokinetic properties - vsc_dyn_atm(i,k) = 1.72e-5_r8 * ((t(i,k)/273.0_r8)**1.5_r8) * 393.0_r8 / & - (t(i,k)+120.0_r8) ![kg m-1 s-1] RoY94 p. 102 - mfp_atm(i,k) = 2.0_r8 * vsc_dyn_atm(i,k) / & ![m] SeP97 p. 455 - (pmid(i,k)*sqrt(8.0_r8/(pi*rair*t(i,k)))) - vsc_knm_atm(i,k) = vsc_dyn_atm(i,k) / rho ![m2 s-1] Kinematic viscosity of air - - slp_crc(i,k) = 1.0_r8 + mfp_atm(i,k) * & - (1.257_r8+0.4_r8*exp(-1.1_r8*radius_moment(i,k)/(mfp_atm(i,k)))) / & - radius_moment(i,k) ![frc] Slip correction factor SeP97 p. 464 - vlc_grv(i,k) = (4.0_r8/18.0_r8) * radius_moment(i,k)*radius_moment(i,k)*density_part(i,k)* & - gravit*slp_crc(i,k) / vsc_dyn_atm(i,k) ![m s-1] Stokes' settling velocity SeP97 p. 466 - vlc_grv(i,k) = vlc_grv(i,k) * dispersion - - vlc_dry(i,k)=vlc_grv(i,k) - enddo - enddo - k=pver ! only look at bottom level for next part - do i=1,ncol - dff_aer = boltz * t(i,k) * slp_crc(i,k) / & ![m2 s-1] - (6.0_r8*pi*vsc_dyn_atm(i,k)*radius_moment(i,k)) !SeP97 p.474 - shm_nbr = vsc_knm_atm(i,k) / dff_aer ![frc] SeP97 p.972 - - wrk2 = 0._r8 - wrk3 = 0._r8 - do lt = 1,n_land_type - lnd_frc = fraction_landuse(i,lt,lchnk) - if ( lnd_frc /= 0._r8 ) then - brownian = shm_nbr**(-gamma(lt)) - if (radius_collector(lt) > 0.0_r8) then -! vegetated surface - stk_nbr = vlc_grv(i,k) * fv(i) / (gravit*radius_collector(lt)) - interception = 2.0_r8*(radius_moment(i,k)/radius_collector(lt))**2.0_r8 - else -! non-vegetated surface - stk_nbr = vlc_grv(i,k) * fv(i) * fv(i) / (gravit*vsc_knm_atm(i,k)) ![frc] SeP97 p.965 - interception = 0.0_r8 - endif - impaction = (stk_nbr/(alpha(lt)+stk_nbr))**2.0_r8 - - if (iwet(lt) > 0) then - stickfrac = 1.0_r8 - else - stickfrac = exp(-sqrt(stk_nbr)) - if (stickfrac < 1.0e-10_r8) stickfrac = 1.0e-10_r8 - endif - rss_lmn = 1.0_r8 / (3.0_r8 * fv(i) * stickfrac * (brownian+interception+impaction)) - rss_trb = ram1(i) + rss_lmn + ram1(i)*rss_lmn*vlc_grv(i,k) - - wrk1 = 1.0_r8 / rss_trb - wrk2 = wrk2 + lnd_frc*( wrk1 ) - wrk3 = wrk3 + lnd_frc*( wrk1 + vlc_grv(i,k) ) - endif - enddo ! n_land_type - vlc_trb(i) = wrk2 - vlc_dry(i,k) = wrk3 - enddo !ncol - - return - end subroutine modal_aero_depvel_part - - !=============================================================================== - subroutine modal_aero_bcscavcoef_get( m, ncol, isprx, dgn_awet, scavcoefnum, scavcoefvol ) - - use modal_aero_data - !----------------------------------------------------------------------- - implicit none - integer,intent(in) :: m, ncol - logical,intent(in):: isprx(pcols,pver) - real(r8), intent(in) :: dgn_awet(pcols,pver,ntot_amode) - real(r8), intent(out) :: scavcoefnum(pcols,pver), scavcoefvol(pcols,pver) - - integer i, k, jgrow - - return - end subroutine modal_aero_bcscavcoef_get - - !============================================================================= - !============================================================================= subroutine qqcw2vmr(lchnk, vmr, mbar, ncol, im, pbuf) - use modal_aero_data, only : qqcw_get_field - use physics_buffer, only : physics_buffer_desc + !----------------------------------------------------------------- ! ... Xfrom from mass to volume mixing ratio !----------------------------------------------------------------- - use chem_mods, only : adv_mass, gas_pcnst - - implicit none + use modal_aero_data , only : qqcw_get_field + use physics_buffer , only : physics_buffer_desc + use chem_mods , only : adv_mass, gas_pcnst !----------------------------------------------------------------- ! ... Dummy args @@ -1073,8 +744,6 @@ subroutine qqcw2vmr(lchnk, vmr, mbar, ncol, im, pbuf) end do end subroutine qqcw2vmr - - !============================================================================= !============================================================================= subroutine vmr2qqcw( lchnk, vmr, mbar, ncol, im, pbuf ) !----------------------------------------------------------------- @@ -1086,8 +755,6 @@ subroutine vmr2qqcw( lchnk, vmr, mbar, ncol, im, pbuf ) use modal_aero_data, only : qqcw_get_field use physics_buffer, only : physics_buffer_desc - implicit none - !----------------------------------------------------------------- ! ... Dummy args !----------------------------------------------------------------- @@ -1112,7 +779,123 @@ subroutine vmr2qqcw( lchnk, vmr, mbar, ncol, im, pbuf ) end do end if end do - end subroutine vmr2qqcw + !============================================================================= + subroutine constants + ! + ! A number of constants used in the emission and size-calculation in CAM-Oslo Jan 2011. + ! Updated by Alf Kirkev May 2013 + ! Updated by Alf Grini February 2014 + ! + use shr_kind_mod, only: r8 => shr_kind_r8 + use physconst, only: pi + use const + use aerosoldef + use koagsub, only : initializeCoagulationReceivers + use koagsub, only : initializeCoagulationCoefficients + use koagsub, only : initializeCoagulationOutput + use oslo_utils + + integer :: kcomp,i + real(r8) :: rhob(0:nmodes) !density of background aerosol in mode + real(r8) :: rhorbc !This has to do with fractal dimensions of bc, come back to this!! + real(r8) :: sumnormnk + real(r8) :: totalLogDelta + real(r8) :: logDeltaBin + real(r8) :: logNextEdge + + rhob(:) =-1.0_r8 + volumeToNumber(:) =-1.0_r8 + numberToSurface(:) =-1.0_r8 + + !Prepare modal properties + do i=0, nmodes + + if(getNumberOfTracersInMode(i) .gt. 0)then + + !Approximate density of mode + !density of mode is density of first species in mode + rhob(i) = rhopart(getTracerIndex(i,1,.false.)) + + !REPLACE THE EFACT-VARIABLE WITH THIS!! + volumeToNumber(i) = 1.0_r8 / & + ( DEXP ( 4.5_r8 * ( log(originalSigma(i)) * log(originalSigma(i)) ) ) & + *(4.0_r8/3.0_r8)*pi*(originalNumberMedianRadius(i))**3 ) + + numberToSurface(i) = 4.0_r8*pi*lifeCycleNumberMedianRadius(i)*lifeCycleNumberMedianRadius(i)& + *DEXP(log(lifeCycleSigma(i))*log(lifeCycleSigma(i))) + end if + end do + + + !Find radius in edges and midpoints of bin + rBinEdge(1) = rTabMin + totalLogDelta = log(rTabMax/rTabMin) + logDeltaBin = totalLogDelta / nBinsTab + do i=2,nBinsTab+1 + logNextEdge = log(rBinEdge(i-1)) + logDeltaBin + rBinEdge(i) = DEXP(logNextEdge) + rBinMidPoint(i-1) = sqrt(rBinEdge(i)*rBinEdge(i-1)) + end do + + !Calculate the fraction of a mode which goes to aquous chemstry + numberFractionAvailableAqChem(:)=0.0_r8 + do i=1,nbmodes + if(isTracerInMode(i,l_so4_a2))then + numberFractionAvailableAqChem(i) = 1.0_r8 - & + calculateLognormalCDF(rMinAquousChemistry,originalNumberMedianRadius(i), originalSigma(i)) + end if + end do + + !Set the density of the fractal mode ==> we get lesser density + !than the emitted density, so for a given mass emitted, we get + !more number-concentration!! This is a way of simulating that the + !aerosols take up more space + rhorbc = calculateEquivalentDensityOfFractalMode( & + rhopart(l_bc_n), & !emitted density + originalNumberMedianRadius(MODE_IDX_BC_NUC), & !emitted size + 2.5_r8, & !fractal dim + originalNumberMedianRadius(MODE_IDX_BC_EXT_AC), & !diameter of mode + originalSigma(MODE_IDX_BC_EXT_AC)) !sigma mode + + rhopart(l_bc_ax) = rhorbc + !fxm: not the right place for this change of value, + !but anyway.. this re-calculateion of tracer density + !influences density of mode used in coagulation + rhob(MODE_IDX_BC_EXT_AC)=rhorbc + + !Size distribution of the modes! + !Unclear if this should use the radii assuming growth or not! + !Mostly used in code where it is sensible to assume some growth has + !happened, so it is used here + do kcomp = 0,nmodes + do i=1,nBinsTab + !dN/dlogR (does not sum to one over size range) + nk(kcomp,i) = calculatedNdLogR(rBinMidPoint(i), lifeCycleNumberMedianRadius(kcomp), lifeCycleSigma(kcomp)) + + !dN (sums to one) over the size range + normnk(kcomp,i) =logDeltaBin*nk(kcomp,i) + enddo + enddo ! kcomp + + !++test: Normalized size distribution must sum to one (accept 2% error) + do kcomp=0,nmodes + sumNormNk = sum(normnk(kcomp,:)) + if(abs(sum(normnk(kcomp,:)) - 1.0_r8) .gt. 2.0e-2_r8)then + print*, "sum normnk", sum(normnk(kcomp,:)) + stop + endif + enddo + !--test + + !Initialize coagulation + call initializeCoagulationReceivers() + + !Calculate the coagulation coefficients Note: Inaccurate density used! + call initializeCoagulationCoefficients(rhob, lifeCycleNumberMedianRadius) + + call initializeCoagulationOutput() + end subroutine constants + end module aero_model diff --git a/src/chemistry/oslo_aero/aeronucl_mod.F90 b/src/chemistry/oslo_aero/aeronucl_mod.F90 deleted file mode 100644 index 3c4673ab0d..0000000000 --- a/src/chemistry/oslo_aero/aeronucl_mod.F90 +++ /dev/null @@ -1,429 +0,0 @@ -module aeronucl_mod - - use shr_kind_mod, only: r8 => shr_kind_r8 - use wv_saturation, only: qsat_water - use physconst, only: avogad, rair - use ppgrid, only: pcols, pver, pverp - use aerosoldef, only : MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na - use commondefinitions, only: originalNumberMedianRadius - use cam_history, only: outfld - use phys_control, only: phys_getopts - use chem_mods, only: adv_mass - use m_spc_id, only : id_H2SO4, id_soa_lv - use const, only : volumeToNumber - - implicit none - -contains - - subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuclso4, nuclorg, zm, pblht) - - ! Subroutine to calculate nucleation (formation) rates of new particles - ! At the moment, the final nucleation rate consists of - ! (1) Binary sulphuric acid-water nucleation in whole atmosphere (Vehkamaki et al., 2002, JGR) - ! JGR, vol 107, No D22, http://onlinelibrary.wiley.com/doi/10.1029/2002JD002184/abstract - ! (2) Boundary-layer nucleation - ! Paasonen et al (2010), ACP, vol 10, pp 11223: http://www.atmos-chem-phys.net/10/11223/2010/acp-10-11223-2010.html - ! (3) First version published ACP (Risto Makkonen) - ! ACP, vol 14, no 10, pp 5127 http://www.atmos-chem-phys.net/14/5127/2014/acp-14-5127-2014.html - ! Modified Spring 2015, cka - - - !-- Arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric column - real(r8), intent(in) :: pmid(pcols,pver) ! layer pressure (Pa) - real(r8), intent(in) :: h2ommr(pcols,pver) ! layer specific humidity - real(r8), intent(in) :: t(pcols,pver) ! Temperature (K) - real(r8), intent(in) :: h2so4pc(pcols,pver) ! Sulphuric acid concentration (kg kg-1) - real(r8), intent(in) :: oxidorg(pcols,pver) ! Organic vapour concentration (kg kg-1) - real(r8), intent(in) :: coagnuc(pcols,pver) ! Coagulation sink for nucleating particles [1/s] - real(r8), intent(out) :: nuclorg(pcols,pver) ! Nucleated mass (ORG) - real(r8), intent(out) :: nuclso4(pcols,pver) ! Nucleated mass (H2SO4) - real(r8), intent(in) :: zm(pcols,pver) ! Height at layer midpoints (m) - real(r8), intent(in) :: pblht(pcols) ! Planetary boundary layer height (m) - - !-- Local variables - - real(r8), parameter :: pi=3.141592654_r8 - !cka+ - real(r8), parameter :: gasconst_R=8.314472_r8 ! universal gas constant [J mol-1 K-1] - real(r8), parameter :: h2so4_dens=1841._r8 ! h2so4 density [kg m-3] - real(r8), parameter :: org_dens=2000._r8 ! density of organics [kg m-3], based on RM assumptions - !cka - - - integer :: i,k - real(r8) :: qs(pcols,pver) ! Saturation specific humidity - real(r8) :: relhum(pcols,pver) ! Relative humidity - real(r8) :: h2so4(pcols,pver) ! Sulphuric acid concentration [#/cm3] - real(r8) :: nuclvolume(pcols,pver) ! [m3/m3/s] Nucleated mass (SO4+ORG) - real(r8) :: rhoair(pcols,pver) ! density of air [kg/m3] !cka - real(r8) :: pblht_lim(pcols) ! Planetary boundary layer height (m) (500mzm(i,k) .AND. pbl_nucleation>0) then - - if(pbl_nucleation .EQ. 1) then - - !-- Paasonen et al. (2010), eqn 10, Table 4 - nuclrate_pbl(i,k)=(1.7E-6_r8)*h2so4(i,k) - - else if(pbl_nucleation .EQ. 2) then - - !-- Paasonen et al. (2010) - !values from Table 3 in Paasonen et al (2010), modified version of eqn 14 - nuclrate_pbl(i,k)=(6.1E-7_r8)*h2so4(i,k)+(0.39E-7_r8)*orgforgrowth(i,k) - - end if - - nuclrate_pbl(i,k)=MAX(MIN(nuclrate_pbl(i,k),1.E10_r8),0._r8) - - else !Not using PBL-nucleation - nuclrate_pbl(i,k)=0._r8 - end if - !Size [nm] of particles in PBL - nuclsize_pbl(i,k)=2._r8 - - end do !horizontal points - end do !levels - - !-- Calculate total nucleated mass - do k=1,pver - do i=1,ncol - - ! Molecular speed and growth rate: H2SO4. Eq. 21 in Kerminen and Kulmala 2002 - vmolh2so4=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_h2so4*1.E-3_r8)) - grh2so4(i,k)=(3.E-9_r8/h2so4_dens)*(vmolh2so4*molmass_h2so4*h2so4(i,k)) - grh2so4(i,k)=MAX(MIN(grh2so4(i,k),10000._r8),1.E-10_r8) - - ! Molecular speed and growth rate: ORG. Eq. 21 in Kerminen and Kulmala 2002 - vmolorg=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_soa*1.E-3_r8)) - grorg(i,k)=(3.E-9_r8/org_dens)*(vmolorg*molmass_soa*orgforgrowth(i,k)) - grorg(i,k)=MAX(MIN(grorg(i,k),10000._r8),1.E-10_r8) - - ! Combined growth rate (cka) - gr(i,k)=grh2so4(i,k)+grorg(i,k) - - !-- Lehtinen 2007 parameterization for apparent formation rate - ! diameters in nm, growth rate in nm h-1, coagulation in s-1 - - call appformrate(nuclsize_bin(i,k), d_form*1.E9_r8, nuclrate_bin(i,k), formrate_bin(i,k), coagnuc(i,k), gr(i,k)) - call appformrate(nuclsize_pbl(i,k), d_form*1.E9_r8, nuclrate_pbl(i,k), formrate_pbl(i,k), coagnuc(i,k), gr(i,k)) - - formrate_bin(i,k)=MAX(MIN(formrate_bin(i,k),1.E3_r8),0._r8) - formrate_pbl(i,k)=MAX(MIN(formrate_pbl(i,k),1.E3_r8),0._r8) - - ! Number of mol nucleated per g air per second. - nuclvolume(i,k) = (formrate_bin(i,k) + formrate_pbl(i,k)) & ![particles/cm3] - *1.0e6_r8 & !==> [particles / m3 /] - /volumeToNumber(MODE_IDX_SO4SOA_AIT) & !==> [m3_{aer} / m3_{air} / sec] - / rhoair(i,k) !==> m3_{aer} / kg_{air} /sec - - !Estimate how much is organic based on growth-rate - if(gr(i,k)>1.E-10_r8) then - frach2so4=grh2so4(i,k)/gr(i,k) - else - frach2so4=1._r8 - end if - - ! Nucleated so4 and soa mass mixing ratio per second [kg kg-1 s-1] - ! used density of particle phase, not of condensing gas - nuclso4(i,k)=rhopart(l_so4_na)*nuclvolume(i,k)*frach2so4 - nuclorg(i,k)=rhopart(l_soa_na)*nuclvolume(i,k)*(1.0_r8-frach2so4) - - end do - end do - - !-- Diagnostic output - call outfld('NUCLRATE', nuclrate_bin+nuclrate_pbl, pcols ,lchnk) - call outfld('FORMRATE', formrate_bin+formrate_pbl, pcols ,lchnk) - call outfld('COAGNUCL', coagnuc, pcols ,lchnk) - call outfld('GRH2SO4', grh2so4, pcols ,lchnk) - call outfld('GRSOA', grorg, pcols ,lchnk) - call outfld('GR', gr, pcols ,lchnk) - - return - end subroutine aeronucl - - subroutine appformrate(d1, dx, j1, jx, CoagS_dx, gr) - !-- appformrate calculates the formation rate jx of dx sized particles from the nucleation rate j1 (d1 sized particles) - !-- Formation rate is parameterized according to Lehtinen et al. (2007), JAS 38:988-994 - !-- Parameterization takes into account the loss of particles due to coagulation - !-- Growth by self-coagulation is not accounted for - !-- Typically, 1% of 1 nm nuclei make it to 12 nm - !-- Written by Risto Makkonen - ! First estimate: 99% of particles are lost during growth from 1 nm to 12 nm - - !-- Arguments - - real(r8), intent(in) :: d1 ! Size of nucleation-sized particles (nm) - real(r8), intent(in) :: dx ! Size of calculated apparent formation rate (nm) - real(r8), intent(in) :: j1 ! Nucleation rate of d1 sized particles (# cm-3 s-1) - real(r8), intent(out) :: jx ! Formation rate of dx sized particles (# cm-3 s-1) - real(r8), intent(in) :: CoagS_dx ! Coagulation term for nucleating particles (s-1) - real(r8), intent(in) :: gr ! Particle growth rate (nm h-1) - - !-- Local variables - - real(r8) :: m - real(r8) :: gamma - real(r8) :: CoagS_d1 ! Coagulation term for nucleating particles, calculated from CoagS_dx - - ! In Hyytiala, typically 80% of the nuclei are scavenged onto larger background particles while they grow from 1 to 3 nm - - !-- (Eq. 6) Exponent m, depends on background distribution - ! m=log(CoagS_dx/CoagS_d1)/log(dx/d1) - ! Or, if we dont want to calculate CoagS_d1, lets assume a typical value for m (-1.5 -- -1.9) and calculate CoagS_d1 from Eq.5 - m=-1.6_r8 - CoagS_d1=CoagS_dx*(d1/dx)**m - CoagS_d1=MAX(MIN(CoagS_d1,1.E2_r8),1.E-10_r8) - - gamma=(1._r8/(m+1._r8))*((dx/d1)**(m+1._r8)-1._r8) - gamma=MAX(MIN(gamma,1.E2_r8),1.E-10_r8) - - !gr=MAX(MIN(gr,1.E3_r8),1.E-5_r8) - - !-- (Eq. 7) CoagS_d1 is multiplied with 3600 to get units h-1 - !WRITE(*,*) 'gammaym:',gamma,exp(-gamma*d1*CoagS_d1*3600/gr) - jx=j1*exp(-gamma*d1*CoagS_d1*3600._r8/gr) - - return - - end subroutine appformrate - -end module aeronucl_mod diff --git a/src/chemistry/oslo_aero/condtend.F90 b/src/chemistry/oslo_aero/condtend.F90 index 1b8cc27ed1..c430fb5e03 100644 --- a/src/chemistry/oslo_aero/condtend.F90 +++ b/src/chemistry/oslo_aero/condtend.F90 @@ -1,640 +1,1024 @@ module condtend - use phys_control, only: phys_getopts - use chem_mods, only: gas_pcnst - use mo_tracname, only: solsym - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid - use const - use cam_history, only: outfld - use aerosoldef - use physconst, only: rair, gravit, pi - use commondefinitions - use chem_mods, only: adv_mass !molecular weights from mozart -!soa - - save - - integer, parameter :: N_COND_VAP = 3 - integer, parameter :: COND_VAP_H2SO4 = 1 - integer, parameter :: COND_VAP_ORG_LV = 2 - integer, parameter :: COND_VAP_ORG_SV = 3 - - real(r8), public, dimension(0:nmodes,N_COND_VAP) :: normalizedCondensationSink ![m3/#/s] condensation sink per particle in mode i - - integer, private, dimension(gas_pcnst) :: lifeCycleReceiver ! [-] array of transformation of life cycle tracers - real(r8), private, dimension(0:nmodes,N_COND_VAP) :: stickingCoefficient ! [-] stickingCoefficient for H2SO4 on a mode - integer, private, dimension(N_COND_VAP) :: cond_vap_map - -! Assumed number of monolayers + use shr_kind_mod, only: r8 => shr_kind_r8 + use phys_control, only: phys_getopts + use chem_mods, only: gas_pcnst + use mo_tracname, only: solsym + use ppgrid, only: pcols, pver, pverp + use const + use cam_history, only: outfld + use aerosoldef + use physconst, only: rair, gravit, pi, avogad + use commondefinitions + use chem_mods, only: adv_mass !molecular weights from mozart + + implicit none + + integer, parameter :: N_COND_VAP = 3 + integer, parameter :: COND_VAP_H2SO4 = 1 + integer, parameter :: COND_VAP_ORG_LV = 2 + integer, parameter :: COND_VAP_ORG_SV = 3 + + real(r8) , public :: normalizedCondensationSink(0:nmodes,N_COND_VAP) ! [m3/#/s] condensation sink per particle in mode i + integer , private :: lifeCycleReceiver(gas_pcnst) ! [-] array of transformation of life cycle tracers + real(r8) , private :: stickingCoefficient(0:nmodes,N_COND_VAP) ! [-] stickingCoefficient for H2SO4 on a mode + integer , private :: cond_vap_map(N_COND_VAP) + + ! Assumed number of monolayers real(r8), parameter, private :: n_so4_monolayers_age = 3.0_r8 - real(r8), parameter, public :: & - dr_so4_monolayers_age = n_so4_monolayers_age * 4.76e-10_r8 -! thickness of the so4 monolayers (m) -! for so4(+nh4), use bi-sulfate mw and 1.77 g/cm3 as in MAM - + ! thickness of the so4 monolayers (m) + ! for so4(+nh4), use bi-sulfate mw and 1.77 g/cm3 as in MAM + real(r8), parameter, public :: dr_so4_monolayers_age = n_so4_monolayers_age * 4.76e-10_r8 contains - subroutine registerCondensation() - - implicit none - - - integer :: iDonor - integer :: l_donor - integer :: tracerIndex - integer :: mode_index_donor - - !These are the lifecycle-species which receive mass when - !the externally mixed modes receive condensate, - !e.g. the receiver of l_so4_n mass is the tracer l_so4_na - lifeCycleReceiver(:) = -99 - lifeCycleReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_a) !create bc int mix from bc in mode 12 - lifeCycleReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ai) !create bc int mix from bc in mode 14 - lifeCycleReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ai) - !!create om int mix from om in mode 14 - lifeCycleReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ai) - !!create bc int mix from bc in mode 0. Note Mass is conserved but not number - - !Sticking coeffcients for H2SO4 condensation - !See table 1 in Kirkevag et al (2013) - !http://www.geosci-model-dev.net/6/207/2013/gmd-6-207-2013.html - !Note: In NorESM1, sticking coefficients of the externally mixed modes were - !used for the internally mixed modes in modallapp. In condtend the internally - !mixed modes had sticking coefficient = 1.0 - !This might be correct, but is too confusing, so here just - !assign based on background aerosol and table 1 in Kirkevag et al - stickingCoefficient(:,:) = 1.0_r8 - stickingCoefficient(MODE_IDX_BC_EXT_AC,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_BC_AIT,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_OMBC_INTMIX_COAT_AIT,:) = 0.5_r8 - stickingCoefficient(MODE_IDX_DST_A2,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_DST_A3,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_BC_NUC,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_OMBC_INTMIX_AIT,:) = 0.5_r8 - - - end subroutine registerCondensation - -!=============================================================================== - - subroutine initializeCondensation() - - !condensation coefficients: - !Theory: Poling et al, "The properties of gases and liquids" - !5th edition, eqn 11-4-4 - - use cam_history, only: addfld, add_default, fieldname_len, horiz_only - implicit none - - real(r8), parameter :: aunit = 1.6606e-27_r8 ![kg] Atomic mass unit - real(r8), parameter :: boltz = 1.3806e-23_r8 ![J/K/molec] - real(r8), parameter :: t0 = 273.15_r8 ![K] standard temperature - real(r8), parameter :: p0 = 101325.0_r8 ! [Pa] Standard pressure - real(r8), parameter :: radair = 1.73e-10_r8 ![m] Typical air molecule collision radius - real(r8), parameter :: Mair = 28.97_r8 ![amu/molec] Molecular weight for dry air - !Diffusion volumes for simple molecules [Poling et al], table 11-1 - real(r8), dimension(N_COND_VAP), parameter :: vad = (/51.96_r8, 208.18_r8, 208.18_r8/) ![cm3/mol] - real(r8), parameter :: vadAir = 19.7_r8 ![cm3/mol] - real(r8), parameter :: aThird = 1.0_r8/3.0_r8 - real(r8), parameter :: cm2Tom2 = 1.e-4_r8 !convert from cm2 ==> m2 - - real(r8), dimension(0:100,0:nmodes,N_COND_VAP) :: DiffusionCoefficient ! [m2/s] Diffusion coefficient - character(len=fieldname_len+3) :: fieldname_donor - character(len=fieldname_len+3) :: fieldname_receiver - character(128) :: long_name - character(8) :: unit - - integer :: nsiz !counter for aerotab sizes - integer :: iChem !counter for chemical species - integer :: mode_index_donor !index for mode - integer :: iMode !Counter for mode - integer :: tracerIndex !counter for chem. spec - - logical :: history_aerosol - logical :: isAlreadyOnList(gas_pcnst) - integer :: cond_vap_idx - - real(r8), dimension(N_COND_VAP) :: mfv ![m] mean free path - real(r8), dimension(N_COND_VAP) :: diff ![m2/s] diffusion coefficient for cond. vap - real(r8) :: molecularWeight !amu/molec molecular weight - real(r8) :: Mdual ![molec/amu] 1/M_1 + 1/M_2 - real(r8) :: rho ![kg/m3] density of component in question - real(r8) :: radmol ![m] radius molecule - real(r8), dimension(N_COND_VAP) :: th !thermal velocity - - !Couple the condenseable vapours to chemical species for properties and indexes - cond_vap_map(COND_VAP_H2SO4) = chemistryIndex(l_h2so4) - cond_vap_map(COND_VAP_ORG_LV) = chemistryIndex(l_soa_lv) - cond_vap_map(COND_VAP_ORG_SV) = chemistryIndex(l_soa_sv) - - do cond_vap_idx = 1, N_COND_VAP - - rho = rhopart(physicsIndex(cond_vap_map(cond_vap_idx))) !pick up densities from aerosoldef - - molecularWeight=adv_mass(cond_vap_map(cond_vap_idx)) !pick up molecular weights from mozart - - !https://en.wikipedia.org/wiki/Thermal_velocity - th(cond_vap_idx) = sqrt(8.0_r8*boltz*t0/(pi*molecularweight*aunit)) ! thermal velocity for H2SO4 in air (m/s) - - !Radius of molecul (straight forward assuming spherical) - radmol=(3.0_r8*molecularWeight*aunit/(4.0_r8*pi*rho))**aThird ! molecule radius - - Mdual=2.0_r8/(1.0_r8/Mair+1.0_r8/molecularWeight) !factor of [1/m_1 + 1_m2] - - !calculating microphysical parameters from equations in Ch. 8 of Seinfeld & Pandis (1998): - mfv(cond_vap_idx)=1.0_r8/(pi*sqrt(1.0_r8+MolecularWeight/Mair)*(radair+radmol)**2*p0/(boltz*t0)) ! mean free path for molec in air (m) - - !Solve eqn 11-4.4 in Poling et al - !(A bit hard to follow units here, but result in the book is in cm2/s).. - !so scale by "cm2Tom2" to get m2/sec - diff(cond_vap_idx) = cm2Tom2 & + subroutine registerCondensation() + + integer :: iDonor + integer :: l_donor + integer :: tracerIndex + integer :: mode_index_donor + + !These are the lifecycle-species which receive mass when + !the externally mixed modes receive condensate, + !e.g. the receiver of l_so4_n mass is the tracer l_so4_na + lifeCycleReceiver(:) = -99 + lifeCycleReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_a) !create bc int mix from bc in mode 12 + lifeCycleReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ai) !create bc int mix from bc in mode 14 + lifeCycleReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ai) + !!create om int mix from om in mode 14 + lifeCycleReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ai) + !!create bc int mix from bc in mode 0. Note Mass is conserved but not number + + !Sticking coeffcients for H2SO4 condensation + !See table 1 in Kirkevag et al (2013) + !http://www.geosci-model-dev.net/6/207/2013/gmd-6-207-2013.html + !Note: In NorESM1, sticking coefficients of the externally mixed modes were + !used for the internally mixed modes in modallapp. In condtend the internally + !mixed modes had sticking coefficient = 1.0 + !This might be correct, but is too confusing, so here just + !assign based on background aerosol and table 1 in Kirkevag et al + stickingCoefficient(:,:) = 1.0_r8 + stickingCoefficient(MODE_IDX_BC_EXT_AC,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_BC_AIT,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_OMBC_INTMIX_COAT_AIT,:) = 0.5_r8 + stickingCoefficient(MODE_IDX_DST_A2,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_DST_A3,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_BC_NUC,:) = 0.3_r8 + stickingCoefficient(MODE_IDX_OMBC_INTMIX_AIT,:) = 0.5_r8 + + end subroutine registerCondensation + + !=============================================================================== + + subroutine initializeCondensation() + + !condensation coefficients: + !Theory: Poling et al, "The properties of gases and liquids" + !5th edition, eqn 11-4-4 + + use cam_history, only: addfld, add_default, fieldname_len, horiz_only + + real(r8), parameter :: aunit = 1.6606e-27_r8 ![kg] Atomic mass unit + real(r8), parameter :: boltz = 1.3806e-23_r8 ![J/K/molec] + real(r8), parameter :: t0 = 273.15_r8 ![K] standard temperature + real(r8), parameter :: p0 = 101325.0_r8 ! [Pa] Standard pressure + real(r8), parameter :: radair = 1.73e-10_r8 ![m] Typical air molecule collision radius + real(r8), parameter :: Mair = 28.97_r8 ![amu/molec] Molecular weight for dry air + !Diffusion volumes for simple molecules [Poling et al], table 11-1 + real(r8), dimension(N_COND_VAP), parameter :: vad = (/51.96_r8, 208.18_r8, 208.18_r8/) ![cm3/mol] + real(r8), parameter :: vadAir = 19.7_r8 ![cm3/mol] + real(r8), parameter :: aThird = 1.0_r8/3.0_r8 + real(r8), parameter :: cm2Tom2 = 1.e-4_r8 !convert from cm2 ==> m2 + + real(r8), dimension(0:100,0:nmodes,N_COND_VAP) :: DiffusionCoefficient ! [m2/s] Diffusion coefficient + character(len=fieldname_len+3) :: fieldname_donor + character(len=fieldname_len+3) :: fieldname_receiver + character(128) :: long_name + character(8) :: unit + + integer :: nsiz !counter for aerotab sizes + integer :: iChem !counter for chemical species + integer :: mode_index_donor !index for mode + integer :: iMode !Counter for mode + integer :: tracerIndex !counter for chem. spec + + logical :: history_aerosol + logical :: isAlreadyOnList(gas_pcnst) + integer :: cond_vap_idx + + real(r8), dimension(N_COND_VAP) :: mfv ![m] mean free path + real(r8), dimension(N_COND_VAP) :: diff ![m2/s] diffusion coefficient for cond. vap + real(r8) :: molecularWeight !amu/molec molecular weight + real(r8) :: Mdual ![molec/amu] 1/M_1 + 1/M_2 + real(r8) :: rho ![kg/m3] density of component in question + real(r8) :: radmol ![m] radius molecule + real(r8), dimension(N_COND_VAP) :: th !thermal velocity + + !Couple the condenseable vapours to chemical species for properties and indexes + cond_vap_map(COND_VAP_H2SO4) = chemistryIndex(l_h2so4) + cond_vap_map(COND_VAP_ORG_LV) = chemistryIndex(l_soa_lv) + cond_vap_map(COND_VAP_ORG_SV) = chemistryIndex(l_soa_sv) + + do cond_vap_idx = 1, N_COND_VAP + + rho = rhopart(physicsIndex(cond_vap_map(cond_vap_idx))) !pick up densities from aerosoldef + + molecularWeight=adv_mass(cond_vap_map(cond_vap_idx)) !pick up molecular weights from mozart + + !https://en.wikipedia.org/wiki/Thermal_velocity + th(cond_vap_idx) = sqrt(8.0_r8*boltz*t0/(pi*molecularweight*aunit)) ! thermal velocity for H2SO4 in air (m/s) + + !Radius of molecul (straight forward assuming spherical) + radmol=(3.0_r8*molecularWeight*aunit/(4.0_r8*pi*rho))**aThird ! molecule radius + + Mdual=2.0_r8/(1.0_r8/Mair+1.0_r8/molecularWeight) !factor of [1/m_1 + 1_m2] + + !calculating microphysical parameters from equations in Ch. 8 of Seinfeld & Pandis (1998): + mfv(cond_vap_idx)=1.0_r8/(pi*sqrt(1.0_r8+MolecularWeight/Mair)*(radair+radmol)**2*p0/(boltz*t0)) ! mean free path for molec in air (m) + + !Solve eqn 11-4.4 in Poling et al + !(A bit hard to follow units here, but result in the book is in cm2/s).. + !so scale by "cm2Tom2" to get m2/sec + diff(cond_vap_idx) = cm2Tom2 & *0.00143_r8*t0**1.75_r8 & - /((p0/1.0e5_r8)*sqrt(Mdual) & - *(((Vad(cond_vap_idx))**aThird+(Vadair)**aThird)**2)) - - !Values used in noresm1: - !real(r8), parameter :: diff = 9.5e-6 !m2/s diffusion coefficient (H2SO4) - !real(r8), parameter :: th = 243.0_r8 !m/s thermal velocity (H2SO4) - !real(r8), parameter :: mfv = 1.65e-8 !m mean free path (H2SO4) - - !Check values obtained here (H2SO4 / SOA) - !write(*,*) 'mfv = ', mfv(cond_vap_idx) !2.800830854409093E-008 / 1.633546464678737E-008 - !write(*,*) ' diff = ', diff(cond_vap_idx) !-> 9.360361706957621E-006 / !-> 4.185923463242946E-006 - !write(*,*) ' th = ', th !-> 242.818542922924 / 185.421069430852 - end do - - do cond_vap_idx = 1, N_COND_VAP - do imode = 0, nmodes !all modes receive condensation - do nsiz = 1, nBinsTab !aerotab sizes - !Correct for non-continuum effects, formula is from - !Chuang and Penner, Tellus, 1995, sticking coeffient from - !Vignati et al, JGR, 2004 - !fxm: make "diff ==> diff (cond_vap_idx) - DiffusionCoefficient(nsiz,imode,cond_vap_idx) = diff(cond_vap_idx) & !original diffusion coefficient - /( & + /((p0/1.0e5_r8)*sqrt(Mdual) & + *(((Vad(cond_vap_idx))**aThird+(Vadair)**aThird)**2)) + + !Values used in noresm1: + !real(r8), parameter :: diff = 9.5e-6 !m2/s diffusion coefficient (H2SO4) + !real(r8), parameter :: th = 243.0_r8 !m/s thermal velocity (H2SO4) + !real(r8), parameter :: mfv = 1.65e-8 !m mean free path (H2SO4) + + !Check values obtained here (H2SO4 / SOA) + !write(*,*) 'mfv = ', mfv(cond_vap_idx) !2.800830854409093E-008 / 1.633546464678737E-008 + !write(*,*) ' diff = ', diff(cond_vap_idx) !-> 9.360361706957621E-006 / !-> 4.185923463242946E-006 + !write(*,*) ' th = ', th !-> 242.818542922924 / 185.421069430852 + end do + + do cond_vap_idx = 1, N_COND_VAP + do imode = 0, nmodes !all modes receive condensation + do nsiz = 1, nBinsTab !aerotab sizes + !Correct for non-continuum effects, formula is from + !Chuang and Penner, Tellus, 1995, sticking coeffient from + !Vignati et al, JGR, 2004 + !fxm: make "diff ==> diff (cond_vap_idx) + DiffusionCoefficient(nsiz,imode,cond_vap_idx) = diff(cond_vap_idx) & !original diffusion coefficient + /( & rBinMidPoint(nsiz)/(rBinMidPoint(nsiz)+mfv(cond_vap_idx)) & !non-continuum correction factor - +4.0_r8*diff(cond_vap_idx)/(stickingCoefficient(imode,cond_vap_idx)*th(cond_vap_idx)*rBinMidPoint(nsiz)) & - ) - enddo - end do !receiver modes - end do - - normalizedCondensationSink(:,:) = 0.0_r8 - !Find sink per particle in mode "imode" - !Eqn 13 in Kulmala et al, Tellus 53B, 2001, pp 479 - !http://onlinelibrary.wiley.com/doi/10.1034/j.1600-0889.2001.530411.x/abstract - do cond_vap_idx =1, N_COND_VAP - do imode = 0, nmodes - do nsiz = 1, nBinsTab - normalizedCondensationSink(imode,cond_vap_idx) = & - normalizedCondensationSink(imode,cond_vap_idx) & - + 4.0_r8*pi & - * DiffusionCoefficient(nsiz,imode,cond_vap_idx) & ![m2/s] diffusion coefficient - * rBinMidPoint(nsiz) & ![m] look up table radius - * normnk(imode,nsiz) ![frc] - end do - end do - end do - - !Initialize output - call phys_getopts(history_aerosol_out = history_aerosol) - - isAlreadyOnList(:) = .FALSE. - do iChem = 1,gas_pcnst - !Does this tracer have a receiver? If yes: It participate in condensation tendencies - if(lifeCycleReceiver(iChem) .gt. 0)then - unit = "kg/m2/s" - fieldname_donor = trim(solsym(iChem))//"condTend" - fieldname_receiver = trim(solsym(lifeCycleReceiver(iChem)))//"condTend" - if(.not. isAlreadyOnList(lifeCycleReceiver(iChem)))then - call addfld( fieldname_receiver, horiz_only, "A", unit, "condensation tendency" ) - isAlreadyOnList(lifeCycleReceiver(iChem))=.TRUE. - end if - call addfld( fieldname_donor, horiz_only, "A", unit, "condensation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - call add_default( fieldname_donor , 1, ' ') - end if - end if - end do - !Need to add so4_a1, soa_na, so4_na, soa_a1 also (which are not parts of the donor-receiver stuff) - fieldname_receiver = trim(solsym(chemistryIndex(l_so4_a1)))//"condTend" - call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency") - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - end if - fieldname_receiver = trim(solsym(chemistryIndex(l_soa_a1)))//"condTend" - call addfld( fieldname_receiver, horiz_only, "A", unit, "condensation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - end if - fieldname_receiver = trim(solsym(chemistryIndex(l_so4_na)))//"condTend" - call addfld( fieldname_receiver, horiz_only, 'A', unit , "condensation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - end if - fieldname_receiver = trim(solsym(chemistryIndex(l_soa_na)))//"condTend" - call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - end if - - - - end subroutine initializeCondensation - - - - subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & - pmid, pdel, dt, ncol, pblh,zm,qh20) - -! Calculate the sulphate nucleation rate, and condensation rate of -! aerosols used for parameterising the transfer of externally mixed -! aitken mode particles into an internal mixture. -! Note the parameterisation for conversion of externally mixed particles -! used the h2so4 lifetime onto the particles, and not a given -! increase in particle radius. Will be improved in future versions of the model -! Added input for h2so4 and soa nucleation: soa_lv_gasprod, soa_sv_gasprod, pblh,zm,qh20 (cka) - - use cam_history, only: outfld,fieldname_len -!nuctst3+ use koagsub, only: normalizedCoagulationSink,receiverMode,numberOfCoagulationReceivers ! h2so4 and soa nucleation(cka) -! use koagsub, only: normCoagSinkMode1,normalizedCoagulationSink,receiverMode,numberOfCoagulationReceivers ! h2so4 and soa nucleation(cka) -!nuctst3- -!ak+ - use koagsub, only: normalizedCoagulationSink,receiverMode,numberOfCoagulationReceivers, & - numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd -!ak- - use constituents, only: pcnst ! h2so4 and soa nucleation (cka) - - implicit none - - ! arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of columns - real(r8), intent(in) :: temperature(pcols,pver) ! Temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] pressure at mid point - real(r8), intent(in) :: pdel(pcols,pver) ! [Pa] difference in grid cell - real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8), intent(in) :: cond_vap_gasprod(pcols,pver,N_COND_VAP) ! TMR [kg/kg/sec]] production rate of H2SO4 (gas prod - aq phase uptake) - real(r8), intent(in) :: dt ! Time step - ! Needed for soa nucleation treatment - real(r8), intent(in) :: pblh(pcols) ! pbl height (m) - real(r8), intent(in) :: zm(pcols,pverp) ! midlayer geopotential height above the surface (m) (pver+1) - real(r8), intent(in) :: qh20(pcols,pver) ! specific humidity (kg/kg) - - ! local - character(len=fieldname_len+3) :: fieldname - integer :: i,k,nsiz - integer :: mode_index_donor ![idx] index of mode donating mass - integer :: mode_index_receiver ![idx] index of mode receiving mass - integer :: tracerIndex - integer :: l_donor - integer :: l_receiver - integer :: iDonor ![idx] counter for externally mixed modes - real(r8) :: condensationSink(0:nmodes, N_COND_VAP)![1/s] loss rate per mode (mixture) - real(r8) :: condensationSinkFraction(pcols,pver,numberOfExternallyMixedModes,N_COND_VAP) ![frc] - real(r8) :: sumCondensationSink(pcols,pver, N_COND_VAP) ![1/s] sum of condensation sink - real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost - real(r8) :: numberConcentration(0:nmodes) ![#/m3] number concentration - real(r8) :: numberConcentrationExtMix(pcols,pver,numberOfExternallyMixedModes) - real(r8), dimension(pcols, gas_pcnst) :: coltend - real(r8), dimension(pcols) :: tracer_coltend - - real(r8) :: intermediateConcentration(pcols,pver,N_COND_VAP) - real(r8) :: rhoAir(pcols,pver) ![kg/m3] density of air -! Volume of added material from condensate; surface area of core particle; - real(r8) :: volume_shell, area_core,vol_monolayer - real (r8) :: frac_transfer ! Fraction of hydrophobic material converted to an internally mixed mode - logical :: history_aerosol - character(128) :: long_name ![-] needed for diagnostics - -!cka:+ - ! needed for h2so4 and soa nucleation treatment - integer :: modeIndexReceiverCoag !Index of modes receiving coagulate - integer :: iCoagReceiver !counter for species receiving coagulate - real(r8) :: coagulationSink(pcols,pver) ![1/s] coaglation loss for SO4_n and soa_n -!nuctst3+ -! real(r8) :: normCSmode1(pcols,pver) !normalized coagulation from self coagulation (simplified) -!nuctst3- - real(r8), parameter :: lvocfrac=0.5 !Fraction of organic oxidation products with low enough - !volatility to enter nucleation mode particles (1-24 nm) - real(r8) :: soa_lv_forNucleation(pcols,pver) ![kg/kg] soa gas available for nucleation - real(r8) :: gasLost(pcols,pver,N_COND_VAP) ![kg/kg] budget terms on H2SO4 (gas) - real(r8) :: fracNucl(pcols,pver,N_COND_VAP) ! [frc] fraction of gas nucleated - real(r8) :: firstOrderLossRateNucl(pcols,pver,N_COND_VAP) ![1/s] first order loss rate due to nucleation - real(r8) :: nuclso4(pcols,pver) ![kg/kg/s] Nucleated so4 mass tendency from RM's parameterization - real(r8) :: nuclsoa(pcols,pver) ![kg/kg/s] Nucleated soa mass tendency from RM's parameterization - integer :: cond_vap_idx - + +4.0_r8*diff(cond_vap_idx)/(stickingCoefficient(imode,cond_vap_idx)*th(cond_vap_idx)*rBinMidPoint(nsiz)) & + ) + enddo + end do !receiver modes + end do + + normalizedCondensationSink(:,:) = 0.0_r8 + !Find sink per particle in mode "imode" + !Eqn 13 in Kulmala et al, Tellus 53B, 2001, pp 479 + !http://onlinelibrary.wiley.com/doi/10.1034/j.1600-0889.2001.530411.x/abstract + do cond_vap_idx =1, N_COND_VAP + do imode = 0, nmodes + do nsiz = 1, nBinsTab + normalizedCondensationSink(imode,cond_vap_idx) = & + normalizedCondensationSink(imode,cond_vap_idx) & + + 4.0_r8*pi & + * DiffusionCoefficient(nsiz,imode,cond_vap_idx) & ![m2/s] diffusion coefficient + * rBinMidPoint(nsiz) & ![m] look up table radius + * normnk(imode,nsiz) ![frc] + end do + end do + end do + + !Initialize output + call phys_getopts(history_aerosol_out = history_aerosol) + + isAlreadyOnList(:) = .FALSE. + do iChem = 1,gas_pcnst + !Does this tracer have a receiver? If yes: It participate in condensation tendencies + if(lifeCycleReceiver(iChem) .gt. 0)then + unit = "kg/m2/s" + fieldname_donor = trim(solsym(iChem))//"condTend" + fieldname_receiver = trim(solsym(lifeCycleReceiver(iChem)))//"condTend" + if(.not. isAlreadyOnList(lifeCycleReceiver(iChem)))then + call addfld( fieldname_receiver, horiz_only, "A", unit, "condensation tendency" ) + isAlreadyOnList(lifeCycleReceiver(iChem))=.TRUE. + end if + call addfld( fieldname_donor, horiz_only, "A", unit, "condensation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + call add_default( fieldname_donor , 1, ' ') + end if + end if + end do + !Need to add so4_a1, soa_na, so4_na, soa_a1 also (which are not parts of the donor-receiver stuff) + fieldname_receiver = trim(solsym(chemistryIndex(l_so4_a1)))//"condTend" + call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency") + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + end if + fieldname_receiver = trim(solsym(chemistryIndex(l_soa_a1)))//"condTend" + call addfld( fieldname_receiver, horiz_only, "A", unit, "condensation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + end if + fieldname_receiver = trim(solsym(chemistryIndex(l_so4_na)))//"condTend" + call addfld( fieldname_receiver, horiz_only, 'A', unit , "condensation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + end if + fieldname_receiver = trim(solsym(chemistryIndex(l_soa_na)))//"condTend" + call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + end if + + + + end subroutine initializeCondensation + + + + subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & + pmid, pdel, dt, ncol, pblh,zm,qh20) + + ! Calculate the sulphate nucleation rate, and condensation rate of + ! aerosols used for parameterising the transfer of externally mixed + ! aitken mode particles into an internal mixture. + ! Note the parameterisation for conversion of externally mixed particles + ! used the h2so4 lifetime onto the particles, and not a given + ! increase in particle radius. Will be improved in future versions of the model + ! Added input for h2so4 and soa nucleation: soa_lv_gasprod, soa_sv_gasprod, pblh,zm,qh20 (cka) + + use cam_history, only: outfld,fieldname_len + use koagsub, only: normalizedCoagulationSink,receiverMode,numberOfCoagulationReceivers + use koagsub, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd + use constituents, only: pcnst ! h2so4 and soa nucleation (cka) + + ! arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of columns + real(r8), intent(in) :: temperature(pcols,pver) ! Temperature (K) + real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] pressure at mid point + real(r8), intent(in) :: pdel(pcols,pver) ! [Pa] difference in grid cell + real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture + real(r8), intent(in) :: cond_vap_gasprod(pcols,pver,N_COND_VAP) ! TMR [kg/kg/sec]] production rate of H2SO4 (gas prod - aq phase uptake) + real(r8), intent(in) :: dt ! Time step + + ! Needed for soa nucleation treatment + real(r8), intent(in) :: pblh(pcols) ! pbl height (m) + real(r8), intent(in) :: zm(pcols,pverp) ! midlayer geopotential height above the surface (m) (pver+1) + real(r8), intent(in) :: qh20(pcols,pver) ! specific humidity (kg/kg) + + ! local + character(len=fieldname_len+3) :: fieldname + integer :: i,k,nsiz + integer :: mode_index_donor ![idx] index of mode donating mass + integer :: mode_index_receiver ![idx] index of mode receiving mass + integer :: tracerIndex + integer :: l_donor + integer :: l_receiver + integer :: iDonor ![idx] counter for externally mixed modes + real(r8) :: condensationSink(0:nmodes, N_COND_VAP)![1/s] loss rate per mode (mixture) + real(r8) :: condensationSinkFraction(pcols,pver,numberOfExternallyMixedModes,N_COND_VAP) ![frc] + real(r8) :: sumCondensationSink(pcols,pver, N_COND_VAP) ![1/s] sum of condensation sink + real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost + real(r8) :: numberConcentration(0:nmodes) ![#/m3] number concentration + real(r8) :: numberConcentrationExtMix(pcols,pver,numberOfExternallyMixedModes) + real(r8) :: coltend(pcols, gas_pcnst) + real(r8) :: tracer_coltend(pcols) + real(r8) :: intermediateConcentration(pcols,pver,N_COND_VAP) + real(r8) :: rhoAir(pcols,pver) ![kg/m3] density of air + + ! Volume of added material from condensate; surface area of core particle; + real(r8) :: volume_shell, area_core,vol_monolayer + real (r8) :: frac_transfer ! Fraction of hydrophobic material converted to an internally mixed mode + logical :: history_aerosol + character(128) :: long_name ![-] needed for diagnostics + + ! needed for h2so4 and soa nucleation treatment + integer :: modeIndexReceiverCoag !Index of modes receiving coagulate + integer :: iCoagReceiver !counter for species receiving coagulate + real(r8) :: coagulationSink(pcols,pver) ![1/s] coaglation loss for SO4_n and soa_n + real(r8), parameter :: lvocfrac=0.5 !Fraction of organic oxidation products with low enough + + !volatility to enter nucleation mode particles (1-24 nm) + real(r8) :: soa_lv_forNucleation(pcols,pver) ![kg/kg] soa gas available for nucleation + real(r8) :: gasLost(pcols,pver,N_COND_VAP) ![kg/kg] budget terms on H2SO4 (gas) + real(r8) :: fracNucl(pcols,pver,N_COND_VAP) ![frc] fraction of gas nucleated + real(r8) :: firstOrderLossRateNucl(pcols,pver,N_COND_VAP) ![1/s] first order loss rate due to nucleation + real(r8) :: nuclso4(pcols,pver) ![kg/kg/s] Nucleated so4 mass tendency from RM's parameterization + real(r8) :: nuclsoa(pcols,pver) ![kg/kg/s] Nucleated soa mass tendency from RM's parameterization + integer :: cond_vap_idx + !Initialize h2so4 and soa nucl variables - coagulationSink(:,:)=0.0_r8 + coagulationSink(:,:)=0.0_r8 condensationSinkFraction(:,:,:,:) = 0.0_r8 !Sink to the coming "receiver" of any vapour numberConcentrationExtMix(:,:,:) = 0.0_r8 -!ak+ -! normCSmode1(:,:)=0.0_r8 -!ak- do k=1,pver - do i=1,ncol - - condensationSink(:,:) = 0.0_r8 !Sink to the coming "receiver" of any vapour + do i=1,ncol - !NB: The following is duplicated code, coordinate with koagsub!! - !Initialize number concentration for this receiver + condensationSink(:,:) = 0.0_r8 !Sink to the coming "receiver" of any vapour - !Air density - rhoAir(i,k) = pmid(i,k)/rair/temperature(i,k) + !NB: The following is duplicated code, coordinate with koagsub!! + !Initialize number concentration for this receiver + !Air density + rhoAir(i,k) = pmid(i,k)/rair/temperature(i,k) - numberConcentration(:) = 0.0_r8 + numberConcentration(:) = 0.0_r8 - !Go though all modes receiving condensation - do mode_index_receiver = 0, nmodes + !Go though all modes receiving condensation + do mode_index_receiver = 0, nmodes - !Go through all core species in that mode - do tracerIndex = 1, getNumberOfBackgroundTracersInMode(mode_index_receiver) + !Go through all core species in that mode + do tracerIndex = 1, getNumberOfBackgroundTracersInMode(mode_index_receiver) - !Find the lifecycle-specie receiving the condensation - l_receiver = getTracerIndex(mode_index_receiver, tracerIndex, .true.) + !Find the lifecycle-specie receiving the condensation + l_receiver = getTracerIndex(mode_index_receiver, tracerIndex, .true.) - !Add up the number concentration of the receiving mode [#/m3] - numberConcentration(mode_index_receiver) = numberConcentration(mode_index_receiver) & !previous value - + q(i,k,l_receiver) & !kg/kg - / rhopart(physicsIndex(l_receiver)) & !m3/kg ==> m3_{aer}/kg_{air} - * volumeToNumber(mode_index_receiver) & !#/m3 ==> #/kg_{air} - * rhoAir(i,k) !kg/m3 ==> #/m3_{air} - end do !Lifecycle "core" species in this mode - enddo + !Add up the number concentration of the receiving mode [#/m3] + numberConcentration(mode_index_receiver) = numberConcentration(mode_index_receiver) & !previous value + + q(i,k,l_receiver) & !kg/kg + / rhopart(physicsIndex(l_receiver)) & !m3/kg ==> m3_{aer}/kg_{air} + * volumeToNumber(mode_index_receiver) & !#/m3 ==> #/kg_{air} + * rhoAir(i,k) !kg/m3 ==> #/m3_{air} + end do !Lifecycle "core" species in this mode + enddo - !All modes are condensation receivers - do cond_vap_idx=1,N_COND_VAP - do mode_index_receiver = 0, nmodes + !All modes are condensation receivers + do cond_vap_idx=1,N_COND_VAP + do mode_index_receiver = 0, nmodes - !This is the loss rate a gas molecule will see due to aerosol surface area - condensationSink(mode_index_receiver,cond_vap_idx) = normalizedCondensationSink(mode_index_receiver,cond_vap_idx) & ![m3/#/s] - * numberConcentration(mode_index_receiver) ![#/m3] - !==> [1/s] - end do !Loop over receivers - end do + !This is the loss rate a gas molecule will see due to aerosol surface area + condensationSink(mode_index_receiver,cond_vap_idx) = normalizedCondensationSink(mode_index_receiver,cond_vap_idx) & ![m3/#/s] + * numberConcentration(mode_index_receiver) ![#/m3] + !==> [1/s] + end do !Loop over receivers + end do - !Find concentration after condensation of all - !condenseable vapours - do cond_vap_idx=1,N_COND_VAP + !Find concentration after condensation of all + !condenseable vapours + do cond_vap_idx=1,N_COND_VAP - !sum of cond. sink for this vapour [1/s] - sumCondensationSink(i,k,cond_vap_idx) = sum(condensationSink(:,cond_vap_idx)) + !sum of cond. sink for this vapour [1/s] + sumCondensationSink(i,k,cond_vap_idx) = sum(condensationSink(:,cond_vap_idx)) - !Solve the intermediate (end of timestep) concentration using - !euler backward solution C_{old} + P *dt - L*C_{new}*dt = C_{new} ==> - !Cnew -Cold = prod - loss ==> - intermediateConcentration(i,k,cond_vap_idx) = & - ( q(i,k,cond_vap_map(cond_vap_idx)) + cond_vap_gasprod(i,k,cond_vap_idx)*dt ) & - / (1.0_r8 + sumCondensationSink(i,k,cond_vap_idx)*dt) - end do + !Solve the intermediate (end of timestep) concentration using + !euler backward solution C_{old} + P *dt - L*C_{new}*dt = C_{new} ==> + !Cnew -Cold = prod - loss ==> + intermediateConcentration(i,k,cond_vap_idx) = & + ( q(i,k,cond_vap_map(cond_vap_idx)) + cond_vap_gasprod(i,k,cond_vap_idx)*dt ) & + / (1.0_r8 + sumCondensationSink(i,k,cond_vap_idx)*dt) + end do - !Save the fraction of condensation sink for the externally mixed modes - !(Needed below to find volume shell) - do cond_vap_idx=1,N_COND_VAP + !Save the fraction of condensation sink for the externally mixed modes + !(Needed below to find volume shell) + do cond_vap_idx=1,N_COND_VAP - do iDonor = 1,numberOfExternallyMixedModes - !Find the mode in question - mode_index_donor = externallyMixedMode(iDonor) + do iDonor = 1,numberOfExternallyMixedModes + !Find the mode in question + mode_index_donor = externallyMixedMode(iDonor) - !Remember fraction of cond sink for this mode - condensationSinkFraction(i,k,iDonor,cond_vap_idx) = & - condensationSink(mode_index_donor,cond_vap_idx) & - / sumCondensationSink(i,k,cond_vap_idx) + !Remember fraction of cond sink for this mode + condensationSinkFraction(i,k,iDonor,cond_vap_idx) = & + condensationSink(mode_index_donor,cond_vap_idx) & + / sumCondensationSink(i,k,cond_vap_idx) - !Remember number concentration in this mode - numberConcentrationExtMix(i,k,iDonor) = & + !Remember number concentration in this mode + numberConcentrationExtMix(i,k,iDonor) = & numberConcentration(mode_index_donor) - end do - end do - - !Assume only a fraction of ORG_LV left can contribute to nucleation - soa_lv_forNucleation(i,k) = lvocfrac*intermediateConcentration(i,k,COND_VAP_ORG_LV) !fraction of soa_lv left that is assumend to have low enough - !volatility to nucleate. - - modeIndexReceiverCoag = 0 - !Sum coagulation sink for nucleated so4 and soa particles over all receivers of coagulate. Needed for RM's nucleation code - !OBS - looks like RM's coagulation sink is multiplied by 10^-12?? - do iCoagReceiver = 1, numberOfCoagulationReceivers - - modeIndexReceiverCoag = receiverMode(iCoagReceiver) - - coagulationSink(i,k) = & ![1/s] - coagulationSink(i,k) + & ![1/] previous value - normalizedCoagulationSink(modeIndexReceiverCoag,MODE_IDX_SO4SOA_AIT) & ![m3/#/s] - * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) - end do !coagulation sink - -!nuctst3+ -! coagulationSink(i,k) = coagulationSink(i,k) + & -! normCoagSinkMode1*numberConcentration(1) -! if (i.eq.1.and.k.eq.30) write(*,*) 'cSink, dcSink = ', coagulationSink(i,k), normCoagSinkMode1*numberConcentration(1) -! if (i.eq.1.and.k.eq.30) write(*,*) 'nConc1 = ', numberConcentration(1) -!nuctst3- -!ak+ - !Sum coagulation sink for nucleated so4 and soa particles over all additional - !receivers od coagulate (not directly affecting the life-cycle). - do iCoagReceiver = 1, numberOfAddCoagReceivers - - modeIndexReceiverCoag = addReceiverMode(iCoagReceiver) - - coagulationSink(i,k) = & ![1/s] - coagulationSink(i,k) + & ![1/] previous value - normCoagSinkAdd(iCoagReceiver) & ![m3/#/s] - * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) - end do !coagulation sink -!ak- - - end do !index i - end do !index k - - !Calculate nucleated masses of so4 and soa (nuclso4, nuclsoa) - !following RM's parameterization (cka) - call aeronucl(lchnk,ncol,temperature, pmid, qh20, & - intermediateConcentration(:,:,COND_VAP_H2SO4), soa_lv_forNucleation, & - coagulationSink, nuclso4, nuclsoa, zm, pblh) - - - firstOrderLossRateNucl(:,:,:)=0.0_r8 - do k=1,pver - do i=1,ncol - - !First order loss rate (1/s) for nucleation - firstOrderLossRateNucl(i,k,COND_VAP_H2SO4) = nuclSo4(i,k)/intermediateConcentration(i,k,COND_VAP_H2SO4) - - !First order loss rate (1/s) for nucleation - firstOrderLossRateNucl(i,k,COND_VAP_ORG_LV) = nuclSOA(i,k)/intermediateConcentration(i,k,COND_VAP_ORG_LV) - - do cond_vap_idx = 1,N_COND_VAP - !Solve implicitly (again) - !C_new - C_old = PROD_{gas} - CS*C_new*dt - LR_{nucl}*C_new => - intermediateConcentration(i,k,cond_vap_idx) = & - ( q(i,k,cond_vap_map(cond_vap_idx)) + cond_vap_gasprod(i,k,cond_vap_idx)*dt ) & - / (1.0_r8 + sumCondensationSink(i,k,cond_vap_idx)*dt + firstOrderLossRateNucl(i,k,cond_vap_idx)*dt) - - !fraction nucleated - fracNucl(i,k,cond_vap_idx) = firstOrderLossRateNucl(i,k,cond_vap_idx) & - /(firstOrderLossRateNucl(i,k,cond_vap_idx) + sumCondensationSink(i,k,cond_vap_idx)) - !From budget, we get: lost = prod -cnew + cold - gasLost(i,k,cond_vap_idx) = cond_vap_gasprod(i,k,cond_vap_idx)*dt & !Produced - + q(i,k,cond_vap_map(cond_vap_idx)) & !cold - - intermediateConcentration(i,k,cond_vap_idx) !cnew - - end do !cond_vap_idx - - !Add nuceated mass to so4_na mode - q(i,k,chemistryIndex(l_so4_na)) = q(i,k,chemistryIndex(l_so4_na)) & - + gasLost(i,k,COND_VAP_H2SO4)*fracNucl(i,k,COND_VAP_H2SO4) - - !H2SO4 condensate - q(i,k,chemistryIndex(l_so4_a1)) = q(i,k,chemistryIndex(l_so4_a1)) & - + gasLost(i,k,COND_VAP_H2SO4)*(1.0_r8-fracNucl(i,k,COND_VAP_H2SO4)) - - !Add nucleated mass to soa_na mode - q(i,k,chemistryIndex(l_soa_na)) = q(i,k,chemistryIndex(l_soa_na)) & - + gasLost(i,k,COND_VAP_ORG_LV)*fracNucl(i,k,COND_VAP_ORG_LV) - - !Organic condensate (from both soa_lv and soa_sv) goes to the soaCondensateReceiver tracer (cka) - q(i,k,chemistryIndex(l_soa_a1)) = q(i,k,chemistryIndex(l_soa_a1)) & - + gasLost(i,k,COND_VAP_ORG_SV) & ! "semi volatile" can not nucleate - + gasLost(i,k,COND_VAP_ORG_LV)*(1.0_r8-fracNucl(i,k,COND_VAP_ORG_LV)) ! part of low volatile which does not nucleate - - !condenseable vapours - q(i,k,chemistryIndex(l_h2so4)) = intermediateConcentration(i,k,COND_VAP_H2SO4) - q(i,k,chemistryIndex(l_soa_lv)) = intermediateConcentration(i,k,COND_VAP_ORG_LV) - q(i,k,chemistryIndex(l_soa_sv)) = intermediateConcentration(i,k,COND_VAP_ORG_SV) - - - !Condensation transfers mass from externally mixed to internally mixed modes - do iDonor = 1,numberOfExternallyMixedModes - - !Find the mode in question - mode_index_donor = externallyMixedMode(iDonor) - - if(getNumberOfTracersInMode(mode_index_donor) .eq. 0)then - cycle - end if - - volume_shell = 0.0_r8 - do cond_vap_idx = 1, N_COND_VAP - - !Add up volume shell for this - !condenseable vapour - volume_shell = volume_shell & + end do + end do + + !Assume only a fraction of ORG_LV left can contribute to nucleation + soa_lv_forNucleation(i,k) = lvocfrac*intermediateConcentration(i,k,COND_VAP_ORG_LV) !fraction of soa_lv left that is assumend to have low enough + !volatility to nucleate. + + modeIndexReceiverCoag = 0 + !Sum coagulation sink for nucleated so4 and soa particles over all receivers of coagulate. Needed for RM's nucleation code + !OBS - looks like RM's coagulation sink is multiplied by 10^-12?? + do iCoagReceiver = 1, numberOfCoagulationReceivers + + modeIndexReceiverCoag = receiverMode(iCoagReceiver) + + coagulationSink(i,k) = & ![1/s] + coagulationSink(i,k) + & ![1/] previous value + normalizedCoagulationSink(modeIndexReceiverCoag,MODE_IDX_SO4SOA_AIT) & ![m3/#/s] + * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) + end do !coagulation sink + + !Sum coagulation sink for nucleated so4 and soa particles over all additional + !receivers od coagulate (not directly affecting the life-cycle). + do iCoagReceiver = 1, numberOfAddCoagReceivers + + modeIndexReceiverCoag = addReceiverMode(iCoagReceiver) + + coagulationSink(i,k) = & ![1/s] + coagulationSink(i,k) + & ![1/] previous value + normCoagSinkAdd(iCoagReceiver) & ![m3/#/s] + * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) + end do !coagulation sink + + end do !index i + end do !index k + + !Calculate nucleated masses of so4 and soa (nuclso4, nuclsoa) + !following RM's parameterization (cka) + call aeronucl(lchnk,ncol,temperature, pmid, qh20, & + intermediateConcentration(:,:,COND_VAP_H2SO4), soa_lv_forNucleation, & + coagulationSink, nuclso4, nuclsoa, zm, pblh) + + + firstOrderLossRateNucl(:,:,:)=0.0_r8 + do k=1,pver + do i=1,ncol + + !First order loss rate (1/s) for nucleation + firstOrderLossRateNucl(i,k,COND_VAP_H2SO4) = nuclSo4(i,k)/intermediateConcentration(i,k,COND_VAP_H2SO4) + + !First order loss rate (1/s) for nucleation + firstOrderLossRateNucl(i,k,COND_VAP_ORG_LV) = nuclSOA(i,k)/intermediateConcentration(i,k,COND_VAP_ORG_LV) + + do cond_vap_idx = 1,N_COND_VAP + !Solve implicitly (again) + !C_new - C_old = PROD_{gas} - CS*C_new*dt - LR_{nucl}*C_new => + intermediateConcentration(i,k,cond_vap_idx) = & + ( q(i,k,cond_vap_map(cond_vap_idx)) + cond_vap_gasprod(i,k,cond_vap_idx)*dt ) & + / (1.0_r8 + sumCondensationSink(i,k,cond_vap_idx)*dt + firstOrderLossRateNucl(i,k,cond_vap_idx)*dt) + + !fraction nucleated + fracNucl(i,k,cond_vap_idx) = firstOrderLossRateNucl(i,k,cond_vap_idx) & + /(firstOrderLossRateNucl(i,k,cond_vap_idx) + sumCondensationSink(i,k,cond_vap_idx)) + !From budget, we get: lost = prod -cnew + cold + gasLost(i,k,cond_vap_idx) = cond_vap_gasprod(i,k,cond_vap_idx)*dt & !Produced + + q(i,k,cond_vap_map(cond_vap_idx)) & !cold + - intermediateConcentration(i,k,cond_vap_idx) !cnew + + end do !cond_vap_idx + + !Add nuceated mass to so4_na mode + q(i,k,chemistryIndex(l_so4_na)) = q(i,k,chemistryIndex(l_so4_na)) & + + gasLost(i,k,COND_VAP_H2SO4)*fracNucl(i,k,COND_VAP_H2SO4) + + !H2SO4 condensate + q(i,k,chemistryIndex(l_so4_a1)) = q(i,k,chemistryIndex(l_so4_a1)) & + + gasLost(i,k,COND_VAP_H2SO4)*(1.0_r8-fracNucl(i,k,COND_VAP_H2SO4)) + + !Add nucleated mass to soa_na mode + q(i,k,chemistryIndex(l_soa_na)) = q(i,k,chemistryIndex(l_soa_na)) & + + gasLost(i,k,COND_VAP_ORG_LV)*fracNucl(i,k,COND_VAP_ORG_LV) + + !Organic condensate (from both soa_lv and soa_sv) goes to the soaCondensateReceiver tracer (cka) + q(i,k,chemistryIndex(l_soa_a1)) = q(i,k,chemistryIndex(l_soa_a1)) & + + gasLost(i,k,COND_VAP_ORG_SV) & ! "semi volatile" can not nucleate + + gasLost(i,k,COND_VAP_ORG_LV)*(1.0_r8-fracNucl(i,k,COND_VAP_ORG_LV)) ! part of low volatile which does not nucleate + + !condenseable vapours + q(i,k,chemistryIndex(l_h2so4)) = intermediateConcentration(i,k,COND_VAP_H2SO4) + q(i,k,chemistryIndex(l_soa_lv)) = intermediateConcentration(i,k,COND_VAP_ORG_LV) + q(i,k,chemistryIndex(l_soa_sv)) = intermediateConcentration(i,k,COND_VAP_ORG_SV) + + + !Condensation transfers mass from externally mixed to internally mixed modes + do iDonor = 1,numberOfExternallyMixedModes + + !Find the mode in question + mode_index_donor = externallyMixedMode(iDonor) + + if(getNumberOfTracersInMode(mode_index_donor) .eq. 0)then + cycle + end if + + volume_shell = 0.0_r8 + do cond_vap_idx = 1, N_COND_VAP + + !Add up volume shell for this + !condenseable vapour + volume_shell = volume_shell & + condensationSinkFraction(i,k,iDonor,cond_vap_idx) & ![frc] * gasLost(i,k,cond_vap_idx)*(1.0_r8-fracNucl(i,k,cond_vap_idx)) & ![kg/kg] * invRhoPart(physicsIndex(cond_vap_map(cond_vap_idx))) & !*[m3/kg] ==> [m3/kg_{air} * rhoAir(i,k) !*[kg/m3] ==> m3/m3 - - end do - - area_core=numberConcentrationExtMix(i,k,iDonor)*numberToSurface(mode_index_donor) !#/m3 * m2/# ==> m2/m3 - vol_monolayer=area_core*dr_so4_monolayers_age - - ! Small fraction retained to avoid numerical irregularities - frac_transfer=min((volume_shell/vol_monolayer),0.999_r8) - - !How many tracers exist in donor mode? - !The "donor" is the externally mixed mode which will soon - !become internally mixed. The externally mixed is donating mass - !and the internally mixed is receiving... - do tracerIndex = 1, getNumberOfTracersInMode(mode_index_donor) - - !Indexes here are in "chemistry space" - l_donor = getTracerIndex(mode_index_donor, tracerIndex,.true.) - l_receiver = lifeCycleReceiver(l_donor) - - if( l_receiver .le. 0)then - stop !something wrong - endif - - !Transfer from donor to receiver takes into account - !fraction transferred - totalLoss(i,k,l_donor) = frac_transfer*q(i,k,l_donor) - q(i,k,l_donor) = q(i,k,l_donor) - totalLoss(i,k,l_donor) - q(i,k,l_receiver) = q(i,k,l_receiver) + totalLoss(i,k,l_donor) - end do !tracers in mode - end do !loop over receivers - end do !physical index k - end do !physical index i - - !Output for diagnostics - call phys_getopts(history_aerosol_out = history_aerosol) - - if(history_aerosol)then - coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst - !Check if species contributes to condensation - if(lifeCycleReceiver(i) .gt. 0)then - !Loss from the donor specie - tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit/dt - coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative (loss for donor) - coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) - endif - end do - - ! Remove so4_n ---> directly into so4_na - coltend(:ncol,chemistryIndex(l_so4_na)) = coltend(:ncol,chemistryIndex(l_so4_na)) + & - sum( & - gasLost(:ncol,:,COND_VAP_H2SO4) & - *fracNucl(:ncol,:,COND_VAP_H2SO4)*pdel(:ncol,:) , 2 & - )/gravit/dt - - !Take into account H2SO4 (gas) condensed in budget - coltend(:ncol,chemistryIndex(l_so4_a1)) = coltend(:ncol,chemistryIndex(l_so4_a1)) + & - sum( & - gasLost(:ncol,:,COND_VAP_H2SO4) & - *(1.0_r8 - fracNucl(:ncol,:,COND_VAP_H2SO4))*pdel(:ncol,:) , 2 & - )/gravit/dt - - !Take into account soa_lv (gas) nucleated in budget - coltend(:ncol,chemistryIndex(l_soa_na)) = coltend(:ncol,chemistryIndex(l_soa_na)) + & - sum( & - gasLost(:ncol,:,COND_VAP_ORG_LV) & - *fracNucl(:ncol,:,COND_VAP_ORG_LV)*pdel(:ncol,:) , 2 & - )/gravit/dt - - !Take into account soa gas condensed in the budget (both LV and SV) - coltend(:ncol,chemistryIndex(l_soa_a1)) = coltend(:ncol,chemistryIndex(l_soa_a1)) + & - sum( & - gasLost(:ncol,:,COND_VAP_ORG_LV) & - *(1.0_r8 - fracNucl(:ncol,:,COND_VAP_ORG_LV))*pdel(:ncol,:) , 2 & - )/gravit/dt & - + & - sum( & - gasLost(:ncol,:,COND_VAP_ORG_SV)*pdel(:ncol,:) , 2 & - )/gravit/dt - - do i=1,gas_pcnst - if(lifeCycleReceiver(i) .gt. 0 )then - long_name= trim(solsym(i))//"condTend" - call outfld(long_name, coltend(:ncol,i), pcols, lchnk) - long_name= trim(solsym(lifeCycleReceiver(i)))//"condTend" - call outfld(long_name, coltend(:ncol,lifeCycleReceiver(i)),pcols,lchnk) - end if - end do - long_name=trim(solsym(chemistryIndex(l_so4_a1)))//"condTend" - call outfld(long_name, coltend(:ncol,chemistryIndex(l_so4_a1)),pcols,lchnk) - long_name=trim(solsym(chemistryIndex(l_soa_a1)))//"condTend" - call outfld(long_name, coltend(:ncol,chemistryIndex(l_soa_a1)),pcols,lchnk) - long_name=trim(solsym(chemistryIndex(l_so4_na)))//"condTend" - call outfld(long_name, coltend(:ncol,chemistryIndex(l_so4_na)),pcols,lchnk) - long_name=trim(solsym(chemistryIndex(l_soa_na)))//"condTend" - call outfld(long_name, coltend(:ncol,chemistryIndex(l_soa_na)),pcols,lchnk) - - endif - - - return - end subroutine condtend_sub + end do + + area_core=numberConcentrationExtMix(i,k,iDonor)*numberToSurface(mode_index_donor) !#/m3 * m2/# ==> m2/m3 + vol_monolayer=area_core*dr_so4_monolayers_age + + ! Small fraction retained to avoid numerical irregularities + frac_transfer=min((volume_shell/vol_monolayer),0.999_r8) + + !How many tracers exist in donor mode? + !The "donor" is the externally mixed mode which will soon + !become internally mixed. The externally mixed is donating mass + !and the internally mixed is receiving... + do tracerIndex = 1, getNumberOfTracersInMode(mode_index_donor) + + !Indexes here are in "chemistry space" + l_donor = getTracerIndex(mode_index_donor, tracerIndex,.true.) + l_receiver = lifeCycleReceiver(l_donor) + + if( l_receiver .le. 0)then + stop !something wrong + endif + + !Transfer from donor to receiver takes into account + !fraction transferred + totalLoss(i,k,l_donor) = frac_transfer*q(i,k,l_donor) + q(i,k,l_donor) = q(i,k,l_donor) - totalLoss(i,k,l_donor) + q(i,k,l_receiver) = q(i,k,l_receiver) + totalLoss(i,k,l_donor) + end do !tracers in mode + end do !loop over receivers + end do !physical index k + end do !physical index i + + !Output for diagnostics + call phys_getopts(history_aerosol_out = history_aerosol) + + if(history_aerosol)then + coltend(:ncol,:) = 0.0_r8 + do i=1,gas_pcnst + !Check if species contributes to condensation + if(lifeCycleReceiver(i) .gt. 0)then + !Loss from the donor specie + tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit/dt + coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative (loss for donor) + coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) + endif + end do + + ! Remove so4_n ---> directly into so4_na + coltend(:ncol,chemistryIndex(l_so4_na)) = coltend(:ncol,chemistryIndex(l_so4_na)) + & + sum( & + gasLost(:ncol,:,COND_VAP_H2SO4) & + *fracNucl(:ncol,:,COND_VAP_H2SO4)*pdel(:ncol,:) , 2 & + )/gravit/dt + + !Take into account H2SO4 (gas) condensed in budget + coltend(:ncol,chemistryIndex(l_so4_a1)) = coltend(:ncol,chemistryIndex(l_so4_a1)) + & + sum( & + gasLost(:ncol,:,COND_VAP_H2SO4) & + *(1.0_r8 - fracNucl(:ncol,:,COND_VAP_H2SO4))*pdel(:ncol,:) , 2 & + )/gravit/dt + + !Take into account soa_lv (gas) nucleated in budget + coltend(:ncol,chemistryIndex(l_soa_na)) = coltend(:ncol,chemistryIndex(l_soa_na)) + & + sum( & + gasLost(:ncol,:,COND_VAP_ORG_LV) & + *fracNucl(:ncol,:,COND_VAP_ORG_LV)*pdel(:ncol,:) , 2 & + )/gravit/dt + + !Take into account soa gas condensed in the budget (both LV and SV) + coltend(:ncol,chemistryIndex(l_soa_a1)) = coltend(:ncol,chemistryIndex(l_soa_a1)) + & + sum( & + gasLost(:ncol,:,COND_VAP_ORG_LV) & + *(1.0_r8 - fracNucl(:ncol,:,COND_VAP_ORG_LV))*pdel(:ncol,:) , 2 & + )/gravit/dt & + + & + sum( & + gasLost(:ncol,:,COND_VAP_ORG_SV)*pdel(:ncol,:) , 2 & + )/gravit/dt + + do i=1,gas_pcnst + if(lifeCycleReceiver(i) .gt. 0 )then + long_name= trim(solsym(i))//"condTend" + call outfld(long_name, coltend(:ncol,i), pcols, lchnk) + long_name= trim(solsym(lifeCycleReceiver(i)))//"condTend" + call outfld(long_name, coltend(:ncol,lifeCycleReceiver(i)),pcols,lchnk) + end if + end do + long_name=trim(solsym(chemistryIndex(l_so4_a1)))//"condTend" + call outfld(long_name, coltend(:ncol,chemistryIndex(l_so4_a1)),pcols,lchnk) + long_name=trim(solsym(chemistryIndex(l_soa_a1)))//"condTend" + call outfld(long_name, coltend(:ncol,chemistryIndex(l_soa_a1)),pcols,lchnk) + long_name=trim(solsym(chemistryIndex(l_so4_na)))//"condTend" + call outfld(long_name, coltend(:ncol,chemistryIndex(l_so4_na)),pcols,lchnk) + long_name=trim(solsym(chemistryIndex(l_soa_na)))//"condTend" + call outfld(long_name, coltend(:ncol,chemistryIndex(l_soa_na)),pcols,lchnk) + + endif + + end subroutine condtend_sub + + subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuclso4, nuclorg, zm, pblht) + + ! Subroutine to calculate nucleation (formation) rates of new particles + ! At the moment, the final nucleation rate consists of + ! (1) Binary sulphuric acid-water nucleation in whole atmosphere (Vehkamaki et al., 2002, JGR) + ! JGR, vol 107, No D22, http://onlinelibrary.wiley.com/doi/10.1029/2002JD002184/abstract + ! (2) Boundary-layer nucleation + ! Paasonen et al (2010), ACP, vol 10, pp 11223: http://www.atmos-chem-phys.net/10/11223/2010/acp-10-11223-2010.html + ! (3) First version published ACP (Risto Makkonen) + ! ACP, vol 14, no 10, pp 5127 http://www.atmos-chem-phys.net/14/5127/2014/acp-14-5127-2014.html + ! Modified Spring 2015, cka + + use wv_saturation, only : qsat_water + use ppgrid, only : pcols, pver, pverp + use aerosoldef, only : MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na + use commondefinitions, only : originalNumberMedianRadius + use phys_control, only : phys_getopts + use m_spc_id, only : id_H2SO4, id_soa_lv + use const, only : volumeToNumber + + !-- Arguments + integer, intent(in) :: lchnk ! chunk identifier + integer, intent(in) :: ncol ! number of atmospheric column + real(r8), intent(in) :: pmid(pcols,pver) ! layer pressure (Pa) + real(r8), intent(in) :: h2ommr(pcols,pver) ! layer specific humidity + real(r8), intent(in) :: t(pcols,pver) ! Temperature (K) + real(r8), intent(in) :: h2so4pc(pcols,pver) ! Sulphuric acid concentration (kg kg-1) + real(r8), intent(in) :: oxidorg(pcols,pver) ! Organic vapour concentration (kg kg-1) + real(r8), intent(in) :: coagnuc(pcols,pver) ! Coagulation sink for nucleating particles [1/s] + real(r8), intent(out) :: nuclorg(pcols,pver) ! Nucleated mass (ORG) + real(r8), intent(out) :: nuclso4(pcols,pver) ! Nucleated mass (H2SO4) + real(r8), intent(in) :: zm(pcols,pver) ! Height at layer midpoints (m) + real(r8), intent(in) :: pblht(pcols) ! Planetary boundary layer height (m) + + !-- Local variables + + real(r8), parameter :: pi=3.141592654_r8 + !cka+ + real(r8), parameter :: gasconst_R=8.314472_r8 ! universal gas constant [J mol-1 K-1] + real(r8), parameter :: h2so4_dens=1841._r8 ! h2so4 density [kg m-3] + real(r8), parameter :: org_dens=2000._r8 ! density of organics [kg m-3], based on RM assumptions + !cka - + + integer :: i,k + real(r8) :: qs(pcols,pver) ! Saturation specific humidity + real(r8) :: relhum(pcols,pver) ! Relative humidity + real(r8) :: h2so4(pcols,pver) ! Sulphuric acid concentration [#/cm3] + real(r8) :: nuclvolume(pcols,pver) ! [m3/m3/s] Nucleated mass (SO4+ORG) + real(r8) :: rhoair(pcols,pver) ! density of air [kg/m3] !cka + real(r8) :: pblht_lim(pcols) ! Planetary boundary layer height (m) (500mzm(i,k) .AND. pbl_nucleation>0) then + + if(pbl_nucleation .EQ. 1) then + + !-- Paasonen et al. (2010), eqn 10, Table 4 + nuclrate_pbl(i,k)=(1.7E-6_r8)*h2so4(i,k) + + else if(pbl_nucleation .EQ. 2) then + + !-- Paasonen et al. (2010) + !values from Table 3 in Paasonen et al (2010), modified version of eqn 14 + nuclrate_pbl(i,k)=(6.1E-7_r8)*h2so4(i,k)+(0.39E-7_r8)*orgforgrowth(i,k) + + end if + + nuclrate_pbl(i,k)=MAX(MIN(nuclrate_pbl(i,k),1.E10_r8),0._r8) + + else !Not using PBL-nucleation + nuclrate_pbl(i,k)=0._r8 + end if + !Size [nm] of particles in PBL + nuclsize_pbl(i,k)=2._r8 + + end do !horizontal points + end do !levels + + !-- Calculate total nucleated mass + do k=1,pver + do i=1,ncol + + ! Molecular speed and growth rate: H2SO4. Eq. 21 in Kerminen and Kulmala 2002 + vmolh2so4=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_h2so4*1.E-3_r8)) + grh2so4(i,k)=(3.E-9_r8/h2so4_dens)*(vmolh2so4*molmass_h2so4*h2so4(i,k)) + grh2so4(i,k)=MAX(MIN(grh2so4(i,k),10000._r8),1.E-10_r8) + + ! Molecular speed and growth rate: ORG. Eq. 21 in Kerminen and Kulmala 2002 + vmolorg=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_soa*1.E-3_r8)) + grorg(i,k)=(3.E-9_r8/org_dens)*(vmolorg*molmass_soa*orgforgrowth(i,k)) + grorg(i,k)=MAX(MIN(grorg(i,k),10000._r8),1.E-10_r8) + + ! Combined growth rate (cka) + gr(i,k)=grh2so4(i,k)+grorg(i,k) + + !-- Lehtinen 2007 parameterization for apparent formation rate + ! diameters in nm, growth rate in nm h-1, coagulation in s-1 + + call appformrate(nuclsize_bin(i,k), d_form*1.E9_r8, nuclrate_bin(i,k), formrate_bin(i,k), coagnuc(i,k), gr(i,k)) + call appformrate(nuclsize_pbl(i,k), d_form*1.E9_r8, nuclrate_pbl(i,k), formrate_pbl(i,k), coagnuc(i,k), gr(i,k)) + + formrate_bin(i,k)=MAX(MIN(formrate_bin(i,k),1.E3_r8),0._r8) + formrate_pbl(i,k)=MAX(MIN(formrate_pbl(i,k),1.E3_r8),0._r8) + + ! Number of mol nucleated per g air per second. + nuclvolume(i,k) = (formrate_bin(i,k) + formrate_pbl(i,k)) & ![particles/cm3] + *1.0e6_r8 & !==> [particles / m3 /] + /volumeToNumber(MODE_IDX_SO4SOA_AIT) & !==> [m3_{aer} / m3_{air} / sec] + / rhoair(i,k) !==> m3_{aer} / kg_{air} /sec + + !Estimate how much is organic based on growth-rate + if(gr(i,k)>1.E-10_r8) then + frach2so4=grh2so4(i,k)/gr(i,k) + else + frach2so4=1._r8 + end if + + ! Nucleated so4 and soa mass mixing ratio per second [kg kg-1 s-1] + ! used density of particle phase, not of condensing gas + nuclso4(i,k)=rhopart(l_so4_na)*nuclvolume(i,k)*frach2so4 + nuclorg(i,k)=rhopart(l_soa_na)*nuclvolume(i,k)*(1.0_r8-frach2so4) + + end do + end do + + !-- Diagnostic output + call outfld('NUCLRATE', nuclrate_bin+nuclrate_pbl, pcols ,lchnk) + call outfld('FORMRATE', formrate_bin+formrate_pbl, pcols ,lchnk) + call outfld('COAGNUCL', coagnuc, pcols ,lchnk) + call outfld('GRH2SO4', grh2so4, pcols ,lchnk) + call outfld('GRSOA', grorg, pcols ,lchnk) + call outfld('GR', gr, pcols ,lchnk) + + return + end subroutine aeronucl + + subroutine appformrate(d1, dx, j1, jx, CoagS_dx, gr) + !-- appformrate calculates the formation rate jx of dx sized particles from the nucleation rate j1 (d1 sized particles) + !-- Formation rate is parameterized according to Lehtinen et al. (2007), JAS 38:988-994 + !-- Parameterization takes into account the loss of particles due to coagulation + !-- Growth by self-coagulation is not accounted for + !-- Typically, 1% of 1 nm nuclei make it to 12 nm + !-- Written by Risto Makkonen + ! First estimate: 99% of particles are lost during growth from 1 nm to 12 nm + + !-- Arguments + + real(r8), intent(in) :: d1 ! Size of nucleation-sized particles (nm) + real(r8), intent(in) :: dx ! Size of calculated apparent formation rate (nm) + real(r8), intent(in) :: j1 ! Nucleation rate of d1 sized particles (# cm-3 s-1) + real(r8), intent(out) :: jx ! Formation rate of dx sized particles (# cm-3 s-1) + real(r8), intent(in) :: CoagS_dx ! Coagulation term for nucleating particles (s-1) + real(r8), intent(in) :: gr ! Particle growth rate (nm h-1) + + !-- Local variables + + real(r8) :: m + real(r8) :: gamma + real(r8) :: CoagS_d1 ! Coagulation term for nucleating particles, calculated from CoagS_dx + + ! In Hyytiala, typically 80% of the nuclei are scavenged onto larger background particles while they grow from 1 to 3 nm + + !-- (Eq. 6) Exponent m, depends on background distribution + ! m=log(CoagS_dx/CoagS_d1)/log(dx/d1) + ! Or, if we dont want to calculate CoagS_d1, lets assume a typical value for m (-1.5 -- -1.9) and calculate CoagS_d1 from Eq.5 + m=-1.6_r8 + CoagS_d1=CoagS_dx*(d1/dx)**m + CoagS_d1=MAX(MIN(CoagS_d1,1.E2_r8),1.E-10_r8) + + gamma=(1._r8/(m+1._r8))*((dx/d1)**(m+1._r8)-1._r8) + gamma=MAX(MIN(gamma,1.E2_r8),1.E-10_r8) + + !gr=MAX(MIN(gr,1.E3_r8),1.E-5_r8) + + !-- (Eq. 7) CoagS_d1 is multiplied with 3600 to get units h-1 + !WRITE(*,*) 'gammaym:',gamma,exp(-gamma*d1*CoagS_d1*3600/gr) + jx=j1*exp(-gamma*d1*CoagS_d1*3600._r8/gr) + + return + + end subroutine appformrate end module condtend diff --git a/src/chemistry/oslo_aero/constants.F90 b/src/chemistry/oslo_aero/constants.F90 deleted file mode 100644 index 5e58b488d6..0000000000 --- a/src/chemistry/oslo_aero/constants.F90 +++ /dev/null @@ -1,123 +0,0 @@ - -subroutine constants -! -! A number of constants used in the emission and size-calculation in CAM-Oslo -! �S Jan 2011. -! Updated by Alf Kirkev�g May 2013. -! Updated by Alf Grini February 2014. -! - use shr_kind_mod, only: r8 => shr_kind_r8 - use physconst, only: pi - use const - use aerosoldef - use koagsub, only : initializeCoagulationReceivers, initializeCoagulationCoefficients & - , initializeCoagulationOutput - - use oslo_utils - implicit none - - - integer kcomp,i - real(r8),dimension(0:nmodes) :: rhob !density of background aerosol in mode - - real(r8) :: rhorbc !This has to do with fractal dimensions of bc, come back to this!! - real(r8) :: sumnormnk - real(r8) :: totalLogDelta - real(r8) :: logDeltaBin - real(r8) :: logNextEdge - - rhob(:)=-1.0_r8 - volumeToNumber(:)=-1.0_r8 - numberToSurface(:)=-1.0_r8 - !Prepare modal properties - do i=0, nmodes - - if(getNumberOfTracersInMode(i) .gt. 0)then - - !Approximate density of mode - rhob(i) = rhopart(getTracerIndex(i,1,.false.)) !density of mode is density of first species in mode - - !REPLACE THE EFACT-VARIABLE WITH THIS!! - volumeToNumber(i) = 1.0_r8 & - / & - ( DEXP ( 4.5_r8 * ( log(originalSigma(i)) * log(originalSigma(i)) ) ) & - *(4.0_r8/3.0_r8)*pi*(originalNumberMedianRadius(i))**3 ) - - numberToSurface(i) = 4.0_r8*pi*lifeCycleNumberMedianRadius(i)*lifeCycleNumberMedianRadius(i)& - *DEXP(log(lifeCycleSigma(i))*log(lifeCycleSigma(i))) - end if - end do - - - !Find radius in edges and midpoints of bin - rBinEdge(1) = rTabMin - totalLogDelta = log(rTabMax/rTabMin) - logDeltaBin = totalLogDelta / nBinsTab - do i=2,nBinsTab+1 - logNextEdge = log(rBinEdge(i-1)) + logDeltaBin - rBinEdge(i) = DEXP(logNextEdge) - rBinMidPoint(i-1) = sqrt(rBinEdge(i)*rBinEdge(i-1)) - end do - - !Calculate the fraction of a mode which goes to aquous chemstry - numberFractionAvailableAqChem(:)=0.0_r8 - do i=1,nbmodes - if(isTracerInMode(i,l_so4_a2))then - numberFractionAvailableAqChem(i) = 1.0_r8 - calculateLognormalCDF(rMinAquousChemistry & - , originalNumberMedianRadius(i) & - , originalSigma(i) & - ) - end if - end do - - !Set the density of the fractal mode ==> we get lesser density - !than the emitted density, so for a given mass emitted, we get - !more number-concentration!! This is a way of simulating that the - !aerosols take up more space - rhorbc = calculateEquivalentDensityOfFractalMode( & - rhopart(l_bc_n) & !emitted density - ,originalNumberMedianRadius(MODE_IDX_BC_NUC) & !emitted size - ,2.5_r8 & !fractal dim - ,originalNumberMedianRadius(MODE_IDX_BC_EXT_AC) & !diameter of mode - ,originalSigma(MODE_IDX_BC_EXT_AC)) !sigma mode - - rhopart(l_bc_ax) = rhorbc - !fxm: not the right place for this change of value, - !but anyway.. this re-calculateion of tracer density - !influences density of mode used in coagulation - rhob(MODE_IDX_BC_EXT_AC)=rhorbc - - !Size distribution of the modes! - !Unclear if this should use the radii assuming growth or not! - !Mostly used in code where it is sensible to assume some growth has - !happened, so it is used here - do kcomp = 0,nmodes - do i=1,nBinsTab - !dN/dlogR (does not sum to one over size range) - nk(kcomp,i) = calculatedNdLogR(rBinMidPoint(i), lifeCycleNumberMedianRadius(kcomp), lifeCycleSigma(kcomp)) - !dN (sums to one) over the size range - normnk(kcomp,i) =logDeltaBin*nk(kcomp,i) - enddo - enddo ! kcomp - - !++test: Normalized size distribution must sum to one (accept 2% error) - do kcomp=0,nmodes - sumNormNk = sum(normnk(kcomp,:)) - if(abs(sum(normnk(kcomp,:)) - 1.0_r8) .gt. 2.0e-2_r8)then - print*, "sum normnk", sum(normnk(kcomp,:)) - stop - endif - enddo - !--test - - !Initialize coagulation - call initializeCoagulationReceivers() - - !Calculate the coagulation coefficients Note: Inaccurate density used! - call initializeCoagulationCoefficients(rhob, lifeCycleNumberMedianRadius) - - - call initializeCoagulationOutput() - - return - end subroutine constants From 1225bbae4dfe4a227b30eeae3fdd22246f2f3c76 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 21 Aug 2023 11:05:53 +0200 Subject: [PATCH 18/71] moved ndrop and aero_model from oslo_aero to cam_oslo since they are duplicate files and refactored seasalt_model --- src/chemistry/oslo_aero/oslo_ocean_intr.F90 | 702 ++++++++---------- .../cam_oslo}/aero_model.F90 | 16 +- .../oslo_aero => physics/cam_oslo}/ndrop.F90 | 0 src/physics/cam_oslo/seasalt_model.F90 | 255 +++---- 4 files changed, 420 insertions(+), 553 deletions(-) rename src/{chemistry/oslo_aero => physics/cam_oslo}/aero_model.F90 (98%) rename src/{chemistry/oslo_aero => physics/cam_oslo}/ndrop.F90 (100%) diff --git a/src/chemistry/oslo_aero/oslo_ocean_intr.F90 b/src/chemistry/oslo_aero/oslo_ocean_intr.F90 index c934313700..af25b61881 100644 --- a/src/chemistry/oslo_aero/oslo_ocean_intr.F90 +++ b/src/chemistry/oslo_aero/oslo_ocean_intr.F90 @@ -12,216 +12,197 @@ !------------------------------------------------------------------- module oslo_ocean_intr - use shr_kind_mod, only : r8 => shr_kind_r8 - use cam_abortutils, only : endrun - use spmd_utils, only : masterproc - use tracer_data, only : trfld, trfile - use cam_logfile, only : iulog - use ppgrid, only : pcols, pver,pverp - use camsrfexch, only : cam_in_t !, cam_out_t ? - - implicit none - - - -! new type for ocean species - - type :: oceanspc -! integer :: spc_ndx ! could be added for selective reading - character(len=16) :: species(1) ! Species name -! character(len=8) :: units ! could be added for units check - type(trfld), pointer :: fields(:) ! where the data ends up fields%data - type(trfile) :: file - end type oceanspc - - -!------------------------------------------------------------------------------------- + use shr_kind_mod, only : r8 => shr_kind_r8 + use cam_abortutils, only : endrun + use spmd_utils, only : masterproc + use tracer_data, only : trfld, trfile + use cam_logfile, only : iulog + use ppgrid, only : pcols, pver,pverp + use camsrfexch, only : cam_in_t !, cam_out_t ? + + implicit none + private + + ! new type for ocean species + + type :: oceanspc + character(len=16) :: species(1) ! Species name + type(trfld), pointer :: fields(:) ! where the data ends up fields%data + type(trfile) :: file + end type oceanspc + + type(oceanspc), allocatable :: oceanspcs(:) + + ! List of subroutines that can be accesed from outside module + + public :: oslo_ocean_getnl ! should this be public. Only used locally... + public :: oslo_ocean_init ! initializing, reading file + public :: oslo_ocean_time ! time interpolation + public :: oslo_dms_emis_intr ! calculate dms surface emissions + public :: oslo_dms_inq ! logical function which tells mo_srf_emis what to do + public :: oslo_opom_emis_intr ! calculate opom surface emissions + public :: oslo_opom_inq ! logical function which tells oslo_salt what to do + + ! These variables are settable via the namelist (with longer names) + ! For reading concentration file + character(len=16) :: dmsl_fld_name = 'dms' !not set from namelist, hard coded, name of nc var + character(len=16) :: dmsk_fld_name = 'dms_Kettle' !not set from namelist, hard coded, name of nc var + character(len=16) :: opomo_fld_name = 'chlor_a' !not set from namelist, hard coded, name of nc var + character(len=16) :: opomn_fld_name = 'poc' !not set from namelist, hard coded, name of nc var + character(len=256) :: filename = '' !will be collected from NAMELIST + character(len=256) :: filelist = '' !not needed? + character(len=256) :: datapath = '' !will be collected from NAMELIST + character(len=32) :: dms_data_type = 'CYCLICAL' !will be collected from NAMELIST + character(len=32) :: opom_data_type= 'CYCLICAL' !will be collected from NAMELIST + logical :: rmv_file = .false. !delete file when finished with it + integer :: dms_cycle_yr = 0 !will be collected from NAMELIST + integer :: opom_cycle_yr = 0 !will be collected from NAMELIST + integer :: fixed_ymd = 0 !running one date only? + integer :: fixed_tod = 0 !running one time of day only? + character(len=20) :: dms_source = 'emission_file' !will be collected from NAMELIST + character(len=20) :: opom_source = 'no_file' !will be collected from NAMELIST + integer :: n_ocean_species !Number of variables read from ocean file + integer :: pndx_fdms !DMS surface flux physics index +contains + !--------------------------------------------------------------------- + !--------------------------------------------------------------------- + subroutine oslo_ocean_getnl() + ! Read namelist variables. For oslo namelist variables this is done through oslo_getopts + use oslo_control, only: oslo_getopts -! List of subroutines that can be accesed from outside module + implicit none - public :: oslo_ocean_getnl ! should this be public. Only used locally... - public :: oslo_ocean_init ! initializing, reading file - public :: oslo_ocean_time ! time interpolation - public :: oslo_dms_emis_intr ! calculate dms surface emissions - public :: oslo_dms_inq ! logical function which tells mo_srf_emis what to do - public :: oslo_opom_emis_intr ! calculate opom surface emissions - public :: oslo_opom_inq ! logical function which tells oslo_salt what to do + ! declaration of variables collected from namelist + character(len=256) :: in_filename + character(len=256) :: in_datapath + character(len=20) :: in_dms_data_source + character(len=32) :: in_dms_data_type + integer :: in_dms_cycle_yr + character(len=20) :: in_opom_data_source + character(len=32) :: in_opom_data_type + integer :: in_opom_cycle_yr + + + ! Initialize namelist variables from local module variables. + in_filename = filename + in_datapath = datapath + in_dms_data_type = dms_data_type + in_dms_cycle_yr = dms_cycle_yr + in_dms_data_source = dms_source + in_opom_data_type = opom_data_type + in_opom_cycle_yr = opom_cycle_yr + in_opom_data_source = opom_source + + ! Read namelist. + call oslo_getopts(dms_source_out = in_dms_data_source, & + dms_source_type_out = in_dms_data_type, & + dms_cycle_year_out = in_dms_cycle_yr, & + opom_source_out = in_opom_data_source, & + opom_source_type_out= in_opom_data_type, & + opom_cycle_year_out = in_opom_cycle_yr, & + ocean_filename_out = in_filename, & + ocean_filepath_out = in_datapath) + + + ! Update module variables with user settings. + filename = in_filename + datapath = in_datapath + dms_data_type = in_dms_data_type + dms_cycle_yr = in_dms_cycle_yr + dms_source = in_dms_data_source + opom_data_type= in_opom_data_type + opom_cycle_yr = in_opom_cycle_yr + opom_source = in_opom_data_source + + ! Write new value set from namelist to log + ! write(iulog,*)"test pom namelist 2: " // trim(opom_source) + + endsubroutine oslo_ocean_getnl + !--------------------------------------------------------------------- + !--------------------------------------------------------------------- + subroutine oslo_ocean_init() + ! no in parameters all information is local + + use tracer_data, only : trcdata_init + use constituents, only : cnst_get_ind + use cam_history, only : addfld, add_default, horiz_only + implicit none + integer :: astat + integer :: m + integer :: cycle_yr(2) + character(len=32) :: data_type(2) + character(len=16) :: emis_species(2) + + ! Collect and save namelist information in module + call oslo_ocean_getnl() + + !get physics index for dms surface flux. Index for cflx + call cnst_get_ind('DMS', pndx_fdms, abort=.true.) + + ! write(iulog,*)"test dms p index: " ,pndx_fdms + + if (dms_source=='lana')then + emis_species(1) = dmsl_fld_name + else + emis_species(1) = dmsk_fld_name + endif + if (opom_source=='odowd')then + emis_species(2) = opomo_fld_name + else + emis_species(2) = opomn_fld_name + endif + cycle_yr(1)= dms_cycle_yr + cycle_yr(2)= opom_cycle_yr + data_type(1) = dms_data_type + data_type(2) = opom_data_type + n_ocean_species = 2 + + if (masterproc) write(iulog,*) 'oslo_dms_inti: n_ocean_species = ',n_ocean_species + + allocate( oceanspcs(n_ocean_species), stat=astat ) + if( astat/= 0 ) then + write(iulog,*) 'oslo_dms_inti: failed to allocate oceanspcs array; error = ',astat + call endrun + end if - private - save + !----------------------------------------------------------------------- + ! ... setup the oceanspcs type array + !----------------------------------------------------------------------- + ! Add support for selective reading with saved units etc.? + do m=1,n_ocean_species ! one for now... start with dms + ! oceanspcs(m)%spc_ndx = emis_indexes(m) ! physics index + ! oceanspcs(m)%units = 'nmol/L' + oceanspcs(m)%species = emis_species(m) ! nc var name - type(oceanspc), allocatable :: oceanspcs(:) + enddo + do m=1,n_ocean_species + ! Ocean concentrations are not stored in pbuf + allocate(oceanspcs(m)%file%in_pbuf(1)) + oceanspcs(m)%file%in_pbuf(:) = .false. + call trcdata_init( oceanspcs(m)%species, & + filename, filelist, datapath, & + oceanspcs(m)%fields, & + oceanspcs(m)%file, & + rmv_file, cycle_yr(m), fixed_ymd, fixed_tod, data_type(m) ) + enddo + ! write(iulog,*) 'oslo_ocean_init: read file ' -! These variables are settable via the namelist (with longer names) -! For reading concentration file - character(len=16) :: dmsl_fld_name = 'dms' !not set from namelist, hard coded, name of nc var - character(len=16) :: dmsk_fld_name = 'dms_Kettle' !not set from namelist, hard coded, name of nc var - character(len=16) :: opomo_fld_name = 'chlor_a' !not set from namelist, hard coded, name of nc var - character(len=16) :: opomn_fld_name = 'poc' !not set from namelist, hard coded, name of nc var - character(len=256) :: filename = '' !will be collected from NAMELIST - character(len=256) :: filelist = '' !not needed? - character(len=256) :: datapath = '' !will be collected from NAMELIST - character(len=32) :: dms_data_type = 'CYCLICAL' !will be collected from NAMELIST - character(len=32) :: opom_data_type= 'CYCLICAL' !will be collected from NAMELIST - logical :: rmv_file = .false. !delete file when finished with it - integer :: dms_cycle_yr = 0 !will be collected from NAMELIST - integer :: opom_cycle_yr = 0 !will be collected from NAMELIST - integer :: fixed_ymd = 0 !running one date only? - integer :: fixed_tod = 0 !running one time of day only? + call addfld( 'odms', horiz_only, 'A', 'nmol/L', 'DMS upper ocean concentration' ) - character(len=20) :: dms_source = 'emission_file' !will be collected from NAMELIST - character(len=20) :: opom_source = 'no_file' !will be collected from NAMELIST - integer :: n_ocean_species !Number of variables read from ocean file - integer :: pndx_fdms !DMS surface flux physics index + call add_default('odms', 1, ' ') -contains -!--------------------------------------------------------------------- -!--------------------------------------------------------------------- -subroutine oslo_ocean_getnl() -! Read namelist variables. For oslo namelist variables this is done through oslo_getopts - - use oslo_control, only: oslo_getopts - - implicit none - - ! declaration of variables collected from namelist - character(len=256) :: in_filename - character(len=256) :: in_datapath - character(len=20) :: in_dms_data_source - character(len=32) :: in_dms_data_type - integer :: in_dms_cycle_yr - character(len=20) :: in_opom_data_source - character(len=32) :: in_opom_data_type - integer :: in_opom_cycle_yr - - - ! Initialize namelist variables from local module variables. - in_filename = filename - in_datapath = datapath - in_dms_data_type = dms_data_type - in_dms_cycle_yr = dms_cycle_yr - in_dms_data_source = dms_source - in_opom_data_type = opom_data_type - in_opom_cycle_yr = opom_cycle_yr - in_opom_data_source = opom_source - - ! Read namelist. - call oslo_getopts(dms_source_out = in_dms_data_source, & - dms_source_type_out = in_dms_data_type, & - dms_cycle_year_out = in_dms_cycle_yr, & - opom_source_out = in_opom_data_source, & - opom_source_type_out= in_opom_data_type, & - opom_cycle_year_out = in_opom_cycle_yr, & - ocean_filename_out = in_filename, & - ocean_filepath_out = in_datapath) - - - ! Update module variables with user settings. - filename = in_filename - datapath = in_datapath - dms_data_type = in_dms_data_type - dms_cycle_yr = in_dms_cycle_yr - dms_source = in_dms_data_source - opom_data_type= in_opom_data_type - opom_cycle_yr = in_opom_cycle_yr - opom_source = in_opom_data_source - - ! Write new value set from namelist to log -! write(iulog,*)"test pom namelist 2: " // trim(opom_source) - -endsubroutine oslo_ocean_getnl -!--------------------------------------------------------------------- -!--------------------------------------------------------------------- -subroutine oslo_ocean_init() -! no in parameters all information is local - - use tracer_data, only : trcdata_init - use constituents, only : cnst_get_ind - use cam_history, only : addfld, add_default, horiz_only - - implicit none - - integer :: astat - integer :: m - integer :: cycle_yr(2) - character(len=32) :: data_type(2) - character(len=16) :: emis_species(2) - - ! Collect and save namelist information in module - call oslo_ocean_getnl() - - !get physics index for dms surface flux. Index for cflx - call cnst_get_ind('DMS', pndx_fdms, abort=.true.) - -! write(iulog,*)"test dms p index: " ,pndx_fdms - - if (dms_source=='lana')then - emis_species(1) = dmsl_fld_name - else - emis_species(1) = dmsk_fld_name - endif - if (opom_source=='odowd')then - emis_species(2) = opomo_fld_name - else - emis_species(2) = opomn_fld_name - endif - cycle_yr(1)= dms_cycle_yr - cycle_yr(2)= opom_cycle_yr - data_type(1) = dms_data_type - data_type(2) = opom_data_type - n_ocean_species = 2 - - if (masterproc) write(iulog,*) 'oslo_dms_inti: n_ocean_species = ',n_ocean_species - - allocate( oceanspcs(n_ocean_species), stat=astat ) - if( astat/= 0 ) then - write(iulog,*) 'oslo_dms_inti: failed to allocate oceanspcs array; error = ',astat - call endrun - end if - - - !----------------------------------------------------------------------- - ! ... setup the oceanspcs type array - !----------------------------------------------------------------------- -! Add support for selective reading with saved units etc.? - do m=1,n_ocean_species ! one for now... start with dms -! oceanspcs(m)%spc_ndx = emis_indexes(m) ! physics index -! oceanspcs(m)%units = 'nmol/L' - oceanspcs(m)%species = emis_species(m) ! nc var name - - enddo - - do m=1,n_ocean_species - - ! Ocean concentrations are not stored in pbuf - allocate(oceanspcs(m)%file%in_pbuf(1)) - oceanspcs(m)%file%in_pbuf(:) = .false. - - call trcdata_init( oceanspcs(m)%species, & - filename, filelist, datapath, & - oceanspcs(m)%fields, & - oceanspcs(m)%file, & - rmv_file, cycle_yr(m), fixed_ymd, fixed_tod, data_type(m) ) - - enddo -! write(iulog,*) 'oslo_ocean_init: read file ' - - call addfld( 'odms', horiz_only, 'A', 'nmol/L', 'DMS upper ocean concentration' ) - - call add_default('odms', 1, ' ') - -endsubroutine oslo_ocean_init -!------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------ -subroutine oslo_ocean_time(state, pbuf2d) + endsubroutine oslo_ocean_init + !------------------------------------------------------------------------------------------ + !------------------------------------------------------------------------------------------ + subroutine oslo_ocean_time(state, pbuf2d) use physics_types, only : physics_state use ppgrid, only : begchunk, endchunk @@ -239,191 +220,156 @@ subroutine oslo_ocean_time(state, pbuf2d) integer :: m do m = 1,n_ocean_species - call advance_trcdata( oceanspcs(m)%fields, oceanspcs(m)%file, state, pbuf2d ) end do - -endsubroutine oslo_ocean_time - -!------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------ - -subroutine oslo_dms_emis_intr(state, cam_in) - - use physics_types, only: physics_state - use constituents, only: cnst_mw !molecular weight for physics constituents - use cam_history, only: outfld - - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), target, intent(inout) :: cam_in ! import state - - - real(r8), dimension(pcols) :: u10m ![m/s] - real(r8), pointer :: ocnfrc(:) ![frc] ocean fraction - real(r8), pointer :: icefrc(:) ![frc] ice fraction - integer :: ncol ![nbr] number of columns in use - integer :: lchnk ! chunk index - - real(r8) :: rk600(pcols) ! ocean/atmos. DMS exchange factor [cm/hr] - real(r8) :: flux(pcols) ! Local flux array: DMS emission rate [kg m-2 s-1] - real(r8) :: odms(pcols) ! Ocean dms concentration [nmol/L] from file - real(r8) :: open_ocn(pcols) ! Open Ocean - - real(r8), dimension(pcols):: t,scdms,kwdms - - real(r8), parameter :: z0= 0.0001_r8 ![m] roughness length over ocean - real(r8), parameter :: Xconvxa= 6.97e-07 ! Wanninkhof's a=0.251 converted to ms-1/(ms-1)^2 - - logical, parameter :: method_oslo =.false. - logical, parameter :: method_hamocc=.true. - - !pointers to land model variables - ocnfrc => cam_in%ocnfrac - icefrc => cam_in%icefrac - ncol = state%ncol - lchnk = state%lchnk - - ! IF CONCENTRATION FILE - if (dms_source=='lana' .or. dms_source=='kettle') then - - ! collect dms data from file - flux(:) = 0._r8 - odms(:) = 0._r8 - odms(:ncol) = oceanspcs(1)%fields(1)%data(:ncol,1,lchnk) - - ! open ocean - open_ocn(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) - !start with midpoint wind speed - u10m(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) - - if (method_oslo) then - ! move the winds to 10m high from the midpoint of the gridbox: - u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) - rk600(:ncol) = (0.222_r8*(u10m(:ncol)*u10m(:ncol))) + (0.333_r8*u10m(:ncol)) ! [cm/hr] - flux (:ncol) = 2.778e-15*cnst_mw(pndx_fdms)*rk600(:ncol)*open_ocn(:ncol)*odms(:ncol) ! [kg m-2 s-1] - else if (method_hamocc) then - t(:ncol)=cam_in%sst(:ncol)-273.15_r8 - u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) - scdms(:ncol) = 2855.7+ (-177.63 + (6.0438 + (-0.11645 + 0.00094743*t(:ncol))*t(:ncol))*t(:ncol))*t(:ncol) - kwdms(:ncol) = open_ocn(:ncol) * Xconvxa *u10m(:ncol)**2*(660./scdms(:ncol))**0.5 - flux (:ncol) = 62.13*kwdms(:ncol)*1e-9*odms(:ncol) - endif - cam_in%cflx(:ncol, pndx_fdms ) = flux(:ncol) - - call outfld('odms', odms(:ncol), ncol, lchnk) - - ! IF OCEAN FLUX - elseif(dms_source=='ocean_flux') then - cam_in%cflx(:ncol, pndx_fdms) = cam_in%fdms(:ncol) - endif - - ! IF EMISSION FILE - ! return without changing cflx - ! return? - -endsubroutine oslo_dms_emis_intr -!------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------ - -subroutine oslo_opom_emis_intr(em_ss1,em_ss2,em_ss3,open_ocn,ncol,lchnk, opomem_out) - - - - integer , intent(in) :: ncol ![nbr] number of columns in use - integer , intent(in) :: lchnk !current chunk - real(r8), intent(in) :: em_ss1(pcols) !sea salt emission mode a1 - real(r8), intent(in) :: em_ss2(pcols) !sea salt emission mode a2 - real(r8), intent(in) :: em_ss3(pcols) !sea salt emission mode a3 - real(r8), intent(in) :: open_ocn(pcols) !open ocean - real(r8), intent(out) :: opomem_out(pcols) !ocean POM emission rate [kg m-2 s-1] -! integer :: lchnk ! chunk index - - real(r8) :: flux(ncol) ! Local flux array: ocean POM emission rate [kg m-2 s-1] - - ! Variables for Nilsson parameterisation - real(r8) :: opoc(ncol) ! Ocean POC concentration [mg m-3] -! real(r8), parameter :: c_n = 0.000288657_r8 ! OM tuning constant (NorESM1 value) - real(r8), parameter :: c_n = 0.000507456_r8 ! OM tuning constant (Tuned for NorESM2) - real(r8), parameter :: c_a1 = 2.06_r8 ! OM fraction in a1 mode - real(r8), parameter :: c_a2 = 0.355_r8 ! OM fraction in a2 mode - real(r8), parameter :: c_a3 = 0.0623_r8 ! OM fraction in a3 mode - - ! Variables for O'Dowd parameterisation - real(r8) :: omFrac(ncol) ! OM fraction of total seaspray mass - real(r8) :: ochlor(ncol) ! Ocean chlorophyll concentration [nmol/L] - real(r8),parameter :: c_o = 0.5238_r8 ! Arbritraty scaling factor to make the emissions match Spracklen. - ! Not consistent with the parameterisation of O'Dowd. Set to 1 - ! for original parameterisation. - - - - - ! Nilsson parameterisation - if (opom_source=='nilsson') then - - ! collect POC data from file - flux(:) = 0._r8 - opoc(:) = 0._r8 - - opoc(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) - - flux(:ncol) = c_n*open_ocn(:ncol)*opoc(:ncol)* & - (c_a1*em_ss1(:ncol)+c_a2*em_ss2(:ncol)+c_a3*em_ss3(:ncol)) - - opomem_out(:ncol) = flux(:ncol) - - - ! O'Dowd parameterisation - elseif (opom_source=='odowd') then - - ! collect dms data from file - flux(:) = 0._r8 - ochlor(:) = 0._r8 - - ochlor(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) - ! OM fraction saturates at 90% according to O'Dowd 2008 - omFrac(:ncol) = min(0.01_r8*(43.5_r8 * ochlor(:ncol) + 13.805_r8),0.76_r8) - omFrac(:ncol) = omFrac(:ncol) / (1._r8 - omFrac(:ncol)) - flux(:ncol) = c_o*omFrac(:ncol) * em_ss1(:ncol) - opomem_out(:ncol) = flux(:ncol) - endif - - ! return? - -endsubroutine oslo_opom_emis_intr -!------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------ - -logical function oslo_dms_inq() - implicit none - - if (dms_source=='emission_file') then - oslo_dms_inq = .true. - else - oslo_dms_inq = .false. - endif - return - -end function oslo_dms_inq - - -!------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------ - -logical function oslo_opom_inq() - implicit none - - if (opom_source=='nilsson' .or. opom_source=='odowd') then - oslo_opom_inq = .true. - else - oslo_opom_inq = .false. - endif - return - -end function oslo_opom_inq - -!------------------------------------------------------------------------------------------ -!------------------------------------------------------------------------------------------ + endsubroutine oslo_ocean_time + + !------------------------------------------------------------------------------------------ + !------------------------------------------------------------------------------------------ + subroutine oslo_dms_emis_intr(state, cam_in) + + use physics_types, only: physics_state + use constituents, only: cnst_mw !molecular weight for physics constituents + use cam_history, only: outfld + + ! Arguments + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), target, intent(inout) :: cam_in ! import state + + ! Local variables + real(r8) :: u10m(pcols) ![m/s] + real(r8), pointer :: ocnfrc(:) ! [frc] ocean fraction + real(r8), pointer :: icefrc(:) ! [frc] ice fraction + integer :: ncol ! [nbr] number of columns in use + integer :: lchnk ! chunk index + real(r8) :: rk600(pcols) ! ocean/atmos. DMS exchange factor [cm/hr] + real(r8) :: flux(pcols) ! Local flux array: DMS emission rate [kg m-2 s-1] + real(r8) :: odms(pcols) ! Ocean dms concentration [nmol/L] from file + real(r8) :: open_ocn(pcols) ! Open Ocean + real(r8) :: t(pcols) + real(r8) :: scdms(pcols) + real(r8) :: kwdms(pcols) + real(r8), parameter :: z0= 0.0001_r8 ! [m] roughness length over ocean + real(r8), parameter :: Xconvxa= 6.97e-07 ! Wanninkhof's a=0.251 converted to ms-1/(ms-1)^2 + logical , parameter :: method_oslo =.false. + logical , parameter :: method_hamocc=.true. + + !pointers to land model variables + ocnfrc => cam_in%ocnfrac + icefrc => cam_in%icefrac + ncol = state%ncol + lchnk = state%lchnk + + ! IF CONCENTRATION FILE + if (dms_source=='lana' .or. dms_source=='kettle') then + + ! collect dms data from file + flux(:) = 0._r8 + odms(:) = 0._r8 + odms(:ncol) = oceanspcs(1)%fields(1)%data(:ncol,1,lchnk) + + ! open ocean + open_ocn(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) + !start with midpoint wind speed + u10m(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) + + if (method_oslo) then + ! move the winds to 10m high from the midpoint of the gridbox: + u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) + rk600(:ncol) = (0.222_r8*(u10m(:ncol)*u10m(:ncol))) + (0.333_r8*u10m(:ncol)) ! [cm/hr] + flux (:ncol) = 2.778e-15*cnst_mw(pndx_fdms)*rk600(:ncol)*open_ocn(:ncol)*odms(:ncol) ! [kg m-2 s-1] + else if (method_hamocc) then + t(:ncol)=cam_in%sst(:ncol)-273.15_r8 + u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) + scdms(:ncol) = 2855.7+ (-177.63 + (6.0438 + (-0.11645 + 0.00094743*t(:ncol))*t(:ncol))*t(:ncol))*t(:ncol) + kwdms(:ncol) = open_ocn(:ncol) * Xconvxa *u10m(:ncol)**2*(660./scdms(:ncol))**0.5 + flux (:ncol) = 62.13*kwdms(:ncol)*1e-9*odms(:ncol) + endif + cam_in%cflx(:ncol, pndx_fdms ) = flux(:ncol) + + call outfld('odms', odms(:ncol), ncol, lchnk) + + ! IF OCEAN FLUX + elseif(dms_source=='ocean_flux') then + cam_in%cflx(:ncol, pndx_fdms) = cam_in%fdms(:ncol) + endif + + ! IF EMISSION FILE + ! return without changing cflx + + endsubroutine oslo_dms_emis_intr + + !------------------------------------------------------------------------------------------ + !------------------------------------------------------------------------------------------ + subroutine oslo_opom_emis_intr(em_ss1,em_ss2,em_ss3,open_ocn,ncol,lchnk, opomem_out) + + + integer , intent(in) :: ncol ![nbr] number of columns in use + integer , intent(in) :: lchnk !current chunk + real(r8), intent(in) :: em_ss1(pcols) !sea salt emission mode a1 + real(r8), intent(in) :: em_ss2(pcols) !sea salt emission mode a2 + real(r8), intent(in) :: em_ss3(pcols) !sea salt emission mode a3 + real(r8), intent(in) :: open_ocn(pcols) !open ocean + real(r8), intent(out) :: opomem_out(pcols) !ocean POM emission rate [kg m-2 s-1] + + real(r8) :: flux(ncol) ! Local flux array: ocean POM emission rate [kg m-2 s-1] + + ! Variables for Nilsson parameterisation + real(r8) :: opoc(ncol) ! Ocean POC concentration [mg m-3] + real(r8), parameter :: c_n = 0.000507456_r8 ! OM tuning constant (Tuned for NorESM2) + real(r8), parameter :: c_a1 = 2.06_r8 ! OM fraction in a1 mode + real(r8), parameter :: c_a2 = 0.355_r8 ! OM fraction in a2 mode + real(r8), parameter :: c_a3 = 0.0623_r8 ! OM fraction in a3 mode + real(r8) :: omFrac(ncol) ! OM fraction of total seaspray mass + real(r8) :: ochlor(ncol) ! Ocean chlorophyll concentration [nmol/L] + real(r8),parameter :: c_o = 0.5238_r8 ! Arbritraty scaling factor to make the emissions match Spracklen. + + if (opom_source=='nilsson') then + ! Nilsson parameterisation - collect POC data from file + flux(:) = 0._r8 + opoc(:) = 0._r8 + opoc(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) + flux(:ncol) = c_n*open_ocn(:ncol)*opoc(:ncol)* (c_a1*em_ss1(:ncol)+c_a2*em_ss2(:ncol)+c_a3*em_ss3(:ncol)) + opomem_out(:ncol) = flux(:ncol) + + elseif (opom_source=='odowd') then + ! O'Dowd parameterisation - collect dms data from file + flux(:) = 0._r8 + ochlor(:) = 0._r8 + ochlor(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) + + ! OM fraction saturates at 90% according to O'Dowd 2008 + omFrac(:ncol) = min(0.01_r8*(43.5_r8 * ochlor(:ncol) + 13.805_r8),0.76_r8) + omFrac(:ncol) = omFrac(:ncol) / (1._r8 - omFrac(:ncol)) + flux(:ncol) = c_o*omFrac(:ncol) * em_ss1(:ncol) + opomem_out(:ncol) = flux(:ncol) + endif + + endsubroutine oslo_opom_emis_intr + + !------------------------------------------------------------------------------------------ + !------------------------------------------------------------------------------------------ + logical function oslo_dms_inq() + + if (dms_source=='emission_file') then + oslo_dms_inq = .true. + else + oslo_dms_inq = .false. + endif + + end function oslo_dms_inq + + !------------------------------------------------------------------------------------------ + !------------------------------------------------------------------------------------------ + logical function oslo_opom_inq() + + if (opom_source=='nilsson' .or. opom_source=='odowd') then + oslo_opom_inq = .true. + else + oslo_opom_inq = .false. + endif + + end function oslo_opom_inq end module oslo_ocean_intr diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/physics/cam_oslo/aero_model.F90 similarity index 98% rename from src/chemistry/oslo_aero/aero_model.F90 rename to src/physics/cam_oslo/aero_model.F90 index d1ef32f6fd..386311cdbb 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/physics/cam_oslo/aero_model.F90 @@ -671,18 +671,14 @@ end subroutine aero_model_gasaerexch !============================================================================= subroutine aero_model_emissions( state, cam_in ) - use seasalt_model , only: oslo_salt_emis_intr, seasalt_active, OMOceanSource + use seasalt_model , only: seasalt_emis, seasalt_active use dust_model , only: oslo_dust_emis_intr, dust_active use oslo_ocean_intr , only: oslo_dms_emis_intr - use aerosoldef , only: l_om_ni use physics_types , only: physics_state ! Arguments: - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), intent(inout) :: cam_in ! import state - - ! local vars - integer :: ncol + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), intent(inout) :: cam_in ! import state if (dust_active) then call oslo_dust_emis_intr( state, cam_in) @@ -690,13 +686,9 @@ subroutine aero_model_emissions( state, cam_in ) endif if (seasalt_active) then - call oslo_salt_emis_intr(state, cam_in) + call seasalt_emis(state, cam_in) endif - !Add whatever OM ocean source was calculated in the seasalt module - ncol = state%ncol - cam_in%cflx(:ncol,l_om_ni) = cam_in%cflx(:ncol,l_om_ni) + OMOceanSource(:ncol) - !Pick up correct DMS emissions (replace values from file if requested) call oslo_dms_emis_intr(state, cam_in) diff --git a/src/chemistry/oslo_aero/ndrop.F90 b/src/physics/cam_oslo/ndrop.F90 similarity index 100% rename from src/chemistry/oslo_aero/ndrop.F90 rename to src/physics/cam_oslo/ndrop.F90 diff --git a/src/physics/cam_oslo/seasalt_model.F90 b/src/physics/cam_oslo/seasalt_model.F90 index 0bb52f3ec8..238ed9431d 100644 --- a/src/physics/cam_oslo/seasalt_model.F90 +++ b/src/physics/cam_oslo/seasalt_model.F90 @@ -1,139 +1,97 @@ module seasalt_model -use constituents, only: cnst_name -use aerosoldef, only: l_ss_a1, l_ss_a2, l_ss_a3,l_om_ni & - , MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 & - , rhopart -use const, only: volumeToNumber -use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl -use spmd_utils, only: masterproc -use camsrfexch, only: cam_in_t, cam_out_t -use ppgrid, only: pcols, pver,pverp -use constituents, only: pcnst, cnst_add, cnst_name, cnst_get_ind -use aerodep_flx, only: aerodep_flx_prescribed -use cam_abortutils, only: endrun -use cam_logfile, only: iulog -use oslo_ocean_intr, only: oslo_opom_emis_intr, oslo_opom_inq - -implicit none -private -save - - !Add Spracklen OC source related to sea salt, Spracklen says about 5.5 sub-micron Tg(C) per year (page 3) - !Total sea salt emissions are about 8000 Tg/year, take into account OM/OC-factor of about 1.4 - !==> scale factor of approx 7.7/8000 - !Note: The emissions are not REALLY related to sea salt, - !but this is as close as we get with the current version - !GRL Volume 35, Issue 12, 28 June 2008, http://onlinelibrary.wiley.com/doi/10.1029/2008GL033359/abstract - real(r8), parameter :: seasaltToSpracklenOM = 7.7_r8/8000_r8 - - !After discussions with Alf K, it is better to scale with only smallest SS-mode since POM is small - !and assume same production mechanism. Nudged 1 degree simulations give 2.52 Tg/yr of SS_A1, so - !to obtain 7.7, we need to scale them by 7.7 / 2.52 ==> 3.03 -!cak real(r8), parameter :: seasaltToSpracklenOM2 = 3.03_r8 - !updated value for Salter et al. sea-salt treatment, which gives global annual SS_A1 emissions of - !2.663 instead of 0.153 ng m-2 s-1 (i.e. ca 17 times more than the old sea-salt treatment): - real(r8), parameter :: seasaltToSpracklenOM2 = 3.03_r8*0.153_r8/2.663_r8 -!cak - - integer, parameter :: numberOfSaltModes = 3 - character(len=6), public, dimension(10) :: seasalt_names - integer, parameter, public :: seasalt_nbin = numberOfSaltModes !just because this is needed by mo_photo.F90 - - !Numbers in table below are from KirkevÃ¥g et al (2013) http://www.geosci-model-dev.net/6/207/2013/gmd-6-207-2013.html - !Based on Struthers et al 2011 (http://www.atmos-chem-phys.net/11/3459/2011/acp-11-3459-2011.html) - !which are again modified from Maartensson , JGR, vol 108. no D9, 4297, 2003 - ! - !Note that using the numbers from the Kirkevag paper will give 20% too small mass emissions of sea salt globally!! - !The number of significant digits there should have been larger! We are here using the numbers as received from the swedes. - ! - !THESE ARE THE NUMBERS RECEIVED FROM THE SWEDES, THEY ARE UN-DOCUMENTED (SEE EMISSIONS.F90 of NORESM1) - !*************************************************************************************************** -! real(r8), dimension(numberOfSaltModes), parameter :: coeffA = (/0.0_r8 , 0.0_r8 , 3.0608e3_r8 /) -! real(r8), dimension(numberOfSaltModes), parameter :: coeffB = (/-3.3551e6_r8, 1.1768e5_r8 , -1.6675e6_r8 /) -! real(r8), dimension(numberOfSaltModes), parameter :: coeffC = (/1.0554e9_r8 , -1.1369e7_r8, 2.2879e8_r8 /) - - !FOR INFO: THESE ARE THE NUMBERS FROM THE PAPER WHICH GIVE TOO LOW EMISSIONS!! - !******************************************************************************************************* - !real(r8), dimension(numberOfSaltModes), parameter :: coeffA = (/0.0_r8, 0.0_r8, 3.06e3_r8 /) - !real(r8), dimension(numberOfSaltModes), parameter :: coeffB = (/-3.36e6_r8, 1.18e5_r8, -1.67e6_r8 /) - !real(r8), dimension(numberOfSaltModes), parameter :: coeffC = (/1.05e9_r8, -1.14e7_r8, 2.29e8_r8 /) - - !New numbers are based on Salter et al. (2105): www.atmos-chem-phys-discuss.net/15/13783/2015/doi:10.5194/acpd-15-13783-2015 - !Values from Table 1 in Salter et al. (2015): - !******************************************************************************************************* - real(r8), dimension(numberOfSaltModes), parameter :: coeffA = (/-5.2168e5_r8, 0.0_r8, 0.0_r8 /) - real(r8), dimension(numberOfSaltModes), parameter :: coeffB = (/ 3.31725e7_r8, 7.374e5_r8, 1.4210e4_r8 /) - real(r8), dimension(numberOfSaltModes), parameter :: coeffC = (/-6.95275e8_r8,-2.4803e7_r8, 1.4662e7_r8 /) - real(r8), dimension(numberOfSaltModes), parameter :: coeffD = (/ 1.0684e10_r8, 7.7373e8_r8, 1.7075e8_r8 /) - - real(r8), parameter :: z0= 0.0001_r8 ![m] roughness length over ocean - - - integer, dimension(numberOfSaltModes) :: modeMap ! [idx] which modes are we modifying - integer, dimension(numberOfSaltModes) :: tracerMap ! [idx] which tracers are we modifying - - real(r8), dimension(pcols), save, public :: OMOceanSource ![kg/m2/s] new OM ocean source - real(r8), dimension(pcols), save, public :: spracklenOMOceanSource ![kg/m2/s] spracklen ocean source - !real(r8), dimension(pcols), save, public :: spracklenOMOceanSource2 ![kg/m2/s] spracklen ocean source - real(r8), dimension(pcols) :: onOMOceanSource ![kg/m2/s] OM source from Nilsson/O'Dowd - logical, parameter, public :: seasalt_active = .TRUE. - -public oslo_salt_emis_intr -public seasalt_init + use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl + use ppgrid, only: pcols, pver + + implicit none + private + + integer , parameter :: numberOfSaltModes = 3 + + character(len=6) , public :: seasalt_names(10) + integer, parameter, public :: seasalt_nbin = numberOfSaltModes ! needed by mo_photo.F90 + logical, parameter, public :: seasalt_active = .true. + + integer :: modeMap(numberOfSaltModes) ! [idx] which modes are we modifying + integer :: tracerMap(numberOfSaltModes) ! [idx] which tracers are we modifying + + public :: seasalt_init + public :: seasalt_emis !=============================================================================== contains !=============================================================================== - subroutine seasalt_init() + subroutine seasalt_init() - implicit none + use constituents, only: cnst_name + use aerosoldef, only: l_ss_a1, l_ss_a2, l_ss_a3 + use aerosoldef, only: MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3, rhopart - integer :: i + integer :: i - modeMap(1) = MODE_IDX_SS_A1 - modeMap(2) = MODE_IDX_SS_A2 - modeMap(3) = MODE_IDX_SS_A3 + modeMap(1) = MODE_IDX_SS_A1 + modeMap(2) = MODE_IDX_SS_A2 + modeMap(3) = MODE_IDX_SS_A3 - tracerMap(1) = l_ss_a1 - tracerMap(2) = l_ss_a2 - tracerMap(3) = l_ss_a3 + tracerMap(1) = l_ss_a1 + tracerMap(2) = l_ss_a2 + tracerMap(3) = l_ss_a3 - seasalt_names(:)=" " - do i=1,numberOfSaltModes - seasalt_names(i) = cnst_name(tracerMap(i)) - end do + seasalt_names(:) = " " + do i = 1,numberOfSaltModes + seasalt_names(i) = cnst_name(tracerMap(i)) + end do - spracklenOMOceanSource(:) = 0.0_r8 - end subroutine seasalt_init + end subroutine seasalt_init -subroutine oslo_salt_emis_intr(state, cam_in) + !=============================================================================== + subroutine seasalt_emis(state, cam_in) - !----------------------------------------------------------------------- - ! Purpose: - ! Interface to emission of sea salt !----------------------------------------------------------------------- - use cam_history, only: outfld - use physics_types, only: physics_state + ! Purpose: Interface to emission of sea salt + !----------------------------------------------------------------------- - ! Arguments: + use camsrfexch, only: cam_in_t + use physics_types, only: physics_state + use const, only: volumeToNumber + use aerosoldef, only: rhopart, l_om_ni + use oslo_ocean_intr, only: oslo_opom_inq, oslo_opom_emis_intr + ! Arguments: type(physics_state), intent(in) :: state ! Physics state variables type(cam_in_t), target, intent(inout) :: cam_in ! import state - real(r8), dimension(pcols) :: whiteCapAreaFraction ![fraction] - real(r8), dimension(pcols) :: open_ocean ![fraction] - real(r8), dimension(pcols,numberOfSaltModes) :: numberFlux ![#/m2/sec] - real(r8), dimension(pcols) :: u10m ![m/s] - real(r8), dimension(pcols) :: totalSaltEmis ![kg/m2/s] - real(r8), pointer :: sst(:) ![frc] sea surface temperature - real(r8), pointer :: ocnfrc(:) ![frc] ocean fraction - real(r8), pointer :: icefrc(:) ![frc] ice fraction - integer :: n ![] counter for modes - integer :: ncol ![nbr] number of columns in use - integer :: lchnk ! chunk index - + ! Local variables + integer :: n ![] counter for modes + integer :: ncol ![nbr] number of columns in use + integer :: lchnk !chunk index + real(r8) :: whiteCapAreaFraction(pcols) ![fraction] + real(r8) :: open_ocean(pcols) ![fraction] + real(r8) :: numberFlux(pcols,numberofSaltModes) ![#/m2/sec] + real(r8) :: u10m(pcols) ![m/s] + real(r8), pointer :: sst(:) ![frc] sea surface temperature + real(r8), pointer :: ocnfrc(:) ![frc] ocean fraction + real(r8), pointer :: icefrc(:) ![frc] ice fraction + real(r8) :: spracklenOMOceanSource(pcols) ![kg/m2/s] spracklen ocean source + real(r8) :: onOMOceanSource(pcols) ![kg/m2/s] OM source from Nilsson/O'Dowd + real(r8) :: OMOceanSource(pcols) ![kg/m2/s] new OM ocean source + real(r8), parameter :: z0= 0.0001_r8 ![m] roughness length over ocean + + !New numbers are based on Salter et al. (2105): + !www.atmos-chem-phys-discuss.net/15/13783/2015/doi:10.5194/acpd-15-13783-2015 + !Values from Table 1 in Salter et al. (2015): + real(r8), parameter :: coeffA(numberOfSaltModes) = (/-5.2168e5_r8, 0.0_r8, 0.0_r8 /) + real(r8), parameter :: coeffB(numberOfSaltModes) = (/ 3.31725e7_r8, 7.374e5_r8, 1.4210e4_r8 /) + real(r8), parameter :: coeffC(numberOfSaltModes) = (/-6.95275e8_r8,-2.4803e7_r8, 1.4662e7_r8 /) + real(r8), parameter :: coeffD(numberOfSaltModes) = (/ 1.0684e10_r8, 7.7373e8_r8, 1.7075e8_r8 /) + + !After discussions with Alf K, it is better to scale with only smallest SS-mode since POM is small + !and assume same production mechanism. Nudged 1 degree simulations give 2.52 Tg/yr of SS_A1, so + !to obtain 7.7, we need to scale them by 7.7 / 2.52 ==> 3.03 + !updated value for Salter et al. sea-salt treatment, which gives global annual SS_A1 emissions of + !2.663 instead of 0.153 ng m-2 s-1 (i.e. ca 17 times more than the old sea-salt treatment): + real(r8), parameter :: seasaltToSpracklenOM2 = 3.03_r8*0.153_r8/2.663_r8 !number of columns in use ncol = state%ncol @@ -146,74 +104,45 @@ subroutine oslo_salt_emis_intr(state, cam_in) !start with midpoint wind speed u10m(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) - - ! move the winds to 10m high from the midpoint of the gridbox: - u10m(:ncol)=u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) -! !whitecap area (eqn 1 in Struthers et al., 2011) -! whitecapAreaFraction(:ncol) = (3.84_r8*10.0_r8**(-6.0_r8))*(u10m(:ncol)**3.41_r8) + ! move the winds to 10m high from the midpoint of the gridbox: + u10m(:ncol)=u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) ! New whitecap area fraction / air entrainment flux from eqn. 6 in Salter et al. (2015) - ! JCA & MS Using Hanson & Phillips 99 air entrainment vs. wind speed + ! JCA & MS Using Hanson & Phillips 99 air entrainment vs. wind speed ! (Note the uncertainty in the factor 2, written as 2 pluss/minus 1 in Eq. 6 -> possible tuning factor) -!aktst+ whitecapAreaFraction(:ncol) = (2.0_r8*10.0_r8**(-8.0_r8))*(u10m(:ncol)**3.41_r8) whitecapAreaFraction(:ncol) = (2.0_r8*10.0_r8**(-8.0_r8))*(u10m(:ncol)**3.74_r8) -!aktst- - whitecapAreaFraction(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) * whitecapAreaFraction(:ncol) open_ocean(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) + !Eqn. 9 in Salter et al. (2015) do n=1,numberOfSaltModes - -! !eqn 1 in Kirkevag et al. (2013) -! numberFlux(:ncol,n) = whitecapAreaFraction(:ncol)* & -! ( & -! coeffA(n)*sst(:ncol)*sst(:ncol) & -! + coeffB(n)*sst(:ncol) & -! + coeffC(n) & -! ) - !Eqn. 9 in Salter et al. (2015) - numberFlux(:ncol,n) = whitecapAreaFraction(:ncol)* & - ( coeffA(n)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8) & - + coeffB(n)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8) & - + coeffC(n)*(sst(:ncol)-273.15_r8) & - + coeffD(n) ) - end do - + numberFlux(:ncol,n) = whitecapAreaFraction(:ncol)* & + ( coeffA(n)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8) & + + coeffB(n)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8) & + + coeffC(n)*(sst(:ncol)-273.15_r8) & + + coeffD(n) ) + end do do n=1,numberOfSaltModes - cam_in%cflx(:ncol, tracerMap(n)) = numberFlux(:ncol,n) & !#/m2/sec - / volumeToNumber(modeMap(n)) & !==> m3/m2/sec - * rhopart(tracerMap(n)) !==> kg/m2/sec + cam_in%cflx(:ncol, tracerMap(n)) = numberFlux(:ncol,n) & !#/m2/sec + / volumeToNumber(modeMap(n)) & !==> m3/m2/sec + * rhopart(tracerMap(n)) !==> kg/m2/sec end do - - !totalSaltEmis(:ncol)=0.0_r8 - !do n=1,numberOfSaltModes - ! totalSaltEmis(:ncol) = totalSaltEmis(:ncol) + cam_in%cflx(:ncol,tracerMap(n)) - !end do - !spracklenOMOceanSource(:ncol) = seasaltToSpracklenOM * totalSaltEmis(:ncol) - - !The above code scales to total seasalt emisisons. This scales to mode 1 - !so assuming that submicron OM is proportional to smallest sea salt mode spracklenOMOceanSource(:ncol) = cam_in%cflx(:ncol, tracerMap(1))*seasaltToSpracklenOM2 - !do i=1,ncol - ! if(ocnfrc(i).gt.0.999_r8 .and. icefrc(i).lt.0.000001_r8 .and. u10m(i).gt.5 .and. sst(i).gt. 284.0_r8)then - ! print*, "u,sst, s1, s2", u10m(i), sst(i), spracklenOMOceanSource(i), spracklenOMOCeanSource2(i) - ! end if - !end do - if (oslo_opom_inq())then call oslo_opom_emis_intr(cam_in%cflx(:ncol, tracerMap(1)), & - cam_in%cflx(:ncol, tracerMap(2)), & - cam_in%cflx(:ncol, tracerMap(3)), & - open_ocean ,ncol,lchnk, onOMOceanSource ) + cam_in%cflx(:ncol,tracerMap(2)), cam_in%cflx(:ncol,tracerMap(3)), & + open_ocean, ncol,lchnk, onOMOceanSource ) OMOceanSource(:ncol) = onOMOceanSource(:ncol) else OMOceanSource(:ncol) = spracklenOMOceanSource(:ncol) endif - return - end subroutine oslo_salt_emis_intr + !Add OM ocean source to cam_in + cam_in%cflx(:ncol,l_om_ni) = cam_in%cflx(:ncol,l_om_ni) + OMOceanSource(:ncol) + + end subroutine seasalt_emis end module seasalt_model From bb4d69a7c7b6bf6e5d021bf2abd0d363e605b8c0 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 21 Aug 2023 15:38:03 +0200 Subject: [PATCH 19/71] refactored dust model --- src/physics/cam_oslo/aero_model.F90 | 4 +- src/physics/cam_oslo/dust_model.F90 | 265 ++++++++++------------------ 2 files changed, 94 insertions(+), 175 deletions(-) diff --git a/src/physics/cam_oslo/aero_model.F90 b/src/physics/cam_oslo/aero_model.F90 index 386311cdbb..6065d13c5b 100644 --- a/src/physics/cam_oslo/aero_model.F90 +++ b/src/physics/cam_oslo/aero_model.F90 @@ -672,7 +672,7 @@ end subroutine aero_model_gasaerexch subroutine aero_model_emissions( state, cam_in ) use seasalt_model , only: seasalt_emis, seasalt_active - use dust_model , only: oslo_dust_emis_intr, dust_active + use dust_model , only: dust_emis, dust_active use oslo_ocean_intr , only: oslo_dms_emis_intr use physics_types , only: physics_state @@ -681,7 +681,7 @@ subroutine aero_model_emissions( state, cam_in ) type(cam_in_t), intent(inout) :: cam_in ! import state if (dust_active) then - call oslo_dust_emis_intr( state, cam_in) + call dust_emis( state, cam_in) ! some dust emis diagnostics ... endif diff --git a/src/physics/cam_oslo/dust_model.F90 b/src/physics/cam_oslo/dust_model.F90 index 4d03c4c97e..68c72e03a7 100644 --- a/src/physics/cam_oslo/dust_model.F90 +++ b/src/physics/cam_oslo/dust_model.F90 @@ -1,39 +1,28 @@ module dust_model + use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl - use spmd_utils, only: masterproc - use cam_abortutils, only: endrun -use constituents, only: cnst_name -use aerosoldef, only: l_dst_a2, l_dst_a3 -use camsrfexch, only: cam_in_t -use ppgrid, only: pcols -use cam_logfile, only: iulog + implicit none + private -implicit none -private -save + integer, parameter :: numberOfDustModes = 2 !define in aerosoldef? + character(len=6), public, dimension(10) :: dust_names - integer, parameter :: numberOfDustModes = 2 !define in aerosoldef? + integer :: tracerMap(numberOfDustModes) = (/-99, -99/) !index of dust tracers in the modes - !This can be refined, but the fractions in coarse/fine mode are approx ok - real(r8), parameter, dimension(numberOfDustModes) :: emis_fraction_in_mode = (/0.13_r8, 0.87_r8 /) - integer, dimension(numberOfDustModes) :: tracerMap = (/-99, -99/) !index of dust tracers in the modes - character(len=6), public, dimension(10) :: dust_names - integer, parameter, public :: dust_nbin = numberOfDustModes + real(r8), parameter :: emis_fraction_in_mode(numberOfDustModes) = (/0.13_r8, 0.87_r8 /) + integer, parameter, public :: dust_nbin = numberOfDustModes - !Related to soil erodibility - real(r8) :: dust_emis_fact = -1.e36_r8 ! tuning parameter for dust emissions - character(len=cl) :: soil_erod_file = 'soil_erod_file' ! full pathname for soil erodibility dataset + !Related to soil erodibility + real(r8) :: dust_emis_fact = -1.e36_r8 ! tuning parameter for dust emissions + character(len=cl) :: soil_erod_file = 'soil_erod_file' ! full pathname for soil erodibility dataset - logical, parameter, public :: dust_active = .TRUE. -public oslo_dust_emis_intr -public getNumberOfDustModes -public getDustTracerIndexInMode -public getEmissionFractionInDustMode -public isOsloDustTracer -public dust_init -public dust_readnl + logical, parameter, public :: dust_active = .TRUE. + ! public routines + public dust_readnl + public dust_init + public dust_emis !=============================================================================== contains @@ -43,6 +32,8 @@ subroutine dust_readnl(nlfile) use namelist_utils, only: find_group_name use units, only: getunit, freeunit + use cam_abortutils, only: endrun + use spmd_utils, only: masterproc use mpishorthand character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input @@ -52,7 +43,6 @@ subroutine dust_readnl(nlfile) character(len=*), parameter :: subname = 'dust_readnl' namelist /dust_nl/ dust_emis_fact, soil_erod_file - !----------------------------------------------------------------------------- ! Read namelist @@ -69,160 +59,89 @@ subroutine dust_readnl(nlfile) close(unitn) call freeunit(unitn) end if - #ifdef SPMD ! Broadcast namelist variables call mpibcast(dust_emis_fact, 1, mpir8, 0, mpicom) call mpibcast(soil_erod_file, len(soil_erod_file), mpichar, 0, mpicom) #endif + end subroutine dust_readnl + !=============================================================================== + subroutine dust_init() + use soil_erod_mod, only: soil_erod_init + use aerosoldef, only: l_dst_a2, l_dst_a3 + use constituents, only: cnst_name - end subroutine dust_readnl - function getEmissionFractionInDustMode(modeIndex) RESULT(fraction) - integer, intent(in) :: modeIndex - real(r8) :: fraction - fraction = emis_fraction_in_mode(modeIndex) - end function getEmissionFractionInDustMode - - function getNumberOfDustModes() RESULT(answer) - integer answer - answer = numberOfDustModes - end function getNumberOfDustModes - - - subroutine dust_init() - - use soil_erod_mod, only: soil_erod_init - implicit none - integer :: i - - - call soil_erod_init( dust_emis_fact, soil_erod_file ) - - call set_oslo_indices() - - dust_names(:)=" " - do i=1,numberOfDustModes - dust_names(i) = cnst_name(tracerMap(i)) - end do - - end subroutine dust_init - - subroutine set_oslo_indices() - implicit none - tracerMap(1) = l_dst_a2 - tracerMap(2) = l_dst_a3 - end subroutine set_oslo_indices - - - !**************************************************** - !This is copied from the MAM aerosols. Should not really - !be necessary since the land model could calculate emissions - !based on soil erodibility. - - !However, the following code in dustMod.F90 (land model) makes it - !necessary to apply it here! - !715 Set basin factor to 1 for now - !716 - !717 call get_proc_bounds(begg, endg, begl, endl, begc, endc, begp, endp) - !718 do c = begc, endc - !719 l = clm3%g%l%c%landunit(c) - !720 if (.not. clm3%g%l%lakpoi(l)) then - !721 mbl_bsn_fct(c) = 1.0_r8 - !722 end if - !723 end do - - !For a general discussion of these factors, see: - !Zender et al JGR (vol 108, D16, 2003) - !http://onlinelibrary.wiley.com/doi/10.1029/2002JD003039/abstract - - function getDustTracerIndexInMode(modeIndex)RESULT(answer) - integer, intent(in) :: modeIndex - integer answer - - answer = tracerMap(modeIndex) - - end function getDustTracerIndexInMode - - function isOsloDustTracer(physTracerIndex) RESULT(answer) - implicit none - integer, intent(in) :: physTracerIndex - integer :: n - logical :: answer - answer = .FALSE. - do n = 1, numberOfDustModes - if(tracerMap(n) .eq. physTracerIndex)then - answer = .TRUE. - end if - end do - end function isOsloDustTracer - - subroutine oslo_dust_emis_intr(state, cam_in) - - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Interface to emission of all dusts. - ! Notice that the mobilization is calculated in the land model (need #define BGC) and - ! the soil erodibility factor is applied here. - ! - ! see comments above in subroutine read_soil_erodibility_data - !----------------------------------------------------------------------- - use cam_history, only: outfld - use physics_types, only: physics_state - use soil_erod_mod, only : soil_erod_fact - use soil_erod_mod, only : soil_erodibility - - implicit none - - ! Arguments: - - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), target, intent(inout) :: cam_in ! import state - - ! Local variables - - integer :: lchnk - integer :: ncol - integer :: i,n - real(r8) :: soil_erod_tmp(pcols) - real(r8) :: totalEmissionFlux(pcols) - real(r8), pointer :: cflx(:,:) - - lchnk = state%lchnk - ncol = state%ncol - - !Filter away unreasonable values for soil erodibility - !(using low values e.g. gives emissions in greenland..) - where(soil_erodibility(:,lchnk) .lt. 0.1_r8) - soil_erod_tmp(:)=0.0_r8 - elsewhere - soil_erod_tmp(:)=soil_erodibility(:,lchnk) - end where - - totalEmissionFlux(:)=0.0_r8 - do i=1,ncol - totalEmissionFlux(i) = totalEmissionFlux(i) + sum(cam_in%dstflx(i,:)) - end do - - cflx => cam_in%cflx - - !Note that following CESM use of "dust_emis_fact", the emissions are - !scaled by the INVERSE of the factor!! - !There is another random scale factor of 1.15 there. Adapting the exact - !same formulation as MAM now and tune later - !As of NE-380: Oslo dust emissions are 2/3 of CAM emissions - do n=1, numberOfDustModes - cflx(:ncol, tracerMap(n)) = -1.0_r8*emis_fraction_in_mode(n) & - *totalEmissionFlux(:ncol)*soil_erod_tmp(:ncol)/(dust_emis_fact)*1.15_r8 ! gives better AOD close to dust sources - end do - + integer :: i + + call soil_erod_init( dust_emis_fact, soil_erod_file ) + + ! Set module variables + tracerMap(1) = l_dst_a2 + tracerMap(2) = l_dst_a3 - !call outfld('MBL_BSN_FCT',soil_erod_tmp,pcols,lchnk) - !call outfld('OSLO_DUST_EMIS',totalEmissionFlux,pcols,lchnk) + dust_names(:)=" " + do i=1,numberOfDustModes + dust_names(i) = cnst_name(tracerMap(i)) + end do + + end subroutine dust_init + + !=============================================================================== + subroutine dust_emis(state, cam_in) + + !----------------------------------------------------------------------- + ! Purpose: Interface to emission of all dusts. + ! Notice that the mobilization is calculated in the land model and + ! the soil erodibility factor is applied here. + !----------------------------------------------------------------------- + + use ppgrid, only: pcols + use physics_types, only: physics_state + use camsrfexch, only: cam_in_t + use soil_erod_mod, only: soil_erod_fact, soil_erodibility + + ! Arguments: + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), target, intent(inout) :: cam_in ! import state + + ! Local variables + integer :: lchnk + integer :: ncol + integer :: i,n + real(r8) :: soil_erod_tmp(pcols) + real(r8) :: totalEmissionFlux(pcols) + real(r8), pointer :: cflx(:,:) + + lchnk = state%lchnk + ncol = state%ncol + + !Filter away unreasonable values for soil erodibility + !(using low values e.g. gives emissions in greenland..) + where(soil_erodibility(:,lchnk) .lt. 0.1_r8) + soil_erod_tmp(:)=0.0_r8 + elsewhere + soil_erod_tmp(:)=soil_erodibility(:,lchnk) + end where + + totalEmissionFlux(:)=0.0_r8 + do i=1,ncol + totalEmissionFlux(i) = totalEmissionFlux(i) + sum(cam_in%dstflx(i,:)) + end do + + !Note that following CESM use of "dust_emis_fact", the emissions are + !scaled by the INVERSE of the factor!! + !There is another random scale factor of 1.15 there. Adapting the exact + !same formulation as MAM now and tune later + !As of NE-380: Oslo dust emissions are 2/3 of CAM emissions + + cflx => cam_in%cflx + do n=1, numberOfDustModes + cflx(:ncol, tracerMap(n)) = -1.0_r8*emis_fraction_in_mode(n) & + *totalEmissionFlux(:ncol)*soil_erod_tmp(:ncol)/(dust_emis_fact)*1.15_r8 ! gives better AOD close to dust sources + end do - return - end subroutine oslo_dust_emis_intr + end subroutine dust_emis end module dust_model From 46f6525998b24bd991e8274de2fe8c277d03e3ba Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 21 Aug 2023 21:51:54 +0200 Subject: [PATCH 20/71] removed modal_aero_data.F90 from physics/cam_oslo --- src/chemistry/oslo_aero/aerosoldef.F90 | 1052 ++++++------ src/chemistry/oslo_aero/condtend.F90 | 2 +- src/chemistry/oslo_aero/koagsub.F90 | 1483 ++++++++--------- src/chemistry/oslo_aero/nucleate_ice_oslo.F90 | 7 +- .../oslo_aero/oslo_aerosols_intr.F90 | 358 ++-- src/physics/cam_oslo/aero_model.F90 | 9 +- src/physics/cam_oslo/hetfrz_classnuc_oslo.F90 | 508 +++--- src/physics/cam_oslo/microp_aero.F90 | 70 +- src/physics/cam_oslo/modal_aero_data.F90 | 64 - 9 files changed, 1688 insertions(+), 1865 deletions(-) delete mode 100644 src/physics/cam_oslo/modal_aero_data.F90 diff --git a/src/chemistry/oslo_aero/aerosoldef.F90 b/src/chemistry/oslo_aero/aerosoldef.F90 index 46e855ad7e..9464447cc4 100644 --- a/src/chemistry/oslo_aero/aerosoldef.F90 +++ b/src/chemistry/oslo_aero/aerosoldef.F90 @@ -1,207 +1,192 @@ module aerosoldef -!--------------------------------------------------------------------------------- -! Module to set up register aerosols indexes, number of gas and particle -! species and their scavenging rates. Tables for humidity growth -!--------------------------------------------------------------------------------- -! Modified Spring 2015 by cka to include a version of RM's treatment of soa. (Makkonen et al. 2012) -! Modified Summer 2015 by ak to include a new treatment of sea-salt (Salter et al. 2015) - - use commondefinitions - use modal_aero_data, only: qqcw_set_ptr - use mo_tracname, only : solsym - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst, cnst_name,cnst_get_ind - use cam_abortutils, only: endrun + !--------------------------------------------------------------------------------- + ! Module to set up register aerosols indexes, number of gas and particle + ! species and their scavenging rates. Tables for humidity growth + !--------------------------------------------------------------------------------- + + use commondefinitions + use shr_kind_mod, only: r8 => shr_kind_r8 + use mo_tracname, only: solsym + use constituents, only: pcnst, cnst_name,cnst_get_ind + use cam_abortutils, only: endrun implicit none - save private ! Make default type private to the module - integer, public, parameter :: max_tracers_per_mode = 7 - real(r8), public,dimension (pcnst) ::rhopart - real(r8), public,dimension (pcnst) ::sgpart - real(r8), public,dimension (pcnst) ::osmoticCoefficient - real(r8), public,dimension (pcnst) ::numberOfIons - real(r8), public,dimension (pcnst) ::solubleMassFraction - integer, public,dimension (pcnst) ::aerosolType - real(r8), public, dimension(nbmodes) :: numberFractionAvailableAqChem - real(r8), public,dimension (pcnst) :: invrhopart - - - real(r8), public, parameter :: smallConcentration = 1.e-100_r8 !duplicate, sync with smallNumber in Const -! -! Public interfaces -! - public aero_register ! register consituents - public is_process_mode ! Check is an aerosol specie is a process mode - public isAerosol ! Check is specie is aerosol (i.e. gases get .FALSE. here) - public getTracerIndex - public getNumberOfTracersInMode - public getNumberOfBackgroundTracersInMode - public getCloudTracerIndex - public getCloudTracerIndexDirect - public getCloudTracerName - public chemistryIndex - public physicsIndex - public getDryDensity - public getConstituentFraction - public isTracerInMode - public fillAerosolTracerList - public getNumberOfAerosolTracers - public fillInverseAerosolTracerList - -!cka: Add SOA particles to mode 1 and 11 - integer, parameter, public :: MODE_IDX_BC_EXT_AC = 0 !Externally mixed BC accumulation mode - integer, parameter, public :: MODE_IDX_SO4SOA_AIT = 1 !SO4 and SOA in aitken mode, Created from 11 by growth (condensation) of SO4 -!cka integer, parameter, public :: MODE_IDX_SO4_AIT = 1 !Pure SO4 in aitken mode, Created from 11 by growth (condensation) of SO4 - integer, parameter, public :: MODE_IDX_BC_AIT = 2 !Created from 12 by growth (condensation) SO4 - integer, parameter, public :: MODE_IDX_NOT_USED = 3 !Not used - integer, parameter, public :: MODE_IDX_OMBC_INTMIX_COAT_AIT = 4 !Created from 14 by growth (condensation) of SO4 and from cloud processing/wet-phas - integer, parameter, public :: MODE_IDX_SO4_AC = 5 !Accumulation mode SO4 (mode will have other comps added) - integer, parameter, public :: MODE_IDX_DST_A2 = 6 !Accumulation mode dust (mode will have other comps added) - integer, parameter, public :: MODE_IDX_DST_A3 = 7 !Coarse mode dust (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SS_A1 = 8 !Fine mode sea-salt (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SS_A2 = 9 !Accumulation mode sea-salt (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SS_A3 = 10 !Coarse mode sea-salt (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SO4SOA_NUC = 11 !SO4 and SOA nucleation mode -!cka integer, parameter, public :: MODE_IDX_SO4_NUC = 11 !SO4 nucleation mode - integer, parameter, public :: MODE_IDX_BC_NUC = 12 !BC nucleation mode - integer, parameter, public :: MODE_IDX_LUMPED_ORGANICS = 13 !not used in lifecycle, but some extra mass goes here when max. allowed LUT conc. are too small - integer, parameter, public :: MODE_IDX_OMBC_INTMIX_AIT = 14 !mix quickly formed in fire-plumes - - integer, parameter, public :: numberOfExternallyMixedModes = 4 !Modes 0;11-14 (13 is not used in lifecycle) - integer, parameter, public :: numberOfInternallyMIxedMOdes = 9 !Modes 1-10 (3 is not used in lifecycle) - - integer, parameter, public :: numberOfProcessModeTracers = 6 - integer, public, dimension(numberOfProcessModeTracers) :: tracerInProcessMode - integer, public, dimension(pcnst) :: processModeMap - - !These tables describe how the tracers behave chemically - integer, dimension(numberOfExternallyMixedModes), public :: externallyMixedMode = (/MODE_IDX_BC_EXT_AC,MODE_IDX_SO4SOA_NUC, MODE_IDX_BC_NUC, MODE_IDX_OMBC_INTMIX_AIT /) - integer, dimension(numberOfInternallyMixedMOdes), public :: internallyMixedMode = (/MODE_IDX_SO4SOA_AIT, MODE_IDX_BC_AIT, MODE_IDX_OMBC_INTMIX_COAT_AIT & - ,MODE_IDX_SO4_AC, MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SS_A1 & - ,MODE_IDX_SS_A2, MODE_IDX_SS_A3 /) - -!cka: add l_soa_n, l_soa_na (particles) l_soa_a1 (condensate) and l_soa_lv, l_soa_sv (SOA precursors) -! following are species indices for individual camuio species + integer, public, parameter :: max_tracers_per_mode = 7 + real(r8), public, dimension (pcnst) :: rhopart + real(r8), public, dimension (pcnst) :: sgpart + real(r8), public, dimension (pcnst) :: osmoticCoefficient + real(r8), public, dimension (pcnst) :: numberOfIons + real(r8), public, dimension (pcnst) :: solubleMassFraction + integer, public, dimension (pcnst) :: aerosolType + real(r8), public, dimension(nbmodes) :: numberFractionAvailableAqChem + real(r8), public, dimension (pcnst) :: invrhopart + real(r8), public, parameter :: smallConcentration = 1.e-100_r8 !duplicate, sync with smallNumber in Const + ! + ! Public interfaces + ! + public aero_register ! register consituents + public is_process_mode ! Check is an aerosol specie is a process mode + public isAerosol ! Check is specie is aerosol (i.e. gases get .FALSE. here) + public getTracerIndex + public getNumberOfTracersInMode + public getNumberOfBackgroundTracersInMode + public getCloudTracerIndex + public getCloudTracerIndexDirect + public getCloudTracerName + public chemistryIndex + public physicsIndex + public getDryDensity + public getConstituentFraction + public isTracerInMode + public fillAerosolTracerList + public getNumberOfAerosolTracers + public fillInverseAerosolTracerList + public qqcw_get_field + + integer, parameter, public :: MODE_IDX_BC_EXT_AC = 0 !Externally mixed BC accumulation mode + integer, parameter, public :: MODE_IDX_SO4SOA_AIT = 1 !SO4 and SOA in aitken mode, Created from 11 by growth (condensation) of SO4 + integer, parameter, public :: MODE_IDX_BC_AIT = 2 !Created from 12 by growth (condensation) SO4 + integer, parameter, public :: MODE_IDX_NOT_USED = 3 !Not used + integer, parameter, public :: MODE_IDX_OMBC_INTMIX_COAT_AIT = 4 !Created from 14 by growth (condensation) of SO4 and from cloud processing/wet-phas + integer, parameter, public :: MODE_IDX_SO4_AC = 5 !Accumulation mode SO4 (mode will have other comps added) + integer, parameter, public :: MODE_IDX_DST_A2 = 6 !Accumulation mode dust (mode will have other comps added) + integer, parameter, public :: MODE_IDX_DST_A3 = 7 !Coarse mode dust (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SS_A1 = 8 !Fine mode sea-salt (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SS_A2 = 9 !Accumulation mode sea-salt (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SS_A3 = 10 !Coarse mode sea-salt (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SO4SOA_NUC = 11 !SO4 and SOA nucleation mode + integer, parameter, public :: MODE_IDX_BC_NUC = 12 !BC nucleation mode + integer, parameter, public :: MODE_IDX_LUMPED_ORGANICS = 13 !not used in lifecycle, but some extra mass goes here when max. allowed LUT conc. are too small + integer, parameter, public :: MODE_IDX_OMBC_INTMIX_AIT = 14 !mix quickly formed in fire-plumes + + integer, parameter, public :: numberOfExternallyMixedModes = 4 !Modes 0;11-14 (13 is not used in lifecycle) + integer, parameter, public :: numberOfInternallyMIxedMOdes = 9 !Modes 1-10 (3 is not used in lifecycle) + + integer, parameter, public :: numberOfProcessModeTracers = 6 + integer, public, dimension(numberOfProcessModeTracers) :: tracerInProcessMode + integer, public, dimension(pcnst) :: processModeMap + + !These tables describe how the tracers behave chemically + integer, dimension(numberOfExternallyMixedModes), public :: externallyMixedMode = & + (/MODE_IDX_BC_EXT_AC,MODE_IDX_SO4SOA_NUC, MODE_IDX_BC_NUC, MODE_IDX_OMBC_INTMIX_AIT /) + integer, dimension(numberOfInternallyMixedMOdes), public :: internallyMixedMode = & + (/MODE_IDX_SO4SOA_AIT, MODE_IDX_BC_AIT, MODE_IDX_OMBC_INTMIX_COAT_AIT & + ,MODE_IDX_SO4_AC, MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SS_A1 & + ,MODE_IDX_SS_A2, MODE_IDX_SS_A3 /) + + ! following are species indices for individual camuio species integer,public :: & - l_so4_na, l_so4_a1, l_so4_a2, l_so4_ac, & - l_bc_n, l_bc_ax, l_bc_ni, l_bc_a, l_bc_ai,l_bc_ac, & - l_om_ni, l_om_ai ,l_om_ac, & - l_so4_pr, & - l_dst_a2, l_dst_a3, & - l_ss_a1, l_ss_a2, l_ss_a3, l_h2so4, & - l_soa_na, l_soa_a1, l_soa_lv, l_soa_sv - -! some code here has been moved to commondefinitions... + l_so4_na, l_so4_a1, l_so4_a2, l_so4_ac, & + l_bc_n, l_bc_ax, l_bc_ni, l_bc_a, l_bc_ai,l_bc_ac, & + l_om_ni, l_om_ai ,l_om_ac, & + l_so4_pr, & + l_dst_a2, l_dst_a3, & + l_ss_a1, l_ss_a2, l_ss_a3, l_h2so4, & + l_soa_na, l_soa_a1, l_soa_lv, l_soa_sv - integer :: n_aerosol_tracers !number of aerosol tracers + integer :: n_aerosol_tracers !number of aerosol tracers + integer :: imozart - integer :: imozart + !Number of transported tracers in each mode + integer, parameter, dimension(0:nmodes) :: n_tracers_in_mode = (/ 1, 4, 3, 0, 5, 7, 7, 7, 7, 7, 7, 0, 1, 0, 2 /) + integer, parameter, dimension(0:nmodes) :: n_background_tracers_in_mode = (/ 1,2,1,0,2,1,1,1,1,1,1,0,1,0,2 /) + integer, dimension(0:nmodes, max_tracers_per_mode) :: tracer_in_mode - !Number of transported tracers in each mode - integer, parameter, dimension(0:nmodes) :: n_tracers_in_mode = (/ 1, 4, 3, 0, 5, 7, 7, 7, 7, 7, 7, 0, 1, 0, 2 /) !cka: added organic condensate to mode 1,2,4-10 - integer, parameter, dimension(0:nmodes) :: n_background_tracers_in_mode = (/ 1,2,1,0,2,1,1,1,1,1,1,0,1,0,2 /) !cka: added soa to mode 1 and 11 + !Radius used for the modes in the lifeCycle MAY ASSUME SOME GROWTH ALREADY HAPPENED + real(r8), parameter, public, dimension(0:nmodes) :: lifeCycleNumberMedianRadius = & + 1.e-6_r8*(/ 0.0626_r8, 0.025_r8, 0.025_r8, 0.04_r8, 0.06_r8, 0.075_r8, & + 0.22_r8, 0.63_r8, 0.0475_r8, 0.30_r8, 0.75_r8, & ! Salter et al. (2015) + 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8 /) - integer, dimension(0:nmodes, max_tracers_per_mode) :: tracer_in_mode + !Sigma based on original lifecycle code (taken from "sigmak" used previously in lifecycle code) + real(r8), parameter, public, dimension(0:nmodes) :: lifeCycleSigma = (/1.6_r8, 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 & !0-4 + ,1.59_r8, 1.59_r8, 2.0_r8 & !5,6,7 (SO4+dust) + ,2.1_r8, 1.72_r8, 1.6_r8 & !8-10 (SS) ! Salter et al. (2015) + ,1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 & !11-14 + /) + !Below cloud scavenging coefficients for modes which have an actual size + real(r8), parameter, public, dimension(0:nmodes) :: belowCloudScavengingCoefficient= & + (/ 0.01_r8 , 0.02_r8 , 0.02_r8 , 0.0_r8 , 0.02_r8, 0.01_r8, & !(0-5) + 0.02_r8 , 0.2_r8 , 0.02_r8 , 0.02_r8, 0.5_r8, & !6-10 (DUST+SS) + 0.04_r8 , 0.08_r8 , 0.0_r8 , 0.02_r8 /) ! SO4_n, bc_n, N/A og bc/oc - !Radius used for the modes in the lifeCycle MAY ASSUME SOME GROWTH ALREADY HAPPENED - real(r8), parameter, public, dimension(0:nmodes) :: lifeCycleNumberMedianRadius = & -!BCsizes 1.e-6_r8*(/ 0.1_r8, 0.02_r8, 0.0118_r8, 0.04_r8, 0.04_r8, 0.075_r8, & - 1.e-6_r8*(/ 0.0626_r8, 0.025_r8, 0.025_r8, 0.04_r8, 0.06_r8, 0.075_r8, & - 0.22_r8, 0.63_r8, 0.0475_r8, 0.30_r8, 0.75_r8, & ! Salter et al. (2015) -!BCsizes 0.0118_r8, 0.0118_r8, 0.04_r8, 0.04_r8 /) - 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8 /) + !Treatment of process-modes! + !The tracers indices can not be set here since they are not known on compile time + !tracerInProcessMode = (/l_so4_a1, l_so4_a2, l_so4_ac, l_om_ac, l_bc_ac, l_soa_a1 /) - !Sigma based on original lifecycle code (taken from "sigmak" used previously in lifecycle code) - real(r8), parameter, public, dimension(0:nmodes) :: lifeCycleSigma = (/1.6_r8, 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 & !0-4 - ,1.59_r8, 1.59_r8, 2.0_r8 & !5,6,7 (SO4+dust) - ,2.1_r8, 1.72_r8, 1.6_r8 & !8-10 (SS) ! Salter et al. (2015) - ,1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 & !11-14 - /) + !The process modes need an "efficient size" (Why does A1 have a different size than the others??) + real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeNumberMedianRadius = & + (/ 0.04e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.04e-6_r8 /) - !Below cloud scavenging coefficients for modes which have an actual size - real(r8), parameter, public, dimension(0:nmodes) :: belowCloudScavengingCoefficient= & - (/ 0.01_r8 , 0.02_r8 , 0.02_r8 , 0.0_r8 , 0.02_r8, 0.01_r8, & !(0-5) - 0.02_r8 , 0.2_r8 , 0.02_r8 , 0.02_r8, 0.5_r8, & !6-10 (DUST+SS) - 0.04_r8 , 0.08_r8 , 0.0_r8 , 0.02_r8 /) ! SO4_n, bc_n, N/A og bc/oc + !The process modes need an "efficient sigma" + real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeSigma = & + (/ 1.8_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.8_r8 /) - !Treatment of process-modes! - !The tracers indices can not be set here since they are not known on compile time - !tracerInProcessMode = (/l_so4_a1, l_so4_a2, l_so4_ac, l_om_ac, l_bc_ac, l_soa_a1 /) - !The process modes need an "efficient size" (Why does A1 have a different size than the others??) - real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeNumberMedianRadius = & - (/ 0.04e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.04e-6_r8 /) + real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: belowCloudScavengingCoefficientProcessModes = & + (/0.02_r8, 0.01_r8, 0.02_r8, 0.02_r8, 0.02_r8, 0.02_r8 /) - !The process modes need an "efficient sigma" - real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeSigma = & - (/ 1.8_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.8_r8 /) - + !Growth of aerosols, duplicated in opttab!! AK: NB oppdaterte tall i opttab, rh der er ikke helt lik rhtab... + real(r8), public,dimension (10) :: rhtab + real(r8), public,dimension (10,pcnst):: rdivr0(10,pcnst) - real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: belowCloudScavengingCoefficientProcessModes = & - (/0.02_r8, 0.01_r8, 0.02_r8, 0.02_r8, 0.02_r8, 0.02_r8 /) + data rhtab/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, 0.80_r8, 0.85_r8, 0.90_r8, 0.95_r8, 0.98_r8 / - !Growth of aerosols, duplicated in opttab!! AK: NB oppdaterte tall i opttab, rh der er ikke helt lik rhtab... - real(r8), public,dimension (10) :: rhtab - real(r8), public,dimension (10,pcnst):: rdivr0(10,pcnst) + integer, dimension(pcnst) :: cloudTracerIndex + character(len=20) :: cloudTracerName(pcnst) - data rhtab/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, 0.80_r8, 0.85_r8, 0.90_r8, 0.95_r8, 0.98_r8 / + integer, private :: qqcw(pcnst)=-1 ! Remaps modal_aero indices into pbuf - integer, dimension(pcnst) :: cloudTracerIndex - character(len=20) :: cloudTracerName(pcnst) contains - - !For a tracer in an aerosol mode, check if this is - !actually a real tracer or a process mode - function is_process_mode(l_index_in, isChemistry) result(answer) - implicit none - integer, intent(in) :: l_index_in - logical, intent(in) :: isChemistry !true if called from chemistry - integer :: l_index_phys - logical :: answer - - l_index_phys = l_index_in - if(isChemistry .eqv. .true.)then - l_index_phys = l_index_phys + iMozart - 1 - endif - - !answer becomes true if tracer is a "process mode" - answer = .FALSE. - if(l_index_phys .eq. l_so4_a1 & + !For a tracer in an aerosol mode, check if this is + !actually a real tracer or a process mode + function is_process_mode(l_index_in, isChemistry) result(answer) + integer, intent(in) :: l_index_in + logical, intent(in) :: isChemistry !true if called from chemistry + integer :: l_index_phys + logical :: answer + + l_index_phys = l_index_in + if(isChemistry .eqv. .true.)then + l_index_phys = l_index_phys + iMozart - 1 + endif + + !answer becomes true if tracer is a "process mode" + answer = .FALSE. + if(l_index_phys .eq. l_so4_a1 & .OR. l_index_phys .eq. l_so4_a2 & .OR. l_index_phys .eq. l_so4_ac & .OR. l_index_phys .eq. l_bc_ac & .OR. l_index_phys .eq. l_om_ac & .OR. l_index_phys .eq. l_soa_a1 ) then - answer = .TRUE. - endif - - return - end function is_process_mode + answer = .TRUE. + endif -!=============================================================================== - subroutine aero_register -!----------------------------------------------------------------------- -! -! Register aerosol modes and indices, should be changed to read in values -! instead of hard-coding it. -! -!----------------------------------------------------------------------- + return + end function is_process_mode - use mpishorthand - use physics_buffer, only: pbuf_add_field, dtype_r8 - use ppgrid, only: pcols, pver, pverp + !=============================================================================== + subroutine aero_register + !----------------------------------------------------------------------- + ! + ! Register aerosol modes and indices, should be changed to read in values + ! instead of hard-coding it. + ! + !----------------------------------------------------------------------- + use mpishorthand + use physics_buffer, only: pbuf_add_field, dtype_r8 + use ppgrid, only: pcols, pver, pverp - implicit none integer :: idx_dum, l,m,mm logical isAlreadyCounted(pcnst) -! register the species + ! register the species call cnst_get_ind('SO4_NA',l_so4_na, abort=.true.) !Aitken mode sulfate (growth from so4_n) call cnst_get_ind('SO4_A1',l_so4_a1, abort=.true.) !sulfate condensate (gas phase production) @@ -227,7 +212,7 @@ subroutine aero_register call cnst_get_ind('SS_A2',l_ss_a2, abort=.true.) !Sea salt accumulation mode call cnst_get_ind('SS_A3',l_ss_a3, abort=.true.) !Sea salt coarse mode -!cka: register SOA species + !cka: register SOA species call cnst_get_ind('SOA_NA',l_soa_na, abort=.true.) !Aitken mode SOA with SO4 and SOA condensate call cnst_get_ind('SOA_A1',l_soa_a1, abort=.true.) !SOA condensate call cnst_get_ind('SOA_LV',l_soa_lv, abort=.true.) !Gas phase low volatile SOA @@ -240,40 +225,42 @@ subroutine aero_register call registerTracersInMode() !Set the aerosol types - aerosolType(:)=-99 - aerosolType(l_so4_na)=AEROSOL_TYPE_SULFATE - aerosolType(l_so4_a1)=AEROSOL_TYPE_SULFATE - aerosolType(l_so4_a2)=AEROSOL_TYPE_SULFATE - aerosolType(l_so4_ac)=AEROSOL_TYPE_SULFATE - aerosolType(l_so4_pr)=AEROSOL_TYPE_SULFATE - aerosolType(l_bc_n)=AEROSOL_TYPE_BC - aerosolType(l_bc_ax)=AEROSOL_TYPE_BC - aerosolType(l_bc_ni)=AEROSOL_TYPE_BC - aerosolType(l_bc_a) =AEROSOL_TYPE_BC - aerosolType(l_bc_ai)=AEROSOL_TYPE_BC - aerosolType(l_bc_ac)=AEROSOL_TYPE_BC - aerosolType(l_om_ni)=AEROSOL_TYPE_OM - aerosolType(l_om_ai)=AEROSOL_TYPE_OM - aerosolType(l_om_ac)=AEROSOL_TYPE_OM - aerosolType(l_dst_a2)=AEROSOL_TYPE_DUST - aerosolType(l_dst_a3)=AEROSOL_TYPE_DUST - aerosolType(l_ss_a1)=AEROSOL_TYPE_SALT - aerosolType(l_ss_a2)=AEROSOL_TYPE_SALT - aerosolType(l_ss_a3)=AEROSOL_TYPE_SALT - aerosolType(l_soa_na)=AEROSOL_TYPE_OM - aerosolType(l_soa_a1)=AEROSOL_TYPE_OM + aerosolType(:) = -99 + aerosolType(l_so4_na) = AEROSOL_TYPE_SULFATE + aerosolType(l_so4_a1) = AEROSOL_TYPE_SULFATE + aerosolType(l_so4_a2) = AEROSOL_TYPE_SULFATE + aerosolType(l_so4_ac) = AEROSOL_TYPE_SULFATE + aerosolType(l_so4_pr) = AEROSOL_TYPE_SULFATE + aerosolType(l_bc_n) = AEROSOL_TYPE_BC + aerosolType(l_bc_ax) = AEROSOL_TYPE_BC + aerosolType(l_bc_ni) = AEROSOL_TYPE_BC + aerosolType(l_bc_a) = AEROSOL_TYPE_BC + aerosolType(l_bc_ai) = AEROSOL_TYPE_BC + aerosolType(l_bc_ac) = AEROSOL_TYPE_BC + aerosolType(l_om_ni) = AEROSOL_TYPE_OM + aerosolType(l_om_ai) = AEROSOL_TYPE_OM + aerosolType(l_om_ac) = AEROSOL_TYPE_OM + aerosolType(l_dst_a2) = AEROSOL_TYPE_DUST + aerosolType(l_dst_a3) = AEROSOL_TYPE_DUST + aerosolType(l_ss_a1) = AEROSOL_TYPE_SALT + aerosolType(l_ss_a2) = AEROSOL_TYPE_SALT + aerosolType(l_ss_a3) = AEROSOL_TYPE_SALT + aerosolType(l_soa_na) = AEROSOL_TYPE_OM + aerosolType(l_soa_a1) = AEROSOL_TYPE_OM rhopart(:)= 1000.0_r8 + !assign values based on aerosol type do m=0,nmodes do l=1,n_tracers_in_mode(m) mm= getTracerIndex(m,l,.false.) - osmoticCoefficient(mm) = aerosol_type_osmotic_coefficient(aerosolType(mm)) - rhopart(mm) = aerosol_type_density(aerosolType(mm)) - solubleMassFraction(mm) = aerosol_type_soluble_mass_fraction(aerosolType(mm)) - numberOfIons(mm) = aerosol_type_number_of_ions(aerosolType(mm)) - end do + osmoticCoefficient(mm) = aerosol_type_osmotic_coefficient(aerosolType(mm)) + rhopart(mm) = aerosol_type_density(aerosolType(mm)) + solubleMassFraction(mm) = aerosol_type_soluble_mass_fraction(aerosolType(mm)) + numberOfIons(mm) = aerosol_type_number_of_ions(aerosolType(mm)) + end do end do + !SPECIAL CASES OF AEROSOL PROPERTIES: !Density of bc_ax is rewritten later (calculated from fractal dimension) !so4_a2 is different since it is ammonium sulfate and not sulf. acid. @@ -284,8 +271,10 @@ subroutine aero_register rhopart(l_h2so4)= 1841.0_r8 rhopart(l_soa_lv) = aerosol_type_density(AEROSOL_TYPE_OM) rhopart(l_soa_sv) = aerosol_type_density(AEROSOL_TYPE_OM) -! Inverse calculated to avoid unneeded divisions in loop + + ! Inverse calculated to avoid unneeded divisions in loop invrhopart(:)=1._r8/rhopart(:) + !Set process mode sizes tracerInProcessMode = (/l_so4_a1, l_so4_a2, l_so4_ac, l_om_ac, l_bc_ac, l_soa_a1 /) processModeMap(:)=-99 !Force error if using unset values @@ -297,30 +286,29 @@ subroutine aero_register end do end do - !Find out first mozart tracers (fxm: short lived species might mess up this!) + ! Find out first mozart tracers (fxm: short lived species might mess up this!) call cnst_get_ind(trim(solsym(1)), imozart, abort=.true.) - !Add the cloud-tracers + !Add the cloud-tracers isAlreadyCounted(:) = .false. cloudTracerIndex(:) = -1 do m=1,nmodes do l=1,n_tracers_in_mode(m) mm= getTracerIndex(m,l,.false.) if(.not. isAlreadyCounted(mm))then - cloudTracerName(mm) = trim(cnst_name(mm))//"_OCW" - !print*, "CTN ", trim(cloudTracerName(mm)) - call pbuf_add_field(trim(cloudTracerName(mm)), 'global', dtype_r8, (/pcols,pver/), idx_dum) - call qqcw_set_ptr(mm,idx_dum) - cloudTracerIndex(mm) = idx_dum - isAlreadyCounted(mm) = .true. + cloudTracerName(mm) = trim(cnst_name(mm))//"_OCW" + call pbuf_add_field(trim(cloudTracerName(mm)), 'global', dtype_r8, (/pcols,pver/), idx_dum) + ! Set the module variable qqcw(mm) to be set to idx_dum + call qqcw_set_ptr(mm,idx_dum) + cloudTracerIndex(mm) = idx_dum + isAlreadyCounted(mm) = .true. endif - end do + end do end do - !Find out how many aerosol-tracers we carry - isAlreadyCounted(:) = .FALSE. - n_aerosol_tracers=0 + isAlreadyCounted(:) = .false. + n_aerosol_tracers = 0 do m=1,nmodes do l=1,n_tracers_in_mode(m) mm=getTracerIndex(m,l,.false.) @@ -331,340 +319,312 @@ subroutine aero_register end do end do - !Tabulated rh-growth for all species - call inittabrh - + !Tabulated rh-growth for all species + call inittabrh - return end subroutine aero_register - function getNumberOfAerosolTracers()RESULT(numberOfTracers) - implicit none - integer :: numberOfTracers - numberOfTracers = n_aerosol_tracers - end function getNumberOfAerosolTracers + function getNumberOfAerosolTracers()RESULT(numberOfTracers) + integer :: numberOfTracers + numberOfTracers = n_aerosol_tracers + end function getNumberOfAerosolTracers - function chemistryIndex(phys_index) RESULT (chemistryIndexOut) - implicit none - integer, intent(in) :: phys_index - integer :: chemistryIndexOut + function chemistryIndex(phys_index) RESULT (chemistryIndexOut) + implicit none + integer, intent(in) :: phys_index + integer :: chemistryIndexOut + chemistryIndexOut = phys_index - imozart + 1 + end function chemistryIndex - chemistryIndexOut = phys_index - imozart + 1 - end function chemistryIndex - function physicsIndex(chem_index) RESULT(physIndexOut) - implicit none - integer, intent(in) :: chem_index - integer :: physIndexOut - - physIndexOut = chem_index + imozart - 1 + integer, intent(in) :: chem_index + integer :: physIndexOut + physIndexOut = chem_index + imozart - 1 end function physicsIndex function isAerosol(phys_index) RESULT(answer) - integer, intent(in) :: phys_index - logical answer - answer=.FALSE. - if(aerosolType(phys_index) .gt. 0)then - answer = .TRUE. - endif - return + integer, intent(in) :: phys_index + logical answer + answer=.FALSE. + if(aerosolType(phys_index) .gt. 0)then + answer = .TRUE. + endif + return end function isAerosol -!============================================================================= - - function getNumberOfTracersInMode(modeIndex) RESULT(numberOfSpecies) - implicit none - integer, intent(in) :: modeIndex - integer numberOfSpecies - numberOfSpecies = n_tracers_in_mode(modeIndex) - end function getNumberOfTracersInMode - - function getNumberOfBackgroundTracersInMode(modeIndex) RESULT (numberOfBackgroundSpecies) - implicit none - integer, intent(in) :: modeIndex - integer numberOfBackgroundSpecies - numberOfBackgroundSpecies = n_background_tracers_in_mode(modeIndex) - end function getNumberOfBackgroundTracersInMode - - !purpose: Ask for an index in mode - !The index is the index in the q-array - !Some tracers may exist in several modes (is that a problem??) - function getTracerIndex(modeIndex, componentIndex, isChemistry) RESULT(tracerIndex) - implicit none - integer, intent(in) :: modeIndex - integer, intent(in) :: componentIndex - logical, intent(in) :: isChemistry - integer tracerIndex - - if(isChemistry)then - !This is tracer index in physics array - tracerIndex = tracer_in_mode(modeIndex,componentIndex)-imozart+1 - else - tracerIndex = tracer_in_mode(modeIndex,componentIndex) - endif - - end function getTracerIndex - - !Obtain an index in the physics-buffer for a component in the lifecycle scheme - function getCloudTracerIndex(modeIndex, componentIndex) RESULT(cloud_tracer_index) - implicit none - integer, intent(in) :: modeIndex - integer, intent(in) :: componentIndex - integer :: tracerIndex - integer cloud_tracer_index - - if(componentIndex == 0)then - !Special key for number concentration of a mode - print*,"error no such species" - stop - else if (componentIndex > 0)then - !Lifecycle specie in a mode - tracerIndex = getTracerIndex(modeIndex,componentIndex,.false.) - cloud_tracer_index = cloudTracerIndex(tracerIndex) !ak: Index in phys-buffer - else - !error, negative component index - call endrun("negative componentindex in getCloudTracerIndex") - endif - end function getCloudTracerIndex - - !returns index in pbuf for the corresponding cloud tracer with physics index "tracerIndex" - !returns "-1" if the tracer does not have any corresponding cloud tracer - function getCloudTracerIndexDirect(tracerIndex) RESULT(cloudTracerIndexOut) - implicit none - integer, intent(in) :: tracerIndex - integer :: cloudTracerIndexOut - - cloudTracerIndexOut = cloudTracerIndex(tracerIndex) - - end function getCloudTracerIndexDirect - - function getDryDensity(m,l) RESULT(density) - implicit none - integer, intent(in) :: m !mode index - integer, intent(in) :: l !tracer index - real(r8) :: density - density = rhopart(tracer_in_mode(m,l)) - end function - - - function getCloudTracerName(tracerIndex) RESULT(cloudTracerNameOut) - implicit none - integer, intent(in) :: tracerIndex - character(len=20) :: cloudTracerNameOut - cloudTracerNameOut = trim(cloudTracerName(tracerIndex)) - return - end function getCloudTracerName - - subroutine fillAerosolTracerList(aerosolTracerList) - implicit none - integer, dimension (:), intent(out) :: aerosolTracerList - logical, dimension(pcnst) :: alreadyFound - - integer :: m,l,mm,nTracer - - alreadyFound(:) = .FALSE. - - nTracer = 0 - do m=1,nmodes - do l=1,n_tracers_in_mode(m) - mm=getTracerIndex(m,l,.FALSE.) - if(.NOT.alreadyFound(mm))then - nTracer = nTracer + 1 - alreadyFound(mm) = .TRUE. - aerosolTracerList(nTracer) = mm - end if - end do - end do - end subroutine fillAerosolTracerList - - subroutine fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) - implicit none - integer, dimension(:), intent(in) :: aerosolTracerList - integer, intent(in) :: n_aerosol_tracers - integer, dimension(pcnst), intent(out) :: inverseAerosolTracerList - integer :: i - - inverseAerosolTracerList(:) = -99 - do i=1,n_aerosol_tracers - inverseAerosolTracerList(aerosolTracerList(i)) = i - end do - - end subroutine - - !Register tracer index in modes - subroutine registerTracersInMode() - - implicit none - - tracer_in_mode(:,:) = -1 !undefined - !externally mixed bc - tracer_in_mode(MODE_IDX_BC_EXT_AC, 1:n_tracers_in_mode(MODE_IDX_BC_EXT_AC)) = (/l_bc_ax/) -!cka !sulphate + sulfate condensate -!cka tracer_in_mode(MODE_IDX_SO4_AIT, 1:n_tracers_in_mode(MODE_IDX_SO4_AIT) ) = (/l_so4_na, l_so4_a1/) - !sulphate + soa, sulfate condensate. - tracer_in_mode(MODE_IDX_SO4SOA_AIT, 1:n_tracers_in_mode(MODE_IDX_SO4SOA_AIT) ) = (/l_so4_na, l_soa_na, l_so4_a1, l_soa_a1/) - !bc + sulfate condensate - tracer_in_mode(MODE_IDX_BC_AIT,1:n_tracers_in_mode(MODE_IDX_BC_AIT)) = (/l_bc_a, l_so4_a1, l_soa_a1/) - !index not used - !tracer_in_mode(MODE_IDX_NOT_USED, 1:n_tracers_in_mode(MODE_IDX_NOT_USED)) = (/-1/) - !om / bc internally mixed with sulfate condensate and aquous phase sulfate - tracer_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT))= (/l_bc_ai, l_om_ai, l_so4_a1, l_so4_a2, l_soa_a1 /) - !accumulation mode sulfate with coagulate, condensate and aquous phase sulfate - tracer_in_mode(MODE_IDX_SO4_AC, 1:n_tracers_in_mode(MODE_IDX_SO4_AC)) = (/l_so4_pr, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - !ac-mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_DST_A2, 1:n_tracers_in_mode(MODE_IDX_DST_A2)) = (/l_dst_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - !coarse mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_DST_A3, 1:n_tracers_in_mode(MODE_IDX_DST_A3)) = (/l_dst_a3, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - !at-mode ss with sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_SS_A1, 1:n_tracers_in_mode(MODE_IDX_SS_A1)) = (/l_ss_a1, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - !ac mode ss with sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_SS_A2, 1:n_tracers_in_mode(MODE_IDX_SS_A2)) = (/l_ss_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - !coarse mode ss sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_SS_A3, 1:n_tracers_in_mode(MODE_IDX_SS_A3)) = (/l_ss_a3, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - !sulfate + soa nucleation mode (mode no longer used) - !tracer_in_mode(MODE_IDX_SO4SOA_NUC, 1:n_tracers_in_mode(MODE_IDX_SO4SOA_NUC)) = (/ -1 /) - !bc in nucleation mode - tracer_in_mode(MODE_IDX_BC_NUC, 1:n_tracers_in_mode(MODE_IDX_BC_NUC)) = (/l_bc_n/) - !lumped organics - !tracer_in_mode(MODE_IDX_LUMPED_ORGANICS, 1:n_tracers_in_mode(MODE_IDX_LUMPED_ORGANICS)) = (/-1/) - !intermal mixture bc/oc coated - tracer_in_mode(MODE_IDX_OMBC_INTMIX_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_AIT)) = (/l_bc_ni, l_om_ni/) - - end subroutine registerTracersInMode - ! - - function isTracerInMode(modeIndex, constituentIndex)RESULT(answer) - implicit none - integer, intent(in) :: modeIndex - integer, intent(in) :: constituentIndex - integer :: i - logical :: answer - answer = .FALSE. - do i=1,n_tracers_in_mode(modeIndex) - if(tracer_in_mode(modeIndex,i) == constituentIndex)then - answer = .TRUE. - endif - enddo - return - end function isTracerInMode - ! - - function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond,f_soa & - ,Cam, f_acm, f_bcm, f_aqm, f_so4_condm,f_soam, constituentIndex,debugPrint ) RESULT(fraction) ! mass fraction - implicit none - real(r8), intent(in) :: CProcessModes - real(r8), intent(in) :: f_c - real(r8), intent(in) :: f_bc - real(r8), intent(in) :: f_aq - real(r8), intent(in) :: f_so4_cond - real(r8), intent(in) :: f_soa - real(r8), intent(in) :: cam - real(r8), intent(in) :: f_aqm - real(r8), intent(in) :: f_bcm - real(r8), intent(in) :: f_acm - real(r8), intent(in) :: f_so4_condm - real(r8), intent(in) :: f_soam - integer, intent(in) :: constituentIndex - logical, optional, intent(in) :: debugPrint - logical :: doPrint = .false. - real(r8) :: fraction - - if(present(debugPrint))then - if(debugPrint .eqv. .true.)then - doPrint=.true. - endif - endif - - - fraction = 1.0_r8 ! fraction = 1 for all tracers, except special cases (process modes) below - - !This fraction is the mass of a certain tracer in a specific size-mode divided by the total - !mass of the same tracer for (i.e. summed up over) all size-modes. This total mass is what - !is transported in the model, in the life cycle scheme. The word size-mode is here used for a mode in the - !aerosol size-distribution, which is assumed to be log-normal prior to growth. - if((l_so4_a1 .eq. constituentIndex))then !so4 condensation - fraction= (cam & - *(1.0_r8-f_acm) & !sulfate fraction - *(1.0_r8-f_aqm) & !fraction not from aq phase - *(f_so4_condm) & !fraction being condensate - ) & - / & - (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*f_so4_cond+smallConcentration) !total so4 condensate - - if(doPrint .eqv. .true.)then - print*, " " - print*, "conc ==>", CProcessmodes, cam - print*, "modefrc ==>", f_acm, f_aqm, f_so4_condm - print*, "totfrc ==>", f_c, f_aq, f_so4_cond - print*, "fraction ==>", cam/(CProcessModes+smallConcentration)*100.0, fraction*100 , "%" - endif - - else if(l_so4_ac .eq. constituentIndex)then !so4 coagulation - fraction = (cam & - * (1.0_r8 - f_acm) & !sulfate fraction - * (1.0_r8 - f_aqm) & !fraction not from aq phase - * (1.0_r8 - f_so4_condm) & !fraction not being condensate - ) & - / & - (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*(1.0_r8-f_so4_cond) & !total non-aq sulf - +smallConcentration) - - else if(l_so4_a2 .eq. constituentIndex) then !so4 wet phase - fraction = (cam & - *(1.0_r8-f_acm) & !sulfate fraction - *f_aqm) & !aq phase fraction of sulfate - / & - (CProcessModes*(1.0_r8-f_c)*(f_aq)+smallConcentration) - - else if(l_bc_ac .eq. constituentIndex)then !bc coagulated - fraction = (cam & - *f_acm & ! carbonaceous fraction - *f_bcm) & ! bc fraction of carbonaceous - / & - (CProcessModes*f_c*f_bc+smallConcentration) - - else if(l_om_ac .eq. constituentIndex ) then !oc coagulated - fraction = (cam & - *f_acm & ! carbonaceous fraction - *(1.0_r8-f_bcm) & ! oc fraction of carbonaceous - *(1.0_r8-f_soam))& ! oc fraction which is soa - / & - (CProcessModes*f_c*(1.0_r8-f_bc)*(1.0_r8-f_soa)+smallConcentration) - - else if (l_soa_a1 .eq. constituentIndex) then !SOA condensate - fraction = cam & - *f_acm & !carbonaceous fraction - *(1.0_r8 -f_bcm) & !om fraction - *(f_soam) & !fraction of OM is SOA - / & - (CProcessModes * f_c* (1.0_r8 -f_bc)*f_soa + smallConcentration) - end if - - !if(fraction .gt. 1.2_r8)then - ! if(cam .gt. 1.e-8 *CprocessModes)then - ! print*, "warning, fraction > 1.2 in getConstituentFraction", constituentIndex, fraction - ! print*, " ==> ", CprocessModes, cam ,f_c, f_bc, f_aq,f_so4_cond - ! print*, " ==> ", f_acm, f_bcm, f_aq, f_so4_condm - ! print*, " ==> ", cam/CprocessModes - ! !stop - ! endif - ! fraction = 1.0_r8 - if (fraction .gt. 1.0_r8)then - fraction = 1.0_r8 - endif - - return - end function getConstituentFraction - -!********************************************** - - - subroutine inittabrh - - ! Tables for hygroscopic growth - - integer :: i + !============================================================================= + + function getNumberOfTracersInMode(modeIndex) RESULT(numberOfSpecies) + integer, intent(in) :: modeIndex + integer numberOfSpecies + numberOfSpecies = n_tracers_in_mode(modeIndex) + end function getNumberOfTracersInMode + + function getNumberOfBackgroundTracersInMode(modeIndex) RESULT (numberOfBackgroundSpecies) + integer, intent(in) :: modeIndex + integer numberOfBackgroundSpecies + numberOfBackgroundSpecies = n_background_tracers_in_mode(modeIndex) + end function getNumberOfBackgroundTracersInMode + + function getTracerIndex(modeIndex, componentIndex, isChemistry) RESULT(tracerIndex) + !purpose: Ask for an index in mode + !The index is the index in the q-array + !Some tracers may exist in several modes (is that a problem??) + integer, intent(in) :: modeIndex + integer, intent(in) :: componentIndex + logical, intent(in) :: isChemistry + integer tracerIndex + if(isChemistry)then + !This is tracer index in physics array + tracerIndex = tracer_in_mode(modeIndex,componentIndex)-imozart+1 + else + tracerIndex = tracer_in_mode(modeIndex,componentIndex) + endif + end function getTracerIndex + + !Obtain an index in the physics-buffer for a component in the lifecycle scheme + function getCloudTracerIndex(modeIndex, componentIndex) RESULT(cloud_tracer_index) + integer, intent(in) :: modeIndex + integer, intent(in) :: componentIndex + integer :: tracerIndex + integer cloud_tracer_index + + if(componentIndex == 0)then + !Special key for number concentration of a mode + print*,"error no such species" + stop + else if (componentIndex > 0)then + !Lifecycle specie in a mode + tracerIndex = getTracerIndex(modeIndex,componentIndex,.false.) + cloud_tracer_index = cloudTracerIndex(tracerIndex) !ak: Index in phys-buffer + else + call endrun("negative componentindex in getCloudTracerIndex") + endif + end function getCloudTracerIndex + + !returns index in pbuf for the corresponding cloud tracer with physics index "tracerIndex" + !returns "-1" if the tracer does not have any corresponding cloud tracer + function getCloudTracerIndexDirect(tracerIndex) RESULT(cloudTracerIndexOut) + integer, intent(in) :: tracerIndex + integer :: cloudTracerIndexOut + cloudTracerIndexOut = cloudTracerIndex(tracerIndex) + end function getCloudTracerIndexDirect + + function getDryDensity(m,l) RESULT(density) + integer, intent(in) :: m !mode index + integer, intent(in) :: l !tracer index + real(r8) :: density + density = rhopart(tracer_in_mode(m,l)) + end function getDryDensity + + function getCloudTracerName(tracerIndex) RESULT(cloudTracerNameOut) + integer, intent(in) :: tracerIndex + character(len=20) :: cloudTracerNameOut + cloudTracerNameOut = trim(cloudTracerName(tracerIndex)) + end function getCloudTracerName + + subroutine fillAerosolTracerList(aerosolTracerList) + integer, dimension (:), intent(out) :: aerosolTracerList + logical, dimension(pcnst) :: alreadyFound + integer :: m,l,mm,nTracer + alreadyFound(:) = .FALSE. + nTracer = 0 + do m=1,nmodes + do l=1,n_tracers_in_mode(m) + mm=getTracerIndex(m,l,.FALSE.) + if(.NOT.alreadyFound(mm))then + nTracer = nTracer + 1 + alreadyFound(mm) = .TRUE. + aerosolTracerList(nTracer) = mm + end if + end do + end do + end subroutine fillAerosolTracerList + subroutine fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) + integer, dimension(:), intent(in) :: aerosolTracerList + integer, intent(in) :: n_aerosol_tracers + integer, dimension(pcnst), intent(out) :: inverseAerosolTracerList + integer :: i + + inverseAerosolTracerList(:) = -99 + do i=1,n_aerosol_tracers + inverseAerosolTracerList(aerosolTracerList(i)) = i + end do + end subroutine fillInverseAerosolTracerList + + subroutine registerTracersInMode() + !Register tracer index in modes + tracer_in_mode(:,:) = -1 !undefined + + !externally mixed bc + tracer_in_mode(MODE_IDX_BC_EXT_AC, 1:n_tracers_in_mode(MODE_IDX_BC_EXT_AC)) = (/l_bc_ax/) + + !sulphate + soa, sulfate condensate. + tracer_in_mode(MODE_IDX_SO4SOA_AIT, 1:n_tracers_in_mode(MODE_IDX_SO4SOA_AIT) ) = & + (/l_so4_na, l_soa_na, l_so4_a1, l_soa_a1/) + + !bc + sulfate condensate + tracer_in_mode(MODE_IDX_BC_AIT,1:n_tracers_in_mode(MODE_IDX_BC_AIT)) = & + (/l_bc_a, l_so4_a1, l_soa_a1/) + + !index not used + !tracer_in_mode(MODE_IDX_NOT_USED, 1:n_tracers_in_mode(MODE_IDX_NOT_USED)) = (/-1/) + + !om / bc internally mixed with sulfate condensate and aquous phase sulfate + tracer_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT))= & + (/l_bc_ai, l_om_ai, l_so4_a1, l_so4_a2, l_soa_a1 /) + + !accumulation mode sulfate with coagulate, condensate and aquous phase sulfate + tracer_in_mode(MODE_IDX_SO4_AC, 1:n_tracers_in_mode(MODE_IDX_SO4_AC)) = & + (/l_so4_pr, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + + !ac-mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_DST_A2, 1:n_tracers_in_mode(MODE_IDX_DST_A2)) = & +(/l_dst_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + + !coarse mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_DST_A3, 1:n_tracers_in_mode(MODE_IDX_DST_A3)) = & + (/l_dst_a3, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + + !at-mode ss with sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_SS_A1, 1:n_tracers_in_mode(MODE_IDX_SS_A1)) = & + (/l_ss_a1, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + + !ac mode ss with sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_SS_A2, 1:n_tracers_in_mode(MODE_IDX_SS_A2)) = & + (/l_ss_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + + !coarse mode ss sulfate coagulate, condensate sulfate and wet-phase sulfate + tracer_in_mode(MODE_IDX_SS_A3, 1:n_tracers_in_mode(MODE_IDX_SS_A3)) = & + (/l_ss_a3, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + + !sulfate + soa nucleation mode (mode no longer used) + !tracer_in_mode(MODE_IDX_SO4SOA_NUC, 1:n_tracers_in_mode(MODE_IDX_SO4SOA_NUC)) = (/ -1 /) + + !bc in nucleation mode + tracer_in_mode(MODE_IDX_BC_NUC, 1:n_tracers_in_mode(MODE_IDX_BC_NUC)) = (/l_bc_n/) + + !lumped organics + !tracer_in_mode(MODE_IDX_LUMPED_ORGANICS, 1:n_tracers_in_mode(MODE_IDX_LUMPED_ORGANICS)) = (/-1/) + + !intermal mixture bc/oc coated + tracer_in_mode(MODE_IDX_OMBC_INTMIX_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_AIT)) = (/l_bc_ni, l_om_ni/) + end subroutine registerTracersInMode + + function isTracerInMode(modeIndex, constituentIndex)RESULT(answer) + integer, intent(in) :: modeIndex + integer, intent(in) :: constituentIndex + integer :: i + logical :: answer + answer = .FALSE. + do i=1,n_tracers_in_mode(modeIndex) + if(tracer_in_mode(modeIndex,i) == constituentIndex)then + answer = .TRUE. + endif + enddo + return + end function isTracerInMode + + function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond,f_soa & + ,Cam, f_acm, f_bcm, f_aqm, f_so4_condm,f_soam, constituentIndex,debugPrint ) RESULT(fraction) ! mass fraction + real(r8), intent(in) :: CProcessModes + real(r8), intent(in) :: f_c + real(r8), intent(in) :: f_bc + real(r8), intent(in) :: f_aq + real(r8), intent(in) :: f_so4_cond + real(r8), intent(in) :: f_soa + real(r8), intent(in) :: cam + real(r8), intent(in) :: f_aqm + real(r8), intent(in) :: f_bcm + real(r8), intent(in) :: f_acm + real(r8), intent(in) :: f_so4_condm + real(r8), intent(in) :: f_soam + integer, intent(in) :: constituentIndex + logical, optional, intent(in) :: debugPrint + logical :: doPrint = .false. + real(r8) :: fraction + + if(present(debugPrint))then + if(debugPrint .eqv. .true.)then + doPrint=.true. + endif + endif + + fraction = 1.0_r8 ! fraction = 1 for all tracers, except special cases (process modes) below + + !This fraction is the mass of a certain tracer in a specific size-mode divided by the total + !mass of the same tracer for (i.e. summed up over) all size-modes. This total mass is what + !is transported in the model, in the life cycle scheme. The word size-mode is here used for a mode in the + !aerosol size-distribution, which is assumed to be log-normal prior to growth. + if((l_so4_a1 .eq. constituentIndex))then !so4 condensation + fraction= (cam & + *(1.0_r8-f_acm) & !sulfate fraction + *(1.0_r8-f_aqm) & !fraction not from aq phase + *(f_so4_condm) & !fraction being condensate + ) & + / & + (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*f_so4_cond+smallConcentration) !total so4 condensate + + if(doPrint .eqv. .true.)then + print*, " " + print*, "conc ==>", CProcessmodes, cam + print*, "modefrc ==>", f_acm, f_aqm, f_so4_condm + print*, "totfrc ==>", f_c, f_aq, f_so4_cond + print*, "fraction ==>", cam/(CProcessModes+smallConcentration)*100.0, fraction*100 , "%" + endif + + else if(l_so4_ac .eq. constituentIndex)then !so4 coagulation + fraction = (cam & + * (1.0_r8 - f_acm) & !sulfate fraction + * (1.0_r8 - f_aqm) & !fraction not from aq phase + * (1.0_r8 - f_so4_condm) & !fraction not being condensate + ) & + / & + (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*(1.0_r8-f_so4_cond) & !total non-aq sulf + +smallConcentration) + + else if(l_so4_a2 .eq. constituentIndex) then !so4 wet phase + fraction = (cam & + *(1.0_r8-f_acm) & !sulfate fraction + *f_aqm) & !aq phase fraction of sulfate + / & + (CProcessModes*(1.0_r8-f_c)*(f_aq)+smallConcentration) + + else if(l_bc_ac .eq. constituentIndex)then !bc coagulated + fraction = (cam & + *f_acm & ! carbonaceous fraction + *f_bcm) & ! bc fraction of carbonaceous + / & + (CProcessModes*f_c*f_bc+smallConcentration) + + else if(l_om_ac .eq. constituentIndex ) then !oc coagulated + fraction = (cam & + *f_acm & ! carbonaceous fraction + *(1.0_r8-f_bcm) & ! oc fraction of carbonaceous + *(1.0_r8-f_soam))& ! oc fraction which is soa + / & + (CProcessModes*f_c*(1.0_r8-f_bc)*(1.0_r8-f_soa)+smallConcentration) + + else if (l_soa_a1 .eq. constituentIndex) then !SOA condensate + fraction = cam & + *f_acm & !carbonaceous fraction + *(1.0_r8 -f_bcm) & !om fraction + *(f_soam) & !fraction of OM is SOA + / & + (CProcessModes * f_c* (1.0_r8 -f_bc)*f_soa + smallConcentration) + end if + + if (fraction .gt. 1.0_r8)then + fraction = 1.0_r8 + endif + end function getConstituentFraction + + !********************************************** + subroutine inittabrh() + + ! Tables for hygroscopic growth + integer :: i real(r8) :: rr0ss(10),rr0so4(10),rr0bcoc(10) data rr0ss / 1.00_r8, 1.00_r8, 1.02_r8, 1.57_r8, 1.88_r8, 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 3.62_r8 / @@ -682,12 +642,10 @@ subroutine inittabrh rdivr0(i,l_bc_a)=rr0bcoc(i) -! rdivr0(i,l_bc_n)=rr0bcoc(i) rdivr0(i,l_bc_ni)=rr0bcoc(i) rdivr0(i,l_bc_ai)=rr0bcoc(i) rdivr0(i,l_bc_ac)=rr0bcoc(i) -! rdivr0(i,l_om_n)=rr0bcoc(i) rdivr0(i,l_om_ni)=rr0bcoc(i) rdivr0(i,l_om_ai)=rr0bcoc(i) rdivr0(i,l_om_ac)=rr0bcoc(i) @@ -696,14 +654,34 @@ subroutine inittabrh rdivr0(i,l_ss_a2)=rr0ss(i) rdivr0(i,l_ss_a3)=rr0ss(i) -!cka: Add hygroscopic properties for soa. Assume identical to bcoc properties. rdivr0(i,l_soa_na)=rr0bcoc(i) -! rdivr0(i,l_soa_a1)=rr0bcoc(i) - end do - return end subroutine inittabrh + subroutine qqcw_set_ptr(index, iptr) + integer, intent(in) :: index, iptr + if(index>0 .and. index <= pcnst ) then + qqcw(index)=iptr + else + call endrun('qqcw_set_ptr: attempting to set qqcw pointer already defined') + end if + end subroutine qqcw_set_ptr + + function qqcw_get_field(pbuf, index) + use physics_buffer, only : physics_buffer_desc, pbuf_get_field + + type(physics_buffer_desc), pointer :: pbuf(:) + integer, intent(in) :: index + real(r8), pointer :: qqcw_get_field(:,:) + + nullify(qqcw_get_field) + if (index>0 .and. index <= pcnst) then + if (qqcw(index)>0) then + call pbuf_get_field(pbuf, qqcw(index), qqcw_get_field) + endif + end if + end function qqcw_get_field + end module aerosoldef diff --git a/src/chemistry/oslo_aero/condtend.F90 b/src/chemistry/oslo_aero/condtend.F90 index c430fb5e03..3cd405e03e 100644 --- a/src/chemistry/oslo_aero/condtend.F90 +++ b/src/chemistry/oslo_aero/condtend.F90 @@ -251,7 +251,7 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & ! Added input for h2so4 and soa nucleation: soa_lv_gasprod, soa_sv_gasprod, pblh,zm,qh20 (cka) use cam_history, only: outfld,fieldname_len - use koagsub, only: normalizedCoagulationSink,receiverMode,numberOfCoagulationReceivers + use koagsub, only: normalizedCoagulationSink, receiverMode,numberOfCoagulationReceivers use koagsub, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd use constituents, only: pcnst ! h2so4 and soa nucleation (cka) diff --git a/src/chemistry/oslo_aero/koagsub.F90 b/src/chemistry/oslo_aero/koagsub.F90 index a183a4647e..eaedc5ab6d 100644 --- a/src/chemistry/oslo_aero/koagsub.F90 +++ b/src/chemistry/oslo_aero/koagsub.F90 @@ -1,821 +1,768 @@ module koagsub - use phys_control, only: phys_getopts - use aerosoldef - use chem_mods, only: gas_pcnst - use mo_tracname, only: solsym - use const - use shr_kind_mod, only: r8 => shr_kind_r8 - use physconst, only: rair, gravit - use cam_logfile, only : iulog - save - - real(r8), parameter :: kboltzmann = 1.3806488e-23_r8 ![m2 kg s-2 K-1] - real(r8), parameter :: temperatureLookupTables = 293.15_r8 !Temperature used in look up tables - real(r8), parameter :: mfpAir = 63.3e-9_r8 ![m] mean free path air - real(r8), parameter :: viscosityAir = 1.983e-5_r8 ![Pa s] viscosity of air - - real(r8), parameter :: rhoh2o = 1000._r8 ! Density of water - - integer, parameter :: numberOfCoagulatingModes = 6 - integer, parameter :: numberOfCoagulationReceivers = 6 - - real(r8), dimension(0:nmodes,0:nmodes) :: normalizedCoagulationSink ![m3/#/s] - real(r8), dimension(0:nmodes) :: NCloudCoagulationSink ![m3/#/s] - -!nuctst3+ - real(r8) normCoagSinkMode1 ![m3/#/s] -!nuctst3- -!aktest+ - integer, parameter :: numberOfAddCoagReceivers = 6 - real(r8), dimension(numberOfAddCoagReceivers) :: normCoagSinkAdd ![m3/#/s] -!aktest- - - !These are the modes which are coagulating (belonging to mixtures no. 0, 1, 2, 4, 12, 14) - integer, dimension(numberOfCoagulatingModes) :: coagulatingMode = & - (/MODE_IDX_BC_EXT_AC & !inert mode - , MODE_IDX_SO4SOA_AIT, MODE_IDX_BC_AIT, MODE_IDX_OMBC_INTMIX_COAT_AIT & !internally mixed small modes - , MODE_IDX_BC_NUC, MODE_IDX_OMBC_INTMIX_AIT /) !externally mixed small modes - - !These are the modes which are receiving coagulating material in OsloAero - ! (belonging to mixtures no. 5, 6, 7, 8, 9, 10) - integer, dimension(numberOfCoagulationReceivers) :: receiverMode = & + use phys_control, only: phys_getopts + use aerosoldef + use chem_mods, only: gas_pcnst + use mo_tracname, only: solsym + use const + use shr_kind_mod, only: r8 => shr_kind_r8 + use physconst, only: rair, gravit + use cam_logfile, only : iulog + + implicit none + private + + real(r8), parameter :: kboltzmann = 1.3806488e-23_r8 ![m2 kg s-2 K-1] + real(r8), parameter :: temperatureLookupTables = 293.15_r8 !Temperature used in look up tables + real(r8), parameter :: mfpAir = 63.3e-9_r8 ![m] mean free path air + real(r8), parameter :: viscosityAir = 1.983e-5_r8 ![Pa s] viscosity of air + + real(r8), parameter :: rhoh2o = 1000._r8 ! Density of water + + integer, parameter :: numberOfCoagulatingModes = 6 + integer, parameter, public :: numberOfCoagulationReceivers = 6 + + real(r8), public :: normalizedCoagulationSink(0:nmodes,0:nmodes) ![m3/#/s] + real(r8), public :: NCloudCoagulationSink(0:nmodes) ![m3/#/s] + + integer, parameter, public :: numberOfAddCoagReceivers = 6 + real(r8), public :: normCoagSinkAdd(numberOfAddCoagReceivers) ![m3/#/s] + + !These are the modes which are coagulating (belonging to mixtures no. 0, 1, 2, 4, 12, 14) + integer, public :: coagulatingMode(numberOfCoagulatingModes) = & + (/MODE_IDX_BC_EXT_AC & !inert mode + , MODE_IDX_SO4SOA_AIT, MODE_IDX_BC_AIT, MODE_IDX_OMBC_INTMIX_COAT_AIT & !internally mixed small modes + , MODE_IDX_BC_NUC, MODE_IDX_OMBC_INTMIX_AIT /) !externally mixed small modes + + !These are the modes which are receiving coagulating material in OsloAero + ! (belonging to mixtures no. 5, 6, 7, 8, 9, 10) + integer, public :: receiverMode(numberOfCoagulationReceivers) = & (/MODE_IDX_SO4_AC,MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 /) -!aktest+ - !And these are the additional modes which are allowed to contribute to the - ! coagulation sink, defined here and to be used only in the nucleation code in condtend.F90 - ! (belonging to mixtures no. 0, 1, 2, 4, 12, 14) - integer, dimension(numberOfAddCoagReceivers) :: addReceiverMode = & + !And these are the additional modes which are allowed to contribute to the + ! coagulation sink, defined here and to be used only in the nucleation code in condtend.F90 + ! (belonging to mixtures no. 0, 1, 2, 4, 12, 14) + integer, public :: addReceiverMode(numberOfAddCoagReceivers) = & (/MODE_IDX_BC_EXT_AC,MODE_IDX_SO4SOA_AIT,MODE_IDX_BC_AIT, & - MODE_IDX_OMBC_INTMIX_COAT_AIT,MODE_IDX_BC_NUC,MODE_IDX_OMBC_INTMIX_AIT /) -!aktest- + MODE_IDX_OMBC_INTMIX_COAT_AIT,MODE_IDX_BC_NUC,MODE_IDX_OMBC_INTMIX_AIT /) - !Coagulation moves aerosol mass to the "coagulate" species, so some - !lifecycle species will receive mass in this routine! - integer, dimension(gas_pcnst) :: lifeCycleReceiver + !Coagulation moves aerosol mass to the "coagulate" species, so some + !lifecycle species will receive mass in this routine! + integer :: lifeCycleReceiver(gas_pcnst) - ! Coagulation between aerosol and cloud droplets move coagulate into - ! the equivalent value for aerosol concentration in cloud water. - ! Exception: Sulphate coagulation with cloud droplets is merged with - ! component from aqueous phase chemistry in order to take advantage of the - ! more detailed addition onto larger particles. + ! Coagulation between aerosol and cloud droplets move coagulate into + ! the equivalent value for aerosol concentration in cloud water. + ! Exception: Sulphate coagulation with cloud droplets is merged with + ! component from aqueous phase chemistry in order to take advantage of the + ! more detailed addition onto larger particles. - integer, dimension(gas_pcnst) :: CloudAerReceiver + integer :: CloudAerReceiver(gas_pcnst) -! Closest Table index for assumed size of droplets used in coagulation - integer :: tableindexcloud - real(r8),parameter :: rcoagdroplet = 10.e-6 ! m + ! Closest Table index for assumed size of droplets used in coagulation + integer :: tableindexcloud + real(r8),parameter :: rcoagdroplet = 10.e-6 ! m + public :: initializeCoagulationOutput + public :: initializeCoagulationReceivers + public :: initializeCoagulationCoefficients + public :: coagtend + public :: clcoag +!================================================================ contains - -subroutine initializeCoagulationOutput() - - use ppgrid, only: pver - use cam_history, only: addfld, add_default, fieldname_len, horiz_only - implicit none - integer :: imode - integer :: iChem - integer :: modeIndexCoagulator - - character(len=fieldname_len+3) :: fieldname_receiver - character(len=fieldname_len+3) :: fieldname_donor - character(8) :: unit - logical :: history_aerosol - logical, dimension(gas_pcnst) :: isAlreadyOnList - - call phys_getopts(history_aerosol_out = history_aerosol) - - isAlreadyOnList(:) = .FALSE. - do iChem = 1,gas_pcnst - !Does this tracer have a receiver? If yes: It contributes to coagulation - if(lifeCycleReceiver(iChem) .gt. 0)then - unit = "kg/m2/s" - fieldname_donor = trim(solsym(iChem))//"coagTend" - fieldname_receiver = trim(solsym(lifeCycleReceiver(iChem)))//"coagTend" - if(.not. isAlreadyOnList(lifeCycleReceiver(iChem)))then - call addfld( fieldname_receiver, horiz_only ,"A", unit, "coagulation tendency") - isAlreadyOnList(lifeCycleReceiver(iChem))=.TRUE. - end if - call addfld( fieldname_donor, horiz_only, 'A', unit, "coagulation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - call add_default( fieldname_donor , 1, ' ') - end if - end if - end do - - isAlreadyOnList(:) = .FALSE. - do iChem = 1,gas_pcnst - if(CloudAerReceiver(iChem) .gt. 0)then - unit = "kg/m2/s" - fieldname_donor = trim(solsym(iChem))//"clcoagTend" - fieldname_receiver = trim(solsym(CloudAerReceiver(iChem)))//"_OCWclcoagTend" - if(.not. isAlreadyOnList(CloudAerReceiver(iChem)))then - call addfld( fieldname_receiver, horiz_only, 'A', unit, "coagulation tendency" ) - isAlreadyOnList(CloudAerReceiver(iChem))=.TRUE. - end if - call addfld( fieldname_donor, horiz_only, "A", unit, "coagulation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - call add_default( fieldname_donor , 1, ' ') - end if - end if - - end do - -end subroutine initializeCoagulationOutput - -subroutine initializeCoagulationReceivers() - implicit none - - !These are the lifecycle-species receiving coagulate - lifeCycleReceiver(:) = -99 - lifeCycleReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ac) - lifeCycleReceiver(chemistryIndex(l_so4_na)) = chemistryIndex(l_so4_ac) !create so4 coagulate from so4 in mode 1 - lifeCycleReceiver(chemistryIndex(l_bc_a)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 2 - lifeCycleReceiver(chemistryIndex(l_bc_ai)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 4 - lifeCycleReceiver(chemistryIndex(l_om_ai)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 4 - lifeCycleReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 12 - lifeCycleReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ac) !create bc coagulate from om in mode 14 - lifeCycleReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 14 - lifeCycleReceiver(chemistryIndex(l_so4_a1)) = chemistryIndex(l_so4_ac) !Create so4 coagulate from so4 condensate - lifeCycleReceiver(chemistryINdex(l_soa_na)) = chemistryIndex(l_soa_a1) - - !These are the lifecycle-species receiving coagulate - CloudAerReceiver(:) = -99 - CloudAerReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ac) - CloudAerReceiver(chemistryIndex(l_so4_na)) = chemistryIndex(l_so4_a2) !create so4 coagulate from so4 in mode 1 - CloudAerReceiver(chemistryIndex(l_bc_a)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 2 - CloudAerReceiver(chemistryIndex(l_bc_ai)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 4 - CloudAerReceiver(chemistryIndex(l_om_ai)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 4 - CloudAerReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 12 - CloudAerReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ac) !create bc coagulate from om in mode 14 - CloudAerReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 14 - CloudAerReceiver(chemistryIndex(l_so4_a1)) = chemistryIndex(l_so4_a2) !Create so4 coagulate from so4 condensate - cloudAerReceiver(chemistryIndex(l_soa_na)) = chemistryIndex(l_soa_a1) - - -end subroutine initializeCoagulationReceivers - -subroutine initializeCoagulationCoefficients(rhob,rk) - - use mo_constants, only: pi - use const, only: normnk - - implicit none - - real(r8), intent(in) :: rk(0:nmodes) ![unit] radius of background (receiver) mode - real(r8), intent(in) :: rhob(0:nmodes) !density of background mode - - real(r8), dimension(numberOfCoagulationReceivers, numberOfCoagulatingModes, nBinsTab) :: K12 = 0.0_r8 !Coagulation coefficient (m3/s) - -!nuctst3+ -! real(r8), dimension(nBinsTab) :: CoagCoeffMode1 = 0.0_r8 !Coagulation coefficient mode 1 with 1 (m3/s) -!nuctst3- -!ak+ - real(r8), dimension(numberOfAddCoagReceivers,nBinsTab) :: CoagCoeffModeAdd = 0.0_r8 !Coagulation coefficient mode 1 (m3/s) -!ak- - - real(r8), dimension(numberOfCoagulatingModes,nBinsTab) :: K12Cl = 0.0_r8 !Coagulation coefficient (m3/s) - - real(r8), dimension(nBinsTab) :: coagulationCoefficient - integer :: aMode - integer :: modeIndex - integer :: modeIndexCoagulator !Index of coagulating mode - integer :: modeIndexReceiver !Index of receiving mode - integer :: iCoagulatingMode !Counter for coagulating mode - integer :: iReceiverMode !Counter for receiver modes - integer :: nsiz !counter for look up table sizes - - do iReceiverMode = 1, numberOfCoagulationReceivers - do iCoagulatingMode = 1,numberOfCoagulatingModes - - !Index of the coagulating mode (0-14), see list above - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) - - !Index of receiver mode (0-14), see list above - modeIndexReceiver = receiverMode(iReceiverMode) - - !Pre-calculate coagulation coefficients for this coagulator.. - !Note: Not using actual density of coagulator here - !Since this is not known at init-time - call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient - , rk(modeIndexCoagulator) & !I [m] radius of coagulator - , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator - , rhob(modeIndexReceiver) ) !I [kg/m3] density of receiver - - !Save values - K12(iReceiverMode,iCoagulatingMode,:) = CoagulationCoefficient(:) - - enddo - end do !receiver modes - -!nuctst3+ -! call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient -! , rk(1) & !I [m] radius of coagulator -! , rhob(1) & !I [kg/m3] density of coagulator -! , rhob(1) ) !I [kg/m3] density of receiver -! CoagCoeffMode1(:) = CoagulationCoefficient(:) -!nuctst3- -!ak+ - do iReceiverMode = 1, numberOfAddCoagReceivers - iCoagulatingMode = 1 - - !Index of the coagulating mode (0-14), see list above - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) - - !Index of receiver mode (0-14), see list above - modeIndexReceiver = addReceiverMode(iReceiverMode) - - !Pre-calculate coagulation coefficients for this coagulator.. - !Note: Not using actual density of coagulator here - !Since this is not known at init-time - call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient - , rk(modeIndexCoagulator) & !I [m] radius of coagulator - , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator - , rhob(modeIndexReceiver) ) !I [kg/m3] density of receiver - - !Save values - CoagCoeffModeAdd(iReceiverMode,:) = CoagulationCoefficient(:) - - end do !receiver modes -!ak- - -! Onl one receivermode for cloud coagulation (water) - do iCoagulatingMode = 1,numberOfCoagulatingModes - - !Index of the coagulating mode (0-14), see list above - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) - - !Pre-calculate coagulation coefficients for this coagulator.. - !Note: Not using actual density of coagulator here - !Since this is not known at init-time - call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient - , rk(modeIndexCoagulator) & !I [m] radius of coagulator - , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator - , rhoh2o ) !I [kg/m3] density of receiver - - !Save values - K12Cl(iCoagulatingMode,:) = CoagulationCoefficient(:) - - enddo - - - - !We don't need to remember K12 for all lookuptable sizes!! - !We only need to rember for 1 [#/m3] of each receiver mode - !and then later scale by number concentration in receiver modes - normalizedCoagulationSink(:,:) = 0.0_r8 - - do iCoagulatingMode = 1, numberOfCoagulatingModes - - !Sum the loss for all possible receivers - do iReceiverMode = 1, numberOfCoagulationReceivers - - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of the coagulating mode - - modeIndexReceiver = receiverMode(iReceiverMode) !Index of receiver mode - - do nsiz=1,nBinsTab !aerotab bin sizes - - !Sum up coagulation sink for this coagulating species (for all receiving modes) - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) = & ![m3/#/s] - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] Previous value - + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode - * K12(iReceiverMode, iCoagulatingMode, nsiz) !Koagulation coefficient (m3/#/s) - end do !Look up table size - end do !receiver modes - end do !coagulator - - -!nuctst3+ -! !Add simple self coagulation sink for mode 1 (with 1) in such a way that it -! !affects coagulationSink but not the lifecycling (directly) otherwise -! normCoagSinkMode1 = 0.0_r8 -! do nsiz=1,nBinsTab !aerotab bin sizes -! normCoagSinkMode1 = normCoagSinkMode1 + normnk(1,nsiz) * CoagCoeffMode1(nsiz) -! end do !Look up table size -!nuctst3- -!ak+ - !Calculate additional coagulation sink for mode 1 in such a way that it - !affects coagulationSink but not the lifecycling (directly) otherwise - - !Sum the loss for all possible receivers - normCoagSinkAdd(:) = 0.0_r8 - iCoagulatingMode = 1 - do iReceiverMode = 1, numberOfAddCoagReceivers - - modeIndexReceiver = addReceiverMode(iReceiverMode) !Index of additional receiver mode - - do nsiz=1,nBinsTab !aerotab bin sizes - - !Sum up coagulation sink for this coagulating species (for all receiving modes) - normCoagSinkAdd(iReceiverMode) = & ![m3/#/s] - normCoagSinkAdd(iReceiverMode) & ![m3/#/s] Previous value - + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode - * CoagCoeffModeAdd(iReceiverMode, nsiz) !Koagulation coefficient (m3/#/s) - end do !Look up table size - end do !receiver modes -!ak- - - nsiz=1 - do while (rBinMidPoint(nsiz).lt.rcoagdroplet.and.nsiz.lt.nBinsTab) - nsiz=nsiz+1 - end do - - if (abs(rBinMidPoint(nsiz-1)-rcoagdroplet).lt.abs(rBinMidPoint(nsiz)-rcoagdroplet)) then - tableindexcloud=nsiz-1 - else - tableindexcloud=nsiz - end if - write(iulog,*) 'Assumed droplet size and table bin number for cloud & +!================================================================ + + subroutine initializeCoagulationOutput() + use cam_history, only: addfld, add_default, fieldname_len, horiz_only + + integer :: iChem + character(len=fieldname_len+3) :: fieldname_receiver + character(len=fieldname_len+3) :: fieldname_donor + character(8) :: unit + logical :: history_aerosol + logical :: isAlreadyOnList(gas_pcnst) + + call phys_getopts(history_aerosol_out = history_aerosol) + + isAlreadyOnList(:) = .FALSE. + do iChem = 1,gas_pcnst + !Does this tracer have a receiver? If yes: It contributes to coagulation + if(lifeCycleReceiver(iChem) .gt. 0)then + unit = "kg/m2/s" + fieldname_donor = trim(solsym(iChem))//"coagTend" + fieldname_receiver = trim(solsym(lifeCycleReceiver(iChem)))//"coagTend" + if(.not. isAlreadyOnList(lifeCycleReceiver(iChem)))then + call addfld( fieldname_receiver, horiz_only ,"A", unit, "coagulation tendency") + isAlreadyOnList(lifeCycleReceiver(iChem))=.TRUE. + end if + call addfld( fieldname_donor, horiz_only, 'A', unit, "coagulation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + call add_default( fieldname_donor , 1, ' ') + end if + end if + end do + + isAlreadyOnList(:) = .FALSE. + do iChem = 1,gas_pcnst + if(CloudAerReceiver(iChem) .gt. 0)then + unit = "kg/m2/s" + fieldname_donor = trim(solsym(iChem))//"clcoagTend" + fieldname_receiver = trim(solsym(CloudAerReceiver(iChem)))//"_OCWclcoagTend" + if(.not. isAlreadyOnList(CloudAerReceiver(iChem)))then + call addfld( fieldname_receiver, horiz_only, 'A', unit, "coagulation tendency" ) + isAlreadyOnList(CloudAerReceiver(iChem))=.TRUE. + end if + call addfld( fieldname_donor, horiz_only, "A", unit, "coagulation tendency" ) + if(history_aerosol)then + call add_default( fieldname_receiver, 1, ' ' ) + call add_default( fieldname_donor , 1, ' ') + end if + end if + end do + end subroutine initializeCoagulationOutput + + !================================================================ + subroutine initializeCoagulationReceivers() + + !These are the lifecycle-species receiving coagulate + lifeCycleReceiver(:) = -99 + lifeCycleReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ac) + lifeCycleReceiver(chemistryIndex(l_so4_na)) = chemistryIndex(l_so4_ac) !create so4 coagulate from so4 in mode 1 + lifeCycleReceiver(chemistryIndex(l_bc_a)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 2 + lifeCycleReceiver(chemistryIndex(l_bc_ai)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 4 + lifeCycleReceiver(chemistryIndex(l_om_ai)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 4 + lifeCycleReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 12 + lifeCycleReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ac) !create bc coagulate from om in mode 14 + lifeCycleReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 14 + lifeCycleReceiver(chemistryIndex(l_so4_a1)) = chemistryIndex(l_so4_ac) !Create so4 coagulate from so4 condensate + lifeCycleReceiver(chemistryINdex(l_soa_na)) = chemistryIndex(l_soa_a1) + + !These are the lifecycle-species receiving coagulate + CloudAerReceiver(:) = -99 + CloudAerReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ac) + CloudAerReceiver(chemistryIndex(l_so4_na)) = chemistryIndex(l_so4_a2) !create so4 coagulate from so4 in mode 1 + CloudAerReceiver(chemistryIndex(l_bc_a)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 2 + CloudAerReceiver(chemistryIndex(l_bc_ai)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 4 + CloudAerReceiver(chemistryIndex(l_om_ai)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 4 + CloudAerReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 12 + CloudAerReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ac) !create bc coagulate from om in mode 14 + CloudAerReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 14 + CloudAerReceiver(chemistryIndex(l_so4_a1)) = chemistryIndex(l_so4_a2) !Create so4 coagulate from so4 condensate + cloudAerReceiver(chemistryIndex(l_soa_na)) = chemistryIndex(l_soa_a1) + end subroutine initializeCoagulationReceivers + + !================================================================ + subroutine initializeCoagulationCoefficients(rhob,rk) + + use mo_constants, only: pi + use const, only: normnk + + real(r8), intent(in) :: rk(0:nmodes) ![unit] radius of background (receiver) mode + real(r8), intent(in) :: rhob(0:nmodes) !density of background mode + + real(r8), dimension(numberOfCoagulationReceivers, numberOfCoagulatingModes, nBinsTab) :: K12 = 0.0_r8 !Coagulation coefficient (m3/s) + + !nuctst3+ + ! real(r8), dimension(nBinsTab) :: CoagCoeffMode1 = 0.0_r8 !Coagulation coefficient mode 1 with 1 (m3/s) + !nuctst3- + !ak+ + real(r8), dimension(numberOfAddCoagReceivers,nBinsTab) :: CoagCoeffModeAdd = 0.0_r8 !Coagulation coefficient mode 1 (m3/s) + !ak- + + real(r8), dimension(numberOfCoagulatingModes,nBinsTab) :: K12Cl = 0.0_r8 !Coagulation coefficient (m3/s) + + real(r8), dimension(nBinsTab) :: coagulationCoefficient + integer :: aMode + integer :: modeIndex + integer :: modeIndexCoagulator !Index of coagulating mode + integer :: modeIndexReceiver !Index of receiving mode + integer :: iCoagulatingMode !Counter for coagulating mode + integer :: iReceiverMode !Counter for receiver modes + integer :: nsiz !counter for look up table sizes + + do iReceiverMode = 1, numberOfCoagulationReceivers + do iCoagulatingMode = 1,numberOfCoagulatingModes + + !Index of the coagulating mode (0-14), see list above + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) + + !Index of receiver mode (0-14), see list above + modeIndexReceiver = receiverMode(iReceiverMode) + + !Pre-calculate coagulation coefficients for this coagulator.. + !Note: Not using actual density of coagulator here + !Since this is not known at init-time + call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient + , rk(modeIndexCoagulator) & !I [m] radius of coagulator + , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator + , rhob(modeIndexReceiver) ) !I [kg/m3] density of receiver + + !Save values + K12(iReceiverMode,iCoagulatingMode,:) = CoagulationCoefficient(:) + + enddo + end do !receiver modes + + !nuctst3+ + ! call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient + ! , rk(1) & !I [m] radius of coagulator + ! , rhob(1) & !I [kg/m3] density of coagulator + ! , rhob(1) ) !I [kg/m3] density of receiver + ! CoagCoeffMode1(:) = CoagulationCoefficient(:) + !nuctst3- + !ak+ + do iReceiverMode = 1, numberOfAddCoagReceivers + iCoagulatingMode = 1 + + !Index of the coagulating mode (0-14), see list above + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) + + !Index of receiver mode (0-14), see list above + modeIndexReceiver = addReceiverMode(iReceiverMode) + + !Pre-calculate coagulation coefficients for this coagulator.. + !Note: Not using actual density of coagulator here + !Since this is not known at init-time + call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient + , rk(modeIndexCoagulator) & !I [m] radius of coagulator + , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator + , rhob(modeIndexReceiver) ) !I [kg/m3] density of receiver + + !Save values + CoagCoeffModeAdd(iReceiverMode,:) = CoagulationCoefficient(:) + + end do !receiver modes + !ak- + + ! Onl one receivermode for cloud coagulation (water) + do iCoagulatingMode = 1,numberOfCoagulatingModes + + !Index of the coagulating mode (0-14), see list above + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) + + !Pre-calculate coagulation coefficients for this coagulator.. + !Note: Not using actual density of coagulator here + !Since this is not known at init-time + call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient + , rk(modeIndexCoagulator) & !I [m] radius of coagulator + , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator + , rhoh2o ) !I [kg/m3] density of receiver + + !Save values + K12Cl(iCoagulatingMode,:) = CoagulationCoefficient(:) + + enddo + + + + !We don't need to remember K12 for all lookuptable sizes!! + !We only need to rember for 1 [#/m3] of each receiver mode + !and then later scale by number concentration in receiver modes + normalizedCoagulationSink(:,:) = 0.0_r8 + + do iCoagulatingMode = 1, numberOfCoagulatingModes + + !Sum the loss for all possible receivers + do iReceiverMode = 1, numberOfCoagulationReceivers + + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of the coagulating mode + + modeIndexReceiver = receiverMode(iReceiverMode) !Index of receiver mode + + do nsiz=1,nBinsTab !aerotab bin sizes + + !Sum up coagulation sink for this coagulating species (for all receiving modes) + normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) = & ![m3/#/s] + normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] Previous value + + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode + * K12(iReceiverMode, iCoagulatingMode, nsiz) !Koagulation coefficient (m3/#/s) + end do !Look up table size + end do !receiver modes + end do !coagulator + + + !Calculate additional coagulation sink for mode 1 in such a way that it + !affects coagulationSink but not the lifecycling (directly) otherwise + + !Sum the loss for all possible receivers + normCoagSinkAdd(:) = 0.0_r8 + iCoagulatingMode = 1 + do iReceiverMode = 1, numberOfAddCoagReceivers + modeIndexReceiver = addReceiverMode(iReceiverMode) !Index of additional receiver mode + + do nsiz=1,nBinsTab !aerotab bin sizes + !Sum up coagulation sink for this coagulating species (for all receiving modes) + normCoagSinkAdd(iReceiverMode) = & ![m3/#/s] + normCoagSinkAdd(iReceiverMode) & ![m3/#/s] Previous value + + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode + * CoagCoeffModeAdd(iReceiverMode, nsiz) !Koagulation coefficient (m3/#/s) + end do !Look up table size + end do !receiver modes + !ak- + + nsiz=1 + do while (rBinMidPoint(nsiz).lt.rcoagdroplet.and.nsiz.lt.nBinsTab) + nsiz=nsiz+1 + end do + + if (abs(rBinMidPoint(nsiz-1)-rcoagdroplet).lt.abs(rBinMidPoint(nsiz)-rcoagdroplet)) then + tableindexcloud=nsiz-1 + else + tableindexcloud=nsiz + end if + write(iulog,*) 'Assumed droplet size and table bin number for cloud & coagulation ',rcoagdroplet, ' nbin ',tableindexcloud,'binmid',rBinMidPoint(tableindexcloud) - do iCoagulatingMode = 1, numberOfCoagulatingModes - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of the coagulating mode - - NCloudCoagulationSink(modeIndexCoagulator) = & ![m3/#/s] - K12Cl(iCoagulatingMode, tableindexcloud) !Koagulation coefficient (m3/#/s) - - end do - -end subroutine initializeCoagulationCoefficients - -!Calculates coagulation coefficient for a coagulator mode -!with a given radius with all look-up table modes -subroutine calculateCoagulationCoefficient(CoagulationCoefficient, modeRadius, modeDensity, receiverDensity) - - implicit none - - real(r8), intent(in) :: modeRadius ! [m] (?) - real(r8), intent(in) :: modeDensity ! [kg/m3] densityi - real(r8), intent(in) :: receiverDensity ! [kg/m3] density of receiver - real(r8), intent(out), dimension(:) :: coagulationCoefficient ![m3/s] - - integer :: i !Counter for look-up tables - - real(r8) :: diff1 ![m2/s] diffusivity - real(r8) :: diff2 ![m2/s] diffusivity - real(r8) :: g12 ![-] factor - real(r8) :: g1 ![-] factor - real(r8) :: g2 ![-] factor - real(r8) :: c12 ![m/s] average particle thermal velocity - real(r8) :: c1 ![m/s] particle thermal velocity - real(r8) :: c2 ![m/s] particle thermal velocity - real(r8) :: mfv1 ![m] mean free path particle - real(r8) :: mfv2 ![m] mean free path particle - -! coagulation coefficient for SO4 (Brownian, Fuchs form) - !Loop through indexes in look-up table - do i=1,nBinsTab - c1=calculateThermalVelocity(rBinMidPoint(i), receiverDensity) !receiving size - c2=calculateThermalVelocity(modeRadius, modeDensity) !coagulating aerosol - c12=sqrt(c1**2+c2**2) - - diff1 = calculateParticleDiffusivity(rBinMidPoint(i)) !receiving particle - diff2 = calculateParticleDiffusivity(modeRadius) !coagulating particle - - mfv1=calculateMeanFreePath(diff1,c1) !receiving particle - mfv2=calculateMeanFreePath(diff2,c2) !coagulating particle - - g1 = calculateGFactor(rBinMidPoint(i), mfv1) - g2 = calculateGFactor(modeRadius, mfv2) - - g12=sqrt(g1**2+g2**2) - - !Coagulation coefficient of receiver size "i" with the coagulating - !mode "kcomp" - CoagulationCoefficient(i) = & - 4.0_r8*pi*(rBinMidPoint(i)+modeRadius)*(diff1+diff2) & - /((rBinMidPoint(i)+modeRadius)/(rBinMidPoint(i)+modeRadius+g12) & - +(4.0_r8/c12)*(diff1+diff2)/(modeRadius+rBinMidPoint(i))) - - enddo ! loop on imax - - return - -end subroutine calculateCoagulationCoefficient - - -!Time step routine for coagulation -!Called from chemistry - -subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) - -! Calculate the coagulation of small aerosols with larger particles and -! cloud droplets. Only particles smaller that dry radius of -! 40 nm is assumed to have an efficient coagulation with other particles. - -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only : pcols, pver -use cam_history, only: outfld -use aerosoldef -use const -use physics_buffer, only : physics_buffer_desc -use modal_aero_data, only : qqcw_get_field -implicit none - - -! input arguments - integer, intent(in) :: ncol ! number of horizontal grid cells (columns) - real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure - real(r8), intent(in) :: pdel(pcols,pver) - real(r8), intent(in) :: temperature(pcols,pver) ! [K] temperature - real(r8), intent(in) :: delt_inverse ! [1/s] inverse time step - integer, intent(in) :: lchnk ! [] chnk id needed for output -! local - integer :: k ! level counter - integer :: i ! horizontal counter - integer :: m ! Species counter - integer :: iCoagulator !counter for species coagulating - integer :: iReceiver !counter for species receiving coagulate - integer :: iSpecie !counter for species in mode - integer :: nsiz !loop up table size - integer :: l_index_receiver - integer :: l_index_donor - integer :: modeIndexCoagulator !Index of coagulating mode - integer :: modeIndexReceiver !Index of receiving mode - real(r8) :: rhoAir ![kg/m3] air density - real(r8) :: coagulationSink ![1/s] loss for coagulating specie - real(r8), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration - real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost - character(128) :: long_name ![-] needed for diagnostics - real(r8), pointer :: fldcw(:,:) - real(r8), dimension(pcols, gas_pcnst) :: coltend - real(r8), dimension(pcols) :: tracer_coltend - logical :: history_aerosol - - - totalLoss(:,:,:)=0.0_r8 - - - call phys_getopts(history_aerosol_out = history_aerosol) - - do k=1,pver - do i=1,ncol - - !Air density - rhoAir = pmid(i,k)/rair/temperature(i,k) - - !Initialize number concentration for all receivers - numberConcentration(:) = 0.0_r8 - - !Go though all modes receiving coagulation - do ireceiver = 1,numberOfCoagulationReceivers - - !Go through all core species in that mode - do iSpecie = 1,getNumberOfTracersInMode(receiverMode(ireceiver)) - - !Find the lifecycle-specie receiving the coagulation - l_index_receiver = getTracerIndex(receiverMode(ireceiver) , iSpecie , .true.) - - long_name = solsym(l_index_receiver) !For testing - - - if(.NOT. is_process_mode(l_index_receiver,.true.)) then - !Add up the number concentration of the receiving mode + do iCoagulatingMode = 1, numberOfCoagulatingModes + modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of the coagulating mode + + NCloudCoagulationSink(modeIndexCoagulator) = & ![m3/#/s] + K12Cl(iCoagulatingMode, tableindexcloud) !Koagulation coefficient (m3/#/s) + end do + + end subroutine initializeCoagulationCoefficients + + !================================================================ + subroutine calculateCoagulationCoefficient(CoagulationCoefficient, modeRadius, modeDensity, receiverDensity) + !Calculates coagulation coefficient for a coagulator mode + !with a given radius with all look-up table modes + + real(r8), intent(in) :: modeRadius ! [m] (?) + real(r8), intent(in) :: modeDensity ! [kg/m3] densityi + real(r8), intent(in) :: receiverDensity ! [kg/m3] density of receiver + real(r8), intent(out), dimension(:) :: coagulationCoefficient ![m3/s] + + integer :: i !Counter for look-up tables + + real(r8) :: diff1 ![m2/s] diffusivity + real(r8) :: diff2 ![m2/s] diffusivity + real(r8) :: g12 ![-] factor + real(r8) :: g1 ![-] factor + real(r8) :: g2 ![-] factor + real(r8) :: c12 ![m/s] average particle thermal velocity + real(r8) :: c1 ![m/s] particle thermal velocity + real(r8) :: c2 ![m/s] particle thermal velocity + real(r8) :: mfv1 ![m] mean free path particle + real(r8) :: mfv2 ![m] mean free path particle + + ! coagulation coefficient for SO4 (Brownian, Fuchs form) + !Loop through indexes in look-up table + do i=1,nBinsTab + c1=calculateThermalVelocity(rBinMidPoint(i), receiverDensity) !receiving size + c2=calculateThermalVelocity(modeRadius, modeDensity) !coagulating aerosol + c12=sqrt(c1**2+c2**2) + + diff1 = calculateParticleDiffusivity(rBinMidPoint(i)) !receiving particle + diff2 = calculateParticleDiffusivity(modeRadius) !coagulating particle + + mfv1=calculateMeanFreePath(diff1,c1) !receiving particle + mfv2=calculateMeanFreePath(diff2,c2) !coagulating particle + + g1 = calculateGFactor(rBinMidPoint(i), mfv1) + g2 = calculateGFactor(modeRadius, mfv2) + + g12=sqrt(g1**2+g2**2) + + !Coagulation coefficient of receiver size "i" with the coagulating + !mode "kcomp" + CoagulationCoefficient(i) = & + 4.0_r8*pi*(rBinMidPoint(i)+modeRadius)*(diff1+diff2) & + /((rBinMidPoint(i)+modeRadius)/(rBinMidPoint(i)+modeRadius+g12) & + +(4.0_r8/c12)*(diff1+diff2)/(modeRadius+rBinMidPoint(i))) + + enddo ! loop on imax + end subroutine calculateCoagulationCoefficient + + !================================================================ + subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) + ! Time step routine for coagulation - called from chemistry + ! Calculate the coagulation of small aerosols with larger particles and + ! cloud droplets. Only particles smaller that dry radius of + ! 40 nm is assumed to have an efficient coagulation with other particles. + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only : pcols, pver + use cam_history, only: outfld + use aerosoldef + use const + use physics_buffer, only : physics_buffer_desc + + ! input arguments + integer, intent(in) :: ncol ! number of horizontal grid cells (columns) + real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture + real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure + real(r8), intent(in) :: pdel(pcols,pver) + real(r8), intent(in) :: temperature(pcols,pver) ! [K] temperature + real(r8), intent(in) :: delt_inverse ! [1/s] inverse time step + integer, intent(in) :: lchnk ! [] chnk id needed for output + ! local + integer :: k ! level counter + integer :: i ! horizontal counter + integer :: m ! Species counter + integer :: iCoagulator !counter for species coagulating + integer :: iReceiver !counter for species receiving coagulate + integer :: iSpecie !counter for species in mode + integer :: nsiz !loop up table size + integer :: l_index_receiver + integer :: l_index_donor + integer :: modeIndexCoagulator !Index of coagulating mode + integer :: modeIndexReceiver !Index of receiving mode + real(r8) :: rhoAir ![kg/m3] air density + real(r8) :: coagulationSink ![1/s] loss for coagulating specie + real(r8), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration + real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost + character(128) :: long_name ![-] needed for diagnostics + real(r8), pointer :: fldcw(:,:) + real(r8), dimension(pcols, gas_pcnst) :: coltend + real(r8), dimension(pcols) :: tracer_coltend + logical :: history_aerosol + + + totalLoss(:,:,:)=0.0_r8 + + + call phys_getopts(history_aerosol_out = history_aerosol) + + do k=1,pver + do i=1,ncol + + !Air density + rhoAir = pmid(i,k)/rair/temperature(i,k) + + !Initialize number concentration for all receivers + numberConcentration(:) = 0.0_r8 + + !Go though all modes receiving coagulation + do ireceiver = 1,numberOfCoagulationReceivers + + !Go through all core species in that mode + do iSpecie = 1,getNumberOfTracersInMode(receiverMode(ireceiver)) + + !Find the lifecycle-specie receiving the coagulation + l_index_receiver = getTracerIndex(receiverMode(ireceiver) , iSpecie , .true.) + + long_name = solsym(l_index_receiver) !For testing + + + if(.NOT. is_process_mode(l_index_receiver,.true.)) then + !Add up the number concentration of the receiving mode numberConcentration(iReceiver) = numberConcentration(iReceiver) & !previous value - + q(i,k,l_index_receiver) & !kg/kg - / rhopart(physicsIndex(l_index_receiver)) & !*[m3/kg] ==> m3/kg - * volumeToNumber(receiverMode(ireceiver)) & ![#/m3] ==> #/kg - * rhoAir !#/kg ==> #/m3 - end if - end do !Lifecycle "core" species in this mode - enddo - - - !Go through all coagulating modes - do iCoagulator = 1, numberOfCoagulatingModes - - !Initialize loss (for a coagulator) summed over all receivers - coagulationSink = 0.0_r8 - - modeIndexCoagulator = coagulatingMode(iCoagulator) - - !Sum the loss for all possible receivers - do iReceiver = 1, numberOfCoagulationReceivers - - modeIndexReceiver = receiverMode(iReceiver) - - !Sum up coagulation sink for this coagulating species (for all receiving modes) - coagulationSink = & ![1/s] - coagulationSink + & ![1/] previous value - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] - * numberConcentration(ireceiver) !numberConcentration (#/m3) - end do !receiver modes - - !SOME LIFECYCLE SPECIES CHANGE "HOST MODE" WHEN THEY PARTICIPATE - !IN COAGULATION (THEY GO FROM EXTERNALLY MIXED TO INTERNALLY MIXED MODES) - - !Each coagulating mode can contain several species - do ispecie = 1, getNumberOfTracersInMode(modeIndexCoagulator) - - !Get the lifecycle specie which is lost - l_index_donor = getTracerIndex(modeIndexCoagulator , ispecie,.true. ) - - !Move lifecycle species to new lifecycle species due to coagulation - - !process modes don't change mode except so4 condensate which becomes coagulate instead - !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT - if( .NOT. is_process_mode(l_index_donor,.true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then - - !Done summing total loss of this coagulating specie - totalLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers - * q(i,k,l_index_donor) & !* mixing ratio ==> MMR/s - / delt_inverse ! seconds ==> MMR - - !Can not loose more than we have - totalLoss(i,k,l_index_donor) = min(totalLoss(i,k,l_index_donor) , q(i,k,l_index_donor)) - - - end if !check on process modes - end do !species in mode - - end do !coagulator mode - end do ! i - end do ! k - - - !UPDATE THE TRACERS AND DO DIAGNOSTICS - do iCoagulator = 1, numberOfCoagulatingModes - do ispecie = 1, getNumberOfTracersInMode(coagulatingMode(iCoagulator)) - - l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie ,.true.) - - !so4_a1 is a process mode (condensate), but is still lost in coagulation - if( .NOT. is_process_mode(l_index_donor, .true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then - - l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie,.true. ) - - !index of mode gaining mass (l_so4_ac, l_om_ac, l_bc_ac), coagulate - l_index_receiver = lifeCycleReceiver(l_index_donor) - - do k=1,pver - !Loose mass from tracer in donor mode - q(:ncol,k,l_index_donor) = q(:ncol,k,l_index_donor) - totalLoss(:ncol,k,l_index_donor) - - !Give mass to tracer in receiver mode - q(:ncol,k,l_index_receiver) = q(:ncol,k,l_index_receiver) + totalLoss(:ncol,k,l_index_donor) - end do !k - endif - end do - end do - - !Output for diagnostics - if(history_aerosol)then - coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst - !Check if species contributes to coagulation - if(lifeCycleReceiver(i) .gt. 0)then - !Loss from the donor specie - tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse - coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor - coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) - endif - end do - do i=1,gas_pcnst - if(lifeCycleReceiver(i) .gt. 0)then - long_name= trim(solsym(i))//"coagTend" - call outfld(long_name, coltend(:ncol,i), pcols, lchnk) - long_name= trim(solsym(lifeCycleReceiver(i)))//"coagTend" - call outfld(long_name, coltend(:ncol,lifeCycleReceiver(i)),pcols,lchnk) - end if - end do - endif - -end subroutine coagtend - -subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, ncol , lchnk, im, pbuf) - -! Calculate the coagulation of small aerosols with larger particles and -! cloud droplets. Only particles smaller that dry radius of -! 40 nm is assumed to have an efficient coagulation with other particles. - -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only : pcols, pver -use cam_history, only: outfld -use aerosoldef -use const -use physics_buffer, only : physics_buffer_desc -use modal_aero_data, only : qqcw_get_field -implicit none - - -! input arguments - integer, intent(in) :: ncol ! number of horizontal grid cells (columns) - real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure - real(r8), intent(in) :: pdel(pcols,pver) - real(r8), intent(in) :: temperature(pcols,pver) ! [K] temperature - - real(r8), dimension(ncol,pver),intent(in) :: cldnum ! Droplet concentration #/kg - real(r8), dimension(ncol,pver),intent(in) :: cldfrc ! Cloud volume fraction - - real(r8), intent(in) :: delt_inverse ! [1/s] inverse time step - integer, intent(in) :: lchnk ! [] chnk id needed for output - integer, intent(in) :: im - - type(physics_buffer_desc), pointer :: pbuf(:) - - -! local - integer :: k ! level counter - integer :: i ! horizontal counter - integer :: m ! Species counter - integer :: iCoagulator !counter for species coagulating - integer :: iReceiver !counter for species receiving coagulate - integer :: iSpecie !counter for species in mode - integer :: nsiz !loop up table size - integer :: l_index_receiver - integer :: l_index_donor - integer :: modeIndexCoagulator !Index of coagulating mode - integer :: modeIndexReceiver !Index of receiving mode - real(r8) :: coagulationSink ![1/s] loss for coagulating specie - real(r8), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration - real(r8) :: cloudLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost - character(128) :: long_name ![-] needed for diagnostics - real(r8) :: rhoAir ![kg/m3] air density - real(r8), pointer :: fldcw(:,:) - real(r8), dimension(pcols, gas_pcnst) :: coltend - real(r8), dimension(pcols) :: tracer_coltend - logical :: history_aerosol - - - call phys_getopts(history_aerosol_out = history_aerosol) - - cloudLoss(:,:,:)=0.0_r8 - - - do k=1,pver - do i=1,ncol - if (cldfrc(i,k).gt.1.e-2) then - rhoAir = pmid(i,k)/rair/temperature(i,k) + + q(i,k,l_index_receiver) & !kg/kg + / rhopart(physicsIndex(l_index_receiver)) & !*[m3/kg] ==> m3/kg + * volumeToNumber(receiverMode(ireceiver)) & ![#/m3] ==> #/kg + * rhoAir !#/kg ==> #/m3 + end if + end do !Lifecycle "core" species in this mode + enddo + + !Go through all coagulating modes - do iCoagulator = 1, numberOfCoagulatingModes + do iCoagulator = 1, numberOfCoagulatingModes - !Initialize loss (for a coagulator) summed over all receivers - coagulationSink = 0.0_r8 + !Initialize loss (for a coagulator) summed over all receivers + coagulationSink = 0.0_r8 - modeIndexCoagulator = coagulatingMode(iCoagulator) + modeIndexCoagulator = coagulatingMode(iCoagulator) - !Receiver for cloud coagulation is water droplets so do not need - !go through the coagulation receivers. + !Sum the loss for all possible receivers + do iReceiver = 1, numberOfCoagulationReceivers - !Sum up coagulation sink for this coagulating species (for all receiving modes) - coagulationSink = & ![1/s] - NCloudCoagulationSink(modeIndexCoagulator) & ![m3/#/s] - * (rhoair*cldnum(i,k)/cldfrc(i,k)) ![kg/m3*#/kg - - !Each coagulating mode can contain several species - do ispecie = 1, getNumberOfTracersInMode(modeIndexCoagulator) + modeIndexReceiver = receiverMode(iReceiver) + + !Sum up coagulation sink for this coagulating species (for all receiving modes) + coagulationSink = & ![1/s] + coagulationSink + & ![1/] previous value + normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] + * numberConcentration(ireceiver) !numberConcentration (#/m3) + end do !receiver modes - !Get the lifecycle specie which is lost + !SOME LIFECYCLE SPECIES CHANGE "HOST MODE" WHEN THEY PARTICIPATE + !IN COAGULATION (THEY GO FROM EXTERNALLY MIXED TO INTERNALLY MIXED MODES) + + !Each coagulating mode can contain several species + do ispecie = 1, getNumberOfTracersInMode(modeIndexCoagulator) + + !Get the lifecycle specie which is lost l_index_donor = getTracerIndex(modeIndexCoagulator , ispecie,.true. ) - !Move lifecycle species to new lifecycle species due to coagulation - - !process modes don't change mode except so4 condensate which becomes coagulate instead - !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT - if( .NOT. is_process_mode(l_index_donor,.true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then - - !Done summing total loss of this coagulating specie - cloudLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers - * cldfrc(i,k)*q(i,k,l_index_donor) & !* mixing ratio ==> MMR/s - / delt_inverse ! seconds ==> MMR - - !Can not loose more than we have - ! At present day assumed lost within the cloud - cloudLoss(i,k,l_index_donor) = min(cloudLoss(i,k,l_index_donor) , cldfrc(i,k)*q(i,k,l_index_donor)) - - - end if !check on process modes - end do !species in mode - - end do !coagulator mode - end if ! cldfrc .gt. 0.01 - end do ! i - end do ! k - -!UPDATE THE TRACERS AND DO DIAGNOSTICS - do iCoagulator = 1, numberOfCoagulatingModes - do ispecie = 1, getNumberOfTracersInMode(coagulatingMode(iCoagulator)) - - l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie ,.true.) - - !so4_a1 is a process mode (condensate), but is still lost in coagulation - if( .NOT. is_process_mode(l_index_donor, .true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then - - l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie,.true. ) - - !index of mode gaining mass (l_so4_a2, l_om_ac, l_bc_ac), coagulate - l_index_receiver = CloudAerReceiver(l_index_donor) - fldcw => qqcw_get_field(pbuf, CloudAerReceiver(l_index_donor)+im,lchnk,errorhandle=.true.) - do k=1,pver - !Loose mass from tracer in donor mode - q(:ncol,k,l_index_donor) = q(:ncol,k,l_index_donor) - cloudLoss(:ncol,k,l_index_donor) - !Give mass to tracer in receiver mode - if(associated(fldcw)) then - fldcw(:ncol,k) = fldcw(:ncol,k) + cloudLoss(:ncol,k,l_index_donor) - end if - end do !k - endif - end do - end do - - - !Output for diagnostics - if(history_aerosol)then - coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst - !Check if species contributes to coagulation - if(CloudAerReceiver(i) .gt. 0)then - !Loss from the donor specie - tracer_coltend(:ncol) = sum(cloudLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse + !Move lifecycle species to new lifecycle species due to coagulation - coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor - coltend(:ncol,CloudAerReceiver(i)) = coltend(:ncol,CloudAerReceiver(i)) + tracer_coltend(:ncol) - endif - end do - do i=1,gas_pcnst - if(CloudAerReceiver(i) .gt. 0)then - long_name= trim(solsym(i))//"clcoagTend" - call outfld(long_name, coltend(:ncol,i), pcols, lchnk) - long_name= trim(solsym(CloudAerReceiver(i)))//"_OCWclcoagTend" - call outfld(long_name, coltend(:ncol,CloudAerReceiver(i)),pcols,lchnk) - end if - end do - endif + !process modes don't change mode except so4 condensate which becomes coagulate instead + !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT + if( .NOT. is_process_mode(l_index_donor,.true.) & + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + !Done summing total loss of this coagulating specie + totalLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers + * q(i,k,l_index_donor) & !* mixing ratio ==> MMR/s + / delt_inverse ! seconds ==> MMR + !Can not loose more than we have + totalLoss(i,k,l_index_donor) = min(totalLoss(i,k,l_index_donor) , q(i,k,l_index_donor)) -end subroutine clcoag + end if !check on process modes + end do !species in mode -function calculateThermalVelocity(radius, density) result(thermalVelocity) - implicit none - real(r8), intent(in) :: radius ![m] - real(r8), intent(in) :: density ![kg/m3] - real(r8) :: thermalVelocity ![m/s] + end do !coagulator mode + end do ! i + end do ! k - !Formula for "c1" in Seinfeld & Pandis, table 12.1 - thermalVelocity = sqrt(8.0_r8*kboltzmann*temperatureLookupTables/pi/pi/((4.0_r8/3.0_r8)*density*radius**3)) -end function calculateThermalVelocity + !UPDATE THE TRACERS AND DO DIAGNOSTICS + do iCoagulator = 1, numberOfCoagulatingModes + do ispecie = 1, getNumberOfTracersInMode(coagulatingMode(iCoagulator)) + l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie ,.true.) + !so4_a1 is a process mode (condensate), but is still lost in coagulation + if( .NOT. is_process_mode(l_index_donor, .true.) & + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then -function calculateParticleDiffusivity(radius) result (diffusivity) - implicit none - real(r8), intent(in) :: radius ![m] particle radius - real(r8) :: knudsenNumber ![-] knudsen number - real(r8) :: diffusivity ![m2/s] diffusivity + l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie,.true. ) - real(r8) :: factor - real(r8) :: numerator, nominator + !index of mode gaining mass (l_so4_ac, l_om_ac, l_bc_ac), coagulate + l_index_receiver = lifeCycleReceiver(l_index_donor) + do k=1,pver + !Loose mass from tracer in donor mode + q(:ncol,k,l_index_donor) = q(:ncol,k,l_index_donor) - totalLoss(:ncol,k,l_index_donor) - !Solve eqn for diffusivity in Seinfeld/Pandis, table 12.1 + !Give mass to tracer in receiver mode + q(:ncol,k,l_index_receiver) = q(:ncol,k,l_index_receiver) + totalLoss(:ncol,k,l_index_donor) + end do !k + endif + end do + end do - knudsenNumber = mfpAir/radius + !Output for diagnostics + if(history_aerosol)then + coltend(:ncol,:) = 0.0_r8 + do i=1,gas_pcnst + !Check if species contributes to coagulation + if(lifeCycleReceiver(i) .gt. 0)then + !Loss from the donor specie + tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse + coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor + coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) + endif + end do + do i=1,gas_pcnst + if(lifeCycleReceiver(i) .gt. 0)then + long_name= trim(solsym(i))//"coagTend" + call outfld(long_name, coltend(:ncol,i), pcols, lchnk) + long_name= trim(solsym(lifeCycleReceiver(i)))//"coagTend" + call outfld(long_name, coltend(:ncol,lifeCycleReceiver(i)),pcols,lchnk) + end if + end do + endif + end subroutine coagtend + + !================================================================ + subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, ncol , lchnk, im, pbuf) + ! Calculate the coagulation of small aerosols with larger particles and + ! cloud droplets. Only particles smaller that dry radius of + ! 40 nm is assumed to have an efficient coagulation with other particles. + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only : pcols, pver + use cam_history, only: outfld + use aerosoldef + use const + use physics_buffer, only : physics_buffer_desc + + ! input arguments + integer, intent(in) :: ncol ! number of horizontal grid cells (columns) + real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture + real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure + real(r8), intent(in) :: pdel(pcols,pver) + real(r8), intent(in) :: temperature(pcols,pver) ! [K] temperature + + real(r8), dimension(ncol,pver),intent(in) :: cldnum ! Droplet concentration #/kg + real(r8), dimension(ncol,pver),intent(in) :: cldfrc ! Cloud volume fraction + + real(r8), intent(in) :: delt_inverse ! [1/s] inverse time step + integer, intent(in) :: lchnk ! [] chnk id needed for output + integer, intent(in) :: im + + type(physics_buffer_desc), pointer :: pbuf(:) + + + ! local + integer :: k ! level counter + integer :: i ! horizontal counter + integer :: m ! Species counter + integer :: iCoagulator !counter for species coagulating + integer :: iReceiver !counter for species receiving coagulate + integer :: iSpecie !counter for species in mode + integer :: nsiz !loop up table size + integer :: l_index_receiver + integer :: l_index_donor + integer :: modeIndexCoagulator !Index of coagulating mode + integer :: modeIndexReceiver !Index of receiving mode + real(r8) :: coagulationSink ![1/s] loss for coagulating specie + real(r8) :: cloudLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost + character(128) :: long_name ![-] needed for diagnostics + real(r8) :: rhoAir ![kg/m3] air density + real(r8), pointer :: fldcw(:,:) + real(r8) :: coltend(pcols, gas_pcnst) + real(r8) :: tracer_coltend(pcols) + logical :: history_aerosol + + call phys_getopts(history_aerosol_out = history_aerosol) + + cloudLoss(:,:,:)=0.0_r8 + do k=1,pver + do i=1,ncol + if (cldfrc(i,k).gt.1.e-2) then + rhoAir = pmid(i,k)/rair/temperature(i,k) + !Go through all coagulating modes + do iCoagulator = 1, numberOfCoagulatingModes + + !Initialize loss (for a coagulator) summed over all receivers + coagulationSink = 0.0_r8 + + modeIndexCoagulator = coagulatingMode(iCoagulator) + + !Receiver for cloud coagulation is water droplets so do not need + !go through the coagulation receivers. + + !Sum up coagulation sink for this coagulating species (for all receiving modes) + coagulationSink = & ![1/s] + NCloudCoagulationSink(modeIndexCoagulator) & ![m3/#/s] + * (rhoair*cldnum(i,k)/cldfrc(i,k)) ![kg/m3*#/kg + + !Each coagulating mode can contain several species + do ispecie = 1, getNumberOfTracersInMode(modeIndexCoagulator) + + !Get the lifecycle specie which is lost + l_index_donor = getTracerIndex(modeIndexCoagulator , ispecie,.true. ) + + !Move lifecycle species to new lifecycle species due to coagulation + + !process modes don't change mode except so4 condensate which becomes coagulate instead + !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT + if( .NOT. is_process_mode(l_index_donor,.true.) & + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then - factor = (kboltzmann*temperatureLookupTables/3.0_r8/pi/viscosityAir/2.0_r8/radius) - numerator = 5.0_r8 + 4.0_r8*knudsenNumber + 6.0_r8*knudsenNumber**2 + 18.0_r8*knudsenNumber**3 - nominator = 5.0_r8 - knudsenNumber + (8.0_r8 + pi)*knudsenNumber**2 + !Done summing total loss of this coagulating specie + cloudLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers + * cldfrc(i,k)*q(i,k,l_index_donor) & !* mixing ratio ==> MMR/s + / delt_inverse ! seconds ==> MMR - diffusivity = factor*numerator/nominator -end function calculateParticleDiffusivity + !Can not loose more than we have + ! At present day assumed lost within the cloud + cloudLoss(i,k,l_index_donor) = min(cloudLoss(i,k,l_index_donor) , cldfrc(i,k)*q(i,k,l_index_donor)) + end if !check on process modes + end do !species in mode + end do !coagulator mode + end if ! cldfrc .gt. 0.01 + end do ! i + end do ! k -function calculateMeanFreePath(diffusivity,thermalVelocity) result(MeanFreePath) - implicit none - real(r8) :: diffusivity ![m2/s] - real(r8) :: thermalVelocity ![m/s] - real(r8) :: meanFreePath ![m] + !UPDATE THE TRACERS AND DO DIAGNOSTICS + do iCoagulator = 1, numberOfCoagulatingModes + do ispecie = 1, getNumberOfTracersInMode(coagulatingMode(iCoagulator)) + l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie ,.true.) - meanFreePath = 8.0_r8*diffusivity/(pi*thermalVelocity) -end function calculateMeanFreePath + !so4_a1 is a process mode (condensate), but is still lost in coagulation + if( .NOT. is_process_mode(l_index_donor, .true.) & + .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) & + .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then + l_index_donor = getTracerIndex(coagulatingMode(iCoagulator), ispecie, .true.) -function calculateGFactor(radius, meanFreePath) result(g) - implicit none - real(r8) :: radius ![m] - real(r8) :: meanFreePath ![m] - real(r8) :: g + !index of mode gaining mass (l_so4_a2, l_om_ac, l_bc_ac), coagulate + l_index_receiver = CloudAerReceiver(l_index_donor) + fldcw => qqcw_get_field(pbuf, CloudAerReceiver(l_index_donor)+im) - g = ((2.0_r8*radius+meanFreePath)**3 & + do k=1,pver + !Loose mass from tracer in donor mode + q(:ncol,k,l_index_donor) = q(:ncol,k,l_index_donor) - cloudLoss(:ncol,k,l_index_donor) + + !Give mass to tracer in receiver mode + if(associated(fldcw)) then + fldcw(:ncol,k) = fldcw(:ncol,k) + cloudLoss(:ncol,k,l_index_donor) + end if + end do !k + endif + end do + end do + + !Output for diagnostics + if(history_aerosol)then + coltend(:ncol,:) = 0.0_r8 + do i=1,gas_pcnst + !Check if species contributes to coagulation + if(CloudAerReceiver(i) .gt. 0)then + !Loss from the donor specie + tracer_coltend(:ncol) = sum(cloudLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse + + coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor + coltend(:ncol,CloudAerReceiver(i)) = coltend(:ncol,CloudAerReceiver(i)) + tracer_coltend(:ncol) + endif + end do + do i=1,gas_pcnst + if(CloudAerReceiver(i) .gt. 0)then + long_name= trim(solsym(i))//"clcoagTend" + call outfld(long_name, coltend(:ncol,i), pcols, lchnk) + long_name= trim(solsym(CloudAerReceiver(i)))//"_OCWclcoagTend" + call outfld(long_name, coltend(:ncol,CloudAerReceiver(i)),pcols,lchnk) + end if + end do + endif + end subroutine clcoag + + !================================================================ + function calculateThermalVelocity(radius, density) result(thermalVelocity) + real(r8), intent(in) :: radius ![m] + real(r8), intent(in) :: density ![kg/m3] + real(r8) :: thermalVelocity ![m/s] + + !Formula for "c1" in Seinfeld & Pandis, table 12.1 + thermalVelocity = sqrt(8.0_r8*kboltzmann*temperatureLookupTables/pi/pi/((4.0_r8/3.0_r8)*density*radius**3)) + end function calculateThermalVelocity + + !================================================================ + function calculateParticleDiffusivity(radius) result (diffusivity) + real(r8), intent(in) :: radius ![m] particle radius + + real(r8) :: knudsenNumber ![-] knudsen number + real(r8) :: diffusivity ![m2/s] diffusivity + real(r8) :: factor + real(r8) :: numerator, nominator + + !Solve eqn for diffusivity in Seinfeld/Pandis, table 12.1 + knudsenNumber = mfpAir/radius + factor = (kboltzmann*temperatureLookupTables/3.0_r8/pi/viscosityAir/2.0_r8/radius) + numerator = 5.0_r8 + 4.0_r8*knudsenNumber + 6.0_r8*knudsenNumber**2 + 18.0_r8*knudsenNumber**3 + nominator = 5.0_r8 - knudsenNumber + (8.0_r8 + pi)*knudsenNumber**2 + diffusivity = factor*numerator/nominator + end function calculateParticleDiffusivity + + !================================================================ + function calculateMeanFreePath(diffusivity,thermalVelocity) result(MeanFreePath) + real(r8) :: diffusivity ![m2/s] + real(r8) :: thermalVelocity ![m/s] + real(r8) :: meanFreePath ![m] + + meanFreePath = 8.0_r8*diffusivity/(pi*thermalVelocity) + end function calculateMeanFreePath + + !================================================================ + function calculateGFactor(radius, meanFreePath) result(g) + real(r8) :: radius ![m] + real(r8) :: meanFreePath ![m] + real(r8) :: g + + g = ((2.0_r8*radius+meanFreePath)**3 & -(4.0_r8*radius**2+meanFreePath**2)**1.5_r8) & /(6.0_r8*radius*meanFreePath) & -2.0_r8*radius - -end function calculateGFactor + end function calculateGFactor end module koagsub diff --git a/src/chemistry/oslo_aero/nucleate_ice_oslo.F90 b/src/chemistry/oslo_aero/nucleate_ice_oslo.F90 index e6b6696e6d..d4d2eb929b 100644 --- a/src/chemistry/oslo_aero/nucleate_ice_oslo.F90 +++ b/src/chemistry/oslo_aero/nucleate_ice_oslo.F90 @@ -30,8 +30,7 @@ module nucleate_ice_oslo use aerosoldef, only: l_dst_a2, l_dst_a3, & MODE_IDX_DST_A2, MODE_IDX_DST_A3, & - rhopart -use modal_aero_data, only: qqcw_get_field + rhopart, qqcw_get_field use const , only: volumeToNumber implicit none @@ -352,8 +351,8 @@ subroutine nucleate_ice_oslo_calc( & call physics_ptend_init(ptend, state%psetcols, 'nucleatei', lq=lq) - cld_dst_a2 => qqcw_get_field(pbuf, l_dst_a2, lchnk, .true.) - cld_dst_a3 => qqcw_get_field(pbuf, l_dst_a2, lchnk, .true.) + cld_dst_a2 => qqcw_get_field(pbuf, l_dst_a2) + cld_dst_a3 => qqcw_get_field(pbuf, l_dst_a2) itim_old = pbuf_old_tim_idx() call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) diff --git a/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 b/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 index 62c3a84b35..4f52d83d15 100644 --- a/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 +++ b/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 @@ -2,7 +2,6 @@ module oslo_aerosols_intr use aerosoldef use commondefinitions - use modal_aero_data, only: qqcw_get_field use shr_kind_mod, only: r8 => shr_kind_r8 use constituents, only: pcnst, cnst_name, cnst_get_ind use ppgrid, only: pcols, pver, pverp @@ -16,9 +15,6 @@ module oslo_aerosols_intr use physics_buffer, only: physics_buffer_desc use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field use physconst, only: gravit, rair, rhoh2o - use spmd_utils, only: masterproc - use infnan, only: nan, assignment(=) - use cam_history, only: outfld, fieldname_len use chem_mods, only: gas_pcnst, adv_mass use mo_tracname, only: solsym @@ -81,9 +77,6 @@ subroutine oslo_aero_initialize(pbuf2d ) use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk use ppgrid, only: pcols, pver, begchunk, endchunk use time_manager, only: is_first_step - use modal_aero_data, only: qqcw_get_field - - implicit none type(physics_buffer_desc), pointer :: pbuf2d(:,:) integer :: m @@ -213,10 +206,9 @@ subroutine oslo_aero_initialize(pbuf2d ) if (is_first_step()) then ! initialize cloud bourne constituents in physics buffer - do i = 1, pcnst do lchnk = begchunk, endchunk - qqcw => qqcw_get_field(pbuf_get_chunk(pbuf2d,lchnk), i, lchnk, .true.) + qqcw => qqcw_get_field(pbuf_get_chunk(pbuf2d,lchnk), i) if (associated(qqcw)) then qqcw = 1.e-38_r8 end if @@ -226,12 +218,9 @@ subroutine oslo_aero_initialize(pbuf2d ) end subroutine oslo_aero_initialize - subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend & - , dgncur_awet, wetdens, dgncur_awet_processmode & - , wetdens_processmode, cflx & - ) + subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend, & + dgncur_awet, wetdens, dgncur_awet_processmode, wetdens_processmode, cflx) - !=============================================================================== use cam_history, only: outfld use ppgrid, only: pverp use physics_types, only: physics_state, physics_ptend @@ -242,10 +231,6 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out use modal_aero_deposition, only: set_srf_drydep use physics_buffer, only : physics_buffer_desc - !----------------------------------------------------------------------- - implicit none - !----------------------------------------------------------------------- - ! ! Arguments: type(physics_state), intent(in) :: state ! Physics state variables real(r8), intent(in) :: obklen(:) @@ -526,7 +511,7 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out else ! lphase == 2 !Pick up the cloud tracers (oslo) - fldcw => qqcw_get_field(pbuf, mm,lchnk,.true.) + fldcw => qqcw_get_field(pbuf, mm) if( .not. associated(fldcw))then cycle end if @@ -583,8 +568,8 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out end subroutine oslo_aero_dry_intr !=============================================================================== subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) - - + + !----------------------------------------------------------------------- !----------------------------------------------------------------------- use cam_history, only: outfld @@ -641,8 +626,8 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) real(r8) :: q_tmp(pcols,pver) ! temporary array to hold "most current" mixing ratio for 1 species real(r8) :: qqcw_tmp(pcols,pver) ! temporary array to hold qqcw ! rce 2010/05/01 real(r8) :: scavcoefnv(pcols,pver,0:2) ! Dana and Hales coefficient (/mm) for - ! cloud-borne num & vol (0), - ! interstitial num (1), interstitial vol (2) + ! cloud-borne num & vol (0), + ! interstitial num (1), interstitial vol (2) real(r8) :: tmpa, tmpb real(r8) :: tmpdust, tmpnacl real(r8) :: water_old, water_new ! temporary old/new aerosol water mix-rat @@ -691,28 +676,28 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) ptend%name = ptend%name//'+mz_aero_wetdep' call wetdep_inputs_set( state, pbuf, dep_inputs ) - call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) - - prec(:ncol)=0._r8 - do k=1,pver - where (prec(:ncol) >= 1.e-7_r8) - isprx(:ncol,k) = .true. - elsewhere - isprx(:ncol,k) = .false. - endwhere + call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) + + prec(:ncol)=0._r8 + do k=1,pver + where (prec(:ncol) >= 1.e-7_r8) + isprx(:ncol,k) = .true. + elsewhere + isprx(:ncol,k) = .false. + endwhere prec(:ncol) = prec(:ncol) + (dep_inputs%prain(:ncol,k) + dep_inputs%cmfdqr(:ncol,k) - dep_inputs%evapr(:ncol,k)) & - *state%pdel(:ncol,k)/gravit - end do + *state%pdel(:ncol,k)/gravit + end do -! calculate the mass-weighted sol_factic for coarse mode species -! sol_factic_coarse(:,:) = 0.30_r8 ! tuned 1/4 - f_act_conv_coarse(:,:) = 0.60_r8 ! rce 2010/05/02 - f_act_conv_coarse_dust = 0.40_r8 ! rce 2010/05/02 - f_act_conv_coarse_nacl = 0.80_r8 ! rce 2010/05/02 - !++ag - f_act_conv_coarse(:,:) = 0.5_r8 - !--ag + ! calculate the mass-weighted sol_factic for coarse mode species + ! sol_factic_coarse(:,:) = 0.30_r8 ! tuned 1/4 + f_act_conv_coarse(:,:) = 0.60_r8 ! rce 2010/05/02 + f_act_conv_coarse_dust = 0.40_r8 ! rce 2010/05/02 + f_act_conv_coarse_nacl = 0.80_r8 ! rce 2010/05/02 + !++ag + f_act_conv_coarse(:,:) = 0.5_r8 + !--ag scavcoefnv(:,:,0) = 0.0_r8 ! below-cloud scavcoef = 0.0 for cloud-borne species @@ -750,7 +735,7 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) scavcoefnv(:,:,1) = 0.1_r8 !Used by MAM for number concentration sol_factb = 0.1_r8 ! all below-cloud scav ON (0.1 "tuning factor") -! sol_factb = 0.03_r8 ! all below-cloud scav ON (0.1 "tuning factor") ! tuned 1/6 + ! sol_factb = 0.03_r8 ! all below-cloud scav ON (0.1 "tuning factor") ! tuned 1/6 sol_facti = 0.0_r8 ! strat in-cloud scav totally OFF for institial @@ -761,7 +746,7 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) else ! cloud-borne aerosol (borne by stratiform cloud drops) - + !++ag !default 100 % is scavenged by cloud -borne sol_facti_cloud_borne = 1.0_r8 @@ -770,7 +755,7 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) sol_factb = 0.0_r8 ! all below-cloud scav OFF (anything cloud-borne is located "in-cloud") sol_facti = sol_facti_cloud_borne ! strat in-cloud scav cloud-borne tuning factor sol_factic = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean - ! that conv precip collects strat droplets) + ! that conv precip collects strat droplets) f_act_conv = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean end if @@ -787,182 +772,181 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) do lspec = 1,getNumberOfTracersInMode(m) ! loop over number + chem constituents + water - - mm = getTracerIndex(m,lspec,.false.) - if(is_done(mm,lphase) .eqv. .true. )then - cycle - endif - is_done(mm,lphase)=.true. - - if (lphase == 1) then - jnv = 2 - !Set correct below cloud scaveing coefficients - !Hard-coded values per mode in NorESM - if(is_process_mode(mm,.FALSE.))then - scavcoefnv(:,:,jnv) = belowCloudScavengingCoefficientProcessModes(processModeMap(mm)) - else - scavcoefnv(:,:,jnv) = belowCloudScavengingCoefficient(m) - end if - else - jnv = 0 !==> below cloud scavenging coefficients are zero (see above) - endif - + mm = getTracerIndex(m,lspec,.false.) + if(is_done(mm,lphase) .eqv. .true. )then + cycle + endif + is_done(mm,lphase)=.true. + + if (lphase == 1) then + jnv = 2 + !Set correct below cloud scaveing coefficients + !Hard-coded values per mode in NorESM + if(is_process_mode(mm,.FALSE.))then + scavcoefnv(:,:,jnv) = belowCloudScavengingCoefficientProcessModes(processModeMap(mm)) + else + scavcoefnv(:,:,jnv) = belowCloudScavengingCoefficient(m) + end if + else + jnv = 0 !==> below cloud scavenging coefficients are zero (see above) + endif - if ((lphase == 1) .and. (lspec <= getNumberOfTracersInMode(m))) then - ptend%lq(mm) = .TRUE. - dqdt_tmp(:,:) = 0.0_r8 - ! q_tmp reflects changes from modal_aero_calcsize and is the "most current" q - q_tmp(1:ncol,:) = state%q(1:ncol,:,mm) + ptend%q(1:ncol,:,mm)*dt + if ((lphase == 1) .and. (lspec <= getNumberOfTracersInMode(m))) then + ptend%lq(mm) = .TRUE. + dqdt_tmp(:,:) = 0.0_r8 + ! q_tmp reflects changes from modal_aero_calcsize and is the "most current" q + q_tmp(1:ncol,:) = state%q(1:ncol,:,mm) + ptend%q(1:ncol,:,mm)*dt if(convproc_do_aer) then !Feed in the saved cloudborne mixing ratios from phase 2 qqcw_in(:,:) = qqcw_sav(:,:,mm) !Not implemented for oslo aerosols else - fldcw => qqcw_get_field(pbuf, mm,lchnk, .TRUE.) + fldcw => qqcw_get_field(pbuf, mm) if(.not. associated(fldcw))then qqcw_in(:,:) = zeroAerosolConcentration(:,:) else - qqcw_in(:,:) = fldcw(:,:) + qqcw_in(:,:) = fldcw(:,:) end if - endif + endif - call wetdepa_v2( state%pmid, state%q(:,:,1), state%pdel, & - dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & - dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & - dep_inputs%evapr, dep_inputs%totcond, q_tmp, dt, & - dqdt_tmp, iscavt, dep_inputs%cldvcu, dep_inputs%cldvst, & - dlf, fracis(:,:,mm), sol_factb, ncol, & - scavcoefnv(:,:,jnv), & - is_strat_cloudborne=.false., & - qqcw=qqcw_in(:,:), & - f_act_conv=f_act_conv, & - icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & - convproc_do_aer=.false., rcscavt=rcscavt, rsscavt=rsscavt, & - sol_facti_in=sol_facti, sol_factic_in=sol_factic ) - - ptend%q(1:ncol,:,mm) = ptend%q(1:ncol,:,mm) + dqdt_tmp(1:ncol,:) - - call outfld( trim(cnst_name(mm))//'WET', dqdt_tmp(:,:), pcols, lchnk) - call outfld( trim(cnst_name(mm))//'SIC', icscavt, pcols, lchnk) - call outfld( trim(cnst_name(mm))//'SIS', isscavt, pcols, lchnk) - call outfld( trim(cnst_name(mm))//'SBC', bcscavt, pcols, lchnk) - call outfld( trim(cnst_name(mm))//'SBS', bsscavt, pcols, lchnk) - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+dqdt_tmp(i,k)*state%pdel(i,k)/gravit + call wetdepa_v2( state%pmid, state%q(:,:,1), state%pdel, & + dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & + dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & + dep_inputs%evapr, dep_inputs%totcond, q_tmp, dt, & + dqdt_tmp, iscavt, dep_inputs%cldvcu, dep_inputs%cldvst, & + dlf, fracis(:,:,mm), sol_factb, ncol, & + scavcoefnv(:,:,jnv), & + is_strat_cloudborne=.false., & + qqcw=qqcw_in(:,:), & + f_act_conv=f_act_conv, & + icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & + convproc_do_aer=.false., rcscavt=rcscavt, rsscavt=rsscavt, & + sol_facti_in=sol_facti, sol_factic_in=sol_factic ) + + ptend%q(1:ncol,:,mm) = ptend%q(1:ncol,:,mm) + dqdt_tmp(1:ncol,:) + + call outfld( trim(cnst_name(mm))//'WET', dqdt_tmp(:,:), pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SIC', icscavt, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SIS', isscavt, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SBC', bcscavt, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SBS', bsscavt, pcols, lchnk) + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+dqdt_tmp(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo if (.not.convproc_do_aer) call outfld( trim(cnst_name(mm))//'SFWET', sflx, pcols, lchnk) - aerdepwetis(:ncol,mm) = sflx(:ncol) - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+icscavt(i,k)*state%pdel(i,k)/gravit + aerdepwetis(:ncol,mm) = sflx(:ncol) + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+icscavt(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo if (.not.convproc_do_aer) call outfld( trim(cnst_name(mm))//'SFSIC', sflx, pcols, lchnk) if (convproc_do_aer) sflxic = sflx - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+isscavt(i,k)*state%pdel(i,k)/gravit + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+isscavt(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo - call outfld( trim(cnst_name(mm))//'SFSIS', sflx, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SFSIS', sflx, pcols, lchnk) - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+bcscavt(i,k)*state%pdel(i,k)/gravit + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+bcscavt(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo - call outfld( trim(cnst_name(mm))//'SFSBC', sflx, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'SFSBC', sflx, pcols, lchnk) if (convproc_do_aer)sflxbc = sflx - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+bsscavt(i,k)*state%pdel(i,k)/gravit + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+bsscavt(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo - call outfld( trim(cnst_name(mm))//'SFSBS', sflx, pcols, lchnk) - + call outfld( trim(cnst_name(mm))//'SFSBS', sflx, pcols, lchnk) - + else ! lphase == 2 - else ! lphase == 2 - dqdt_tmp(:,:) = 0.0_r8 - qqcw_tmp(:,:) = 0.0_r8 ! rce 2010/05/01 + dqdt_tmp(:,:) = 0.0_r8 + qqcw_tmp(:,:) = 0.0_r8 ! rce 2010/05/01 - if (convproc_do_aer) then - fldcw => qqcw_get_field(pbuf,mm,lchnk) - qqcw_sav(1:ncol,:,mm) = fldcw(1:ncol,:) - !This option yet not implemented for OSLO_AERO - else - fldcw => qqcw_get_field(pbuf, mm,lchnk, .TRUE.) - if(.not. associated(fldcw))then - cycle - end if - endif - - call wetdepa_v2(state%pmid, state%q(:,:,1), state%pdel, & - dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & - dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & - dep_inputs%evapr, dep_inputs%totcond, fldcw, dt, & - dqdt_tmp, iscavt, dep_inputs%cldvcu, dep_inputs%cldvst, & - dlf, fracis_cw, sol_factb, ncol, & - scavcoefnv(:,:,jnv), & - is_strat_cloudborne=.true., & - icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & - convproc_do_aer=.false., rcscavt=rcscavt, rsscavt=rsscavt, & - sol_facti_in=sol_facti, sol_factic_in=sol_factic ) - - fldcw(1:ncol,:) = fldcw(1:ncol,:) + dqdt_tmp(1:ncol,:) * dt + if (convproc_do_aer) then + fldcw => qqcw_get_field(pbuf,mm) + if (.not. associated(fldcw)) then + call endrun('attempt to access undefined qqcw_sav for fld_cw') + end if + qqcw_sav(1:ncol,:,mm) = fldcw(1:ncol,:) + !This option yet not implemented for OSLO_AERO + else + fldcw => qqcw_get_field(pbuf, mm) + if(.not. associated(fldcw))then + cycle + end if + endif - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+dqdt_tmp(i,k)*state%pdel(i,k)/gravit + call wetdepa_v2(state%pmid, state%q(:,:,1), state%pdel, & + dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & + dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & + dep_inputs%evapr, dep_inputs%totcond, fldcw, dt, & + dqdt_tmp, iscavt, dep_inputs%cldvcu, dep_inputs%cldvst, & + dlf, fracis_cw, sol_factb, ncol, & + scavcoefnv(:,:,jnv), & + is_strat_cloudborne=.true., & + icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & + convproc_do_aer=.false., rcscavt=rcscavt, rsscavt=rsscavt, & + sol_facti_in=sol_facti, sol_factic_in=sol_factic ) + + fldcw(1:ncol,:) = fldcw(1:ncol,:) + dqdt_tmp(1:ncol,:) * dt + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+dqdt_tmp(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFWET', sflx, pcols, lchnk) - aerdepwetcw(:ncol,mm) = sflx(:ncol) - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+icscavt(i,k)*state%pdel(i,k)/gravit + call outfld( trim(getCloudTracerName(mm))//'SFWET', sflx, pcols, lchnk) + aerdepwetcw(:ncol,mm) = sflx(:ncol) + + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+icscavt(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFSIC', sflx, pcols, lchnk) - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+isscavt(i,k)*state%pdel(i,k)/gravit + call outfld( trim(getCloudTracerName(mm))//'SFSIC', sflx, pcols, lchnk) + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+isscavt(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFSIS', sflx, pcols, lchnk) - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+bcscavt(i,k)*state%pdel(i,k)/gravit + call outfld( trim(getCloudTracerName(mm))//'SFSIS', sflx, pcols, lchnk) + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+bcscavt(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFSBC', sflx, pcols, lchnk) - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+bsscavt(i,k)*state%pdel(i,k)/gravit + call outfld( trim(getCloudTracerName(mm))//'SFSBC', sflx, pcols, lchnk) + sflx(:)=0._r8 + do k=1,pver + do i=1,ncol + sflx(i)=sflx(i)+bsscavt(i,k)*state%pdel(i,k)/gravit + enddo enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFSBS', sflx, pcols, lchnk) + call outfld( trim(getCloudTracerName(mm))//'SFSBS', sflx, pcols, lchnk) - endif + endif enddo ! lspec = 0, nspec_amode(m)+1 enddo ! lphase = 1, 2 diff --git a/src/physics/cam_oslo/aero_model.F90 b/src/physics/cam_oslo/aero_model.F90 index 6065d13c5b..6ae97402df 100644 --- a/src/physics/cam_oslo/aero_model.F90 +++ b/src/physics/cam_oslo/aero_model.F90 @@ -22,6 +22,7 @@ module aero_model use chem_mods, only: gas_pcnst, adv_mass use mo_tracname, only: solsym use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName + use aerosoldef, only: qqcw_get_field use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub use koagsub, only: coagtend, clcoag use sox_cldaero_mod, only: sox_cldaero_init @@ -505,7 +506,7 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ delt_inverse = 1.0_r8 / delt !Get height of boundary layer (needed for boundary layer nucleation) - call pbuf_get_field(pbuf, pblh_idx, pblh) + call pbuf_get_field(pbuf, pblh_idx, pblh) ! calculate tendency due to gas phase chemistry and processes dvmrdt(:ncol,:,:) = (vmr(:ncol,:,:) - vmr0(:ncol,:,:)) / delt @@ -704,7 +705,6 @@ subroutine qqcw2vmr(lchnk, vmr, mbar, ncol, im, pbuf) ! ... Xfrom from mass to volume mixing ratio !----------------------------------------------------------------- - use modal_aero_data , only : qqcw_get_field use physics_buffer , only : physics_buffer_desc use chem_mods , only : adv_mass, gas_pcnst @@ -724,7 +724,7 @@ subroutine qqcw2vmr(lchnk, vmr, mbar, ncol, im, pbuf) do m=1,gas_pcnst if( adv_mass(m) /= 0._r8 ) then - fldcw => qqcw_get_field(pbuf, m+im,lchnk,errorhandle=.true.) + fldcw => qqcw_get_field(pbuf, m+im) if(associated(fldcw)) then do k=1,pver vmr(:ncol,k,m) = mbar(:ncol,k) * fldcw(:ncol,k) / adv_mass(m) @@ -744,7 +744,6 @@ subroutine vmr2qqcw( lchnk, vmr, mbar, ncol, im, pbuf ) use m_spc_id use chem_mods, only : adv_mass, gas_pcnst - use modal_aero_data, only : qqcw_get_field use physics_buffer, only : physics_buffer_desc !----------------------------------------------------------------- @@ -764,7 +763,7 @@ subroutine vmr2qqcw( lchnk, vmr, mbar, ncol, im, pbuf ) ! ... The non-group species !----------------------------------------------------------------- do m = 1,gas_pcnst - fldcw => qqcw_get_field(pbuf, m+im,lchnk,errorhandle=.true.) + fldcw => qqcw_get_field(pbuf, m+im) if( adv_mass(m) /= 0._r8 .and. associated(fldcw)) then do k = 1,pver fldcw(:ncol,k) = adv_mass(m) * vmr(:ncol,k,m) / mbar(:ncol,k) diff --git a/src/physics/cam_oslo/hetfrz_classnuc_oslo.F90 b/src/physics/cam_oslo/hetfrz_classnuc_oslo.F90 index 3910d2869a..71a78f7f01 100644 --- a/src/physics/cam_oslo/hetfrz_classnuc_oslo.F90 +++ b/src/physics/cam_oslo/hetfrz_classnuc_oslo.F90 @@ -29,9 +29,9 @@ module hetfrz_classnuc_oslo use hetfrz_classnuc, only: hetfrz_classnuc_init, hetfrz_classnuc_calc use oslo_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius use aerosoldef, only : MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT + implicit none private - save public :: & hetfrz_classnuc_oslo_readnl, & @@ -110,9 +110,9 @@ module hetfrz_classnuc_oslo ! Copy of interstitial aerosols with basis converted from mass to volume. real(r8), allocatable :: aer(:,:,:,:) - !=============================================================================== +!=============================================================================== contains - !=============================================================================== +!=============================================================================== subroutine hetfrz_classnuc_oslo_readnl(nlfile) @@ -345,15 +345,13 @@ end subroutine hetfrz_classnuc_oslo_init !================================================================================================ subroutine hetfrz_classnuc_oslo_calc( & - state, deltatin, factnum, pbuf & - ,numberConcentration, volumeConcentration & - ,f_acm, f_bcm, f_aqm, f_so4_condm, f_soam & - ,hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) + state, deltatin, factnum, pbuf, & + numberConcentration, volumeConcentration, & + f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & + hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) use commondefinitions, only: nmodes_oslo => nmodes - use modal_aero_data, only : qqcw_get_field use aerosoldef, only : getNumberOfTracersInMode, getTracerIndex - implicit none ! arguments type(physics_state), target, intent(in) :: state @@ -374,7 +372,7 @@ subroutine hetfrz_classnuc_oslo_calc( & real(r8),intent(in) :: volumeCore(pcols,pver,nmodes_oslo) real(r8),intent(in) :: volumeCoat(pcols,pver,nmodes_oslo) - type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_buffer_desc), pointer :: pbuf(:) ! local workspace @@ -674,254 +672,252 @@ subroutine hetfrz_classnuc_oslo_calc( & call outfld('NUMIMM10sDST', numice10s_imm_dst, pcols, lchnk) call outfld('NUMIMM10sBC', numice10s_imm_bc, pcols, lchnk) - end associate - -end subroutine hetfrz_classnuc_oslo_calc - -!==================================================================================================== - -subroutine hetfrz_classnuc_oslo_save_cbaero(state, pbuf) - - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only: getTracerIndex, getNumberOfTracersInMode - use modal_aero_data, only: qqcw_get_field - - ! Save the required cloud borne aerosol constituents. - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - ! local variables - integer :: i, lchnk, kk, ncol, m, n - real(r8), pointer :: ptr2d(:,:) - type qqcw_type - real(r8), pointer :: fldcw(:,:) - end type qqcw_type - type(qqcw_type) :: qqcw(pcnst) - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - - ! loop over the cloud borne constituents required by this module and save - ! a local copy - - aer_cb(1:ncol,1:pver,:,lchnk) = 0.0_r8 - do m=1,nmodes_oslo - do n=1,getNumberOfTracersInMode(m) - kk=getTracerIndex(m,n,.false.)! This gives the tracer index used in the q-array - qqcw(kk)%fldcw => qqcw_get_field(pbuf,kk,lchnk,.TRUE.) - if(associated(qqcw(kk)%fldcw))then - aer_cb(:,:,kk,lchnk) = qqcw(kk)%fldcw - end if - end do - end do - -end subroutine hetfrz_classnuc_oslo_save_cbaero - -!==================================================================================================== - -subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input - f_acm, f_condm, & - cam, volumeCore, volumeCoat, & - total_aer_num, & ! output - coated_aer_num, & - uncoated_aer_num, & - total_interstial_aer_num, & - total_cloudborne_aer_num, & - hetraer, awcam, awfacm, dstcoat, & - !++ wy4.0 - na500, tot_na500) - !-- wy4.0 - - use spmd_utils, only: iam - use shr_kind_mod, only: r8 => shr_kind_r8 - ! use ppgrid, only : pcols, pver - use constituents, only: pcnst - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only:MODE_IDX_DST_A2, MODE_IDX_DST_A3, & - l_dst_a2, l_dst_a3, l_bc_ai, & - MODE_IDX_OMBC_INTMIX_COAT_AIT, l_bc_ac, & - lifeCycleNumberMedianRadius, & - lifeCycleSigma + end associate + end subroutine hetfrz_classnuc_oslo_calc - implicit none + !==================================================================================================== + + subroutine hetfrz_classnuc_oslo_save_cbaero(state, pbuf) + + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only: getTracerIndex, getNumberOfTracersInMode + use aerosoldef, only: qqcw_get_field + + ! Save the required cloud borne aerosol constituents. + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + + ! local variables + integer :: i, lchnk, kk, ncol, m, n + real(r8), pointer :: ptr2d(:,:) + type qqcw_type + real(r8), pointer :: fldcw(:,:) + end type qqcw_type + type(qqcw_type) :: qqcw(pcnst) + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + ! loop over the cloud borne constituents required by this module and save + ! a local copy + + aer_cb(1:ncol,1:pver,:,lchnk) = 0.0_r8 + do m=1,nmodes_oslo + do n=1,getNumberOfTracersInMode(m) + kk=getTracerIndex(m,n,.false.)! This gives the tracer index used in the q-array + qqcw(kk)%fldcw => qqcw_get_field(pbuf,kk) + if(associated(qqcw(kk)%fldcw))then + aer_cb(:,:,kk,lchnk) = qqcw(kk)%fldcw + end if + end do + end do + end subroutine hetfrz_classnuc_oslo_save_cbaero + + !==================================================================================================== + + subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input + f_acm, f_condm, & + cam, volumeCore, volumeCoat, & + total_aer_num, & ! output + coated_aer_num, & + uncoated_aer_num, & + total_interstial_aer_num, & + total_cloudborne_aer_num, & + hetraer, awcam, awfacm, dstcoat, & + !++ wy4.0 + na500, tot_na500) + !-- wy4.0 + + use spmd_utils, only: iam + use shr_kind_mod, only: r8 => shr_kind_r8 + ! use ppgrid, only : pcols, pver + use constituents, only: pcnst + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only:MODE_IDX_DST_A2, MODE_IDX_DST_A3, & + l_dst_a2, l_dst_a3, l_bc_ai, & + MODE_IDX_OMBC_INTMIX_COAT_AIT, l_bc_ac, & + lifeCycleNumberMedianRadius, & + lifeCycleSigma + + + implicit none + + ! input + real(r8), intent(in) :: qaerpt(0:nmodes_oslo) ! aerosol number and mass mixing ratios(instertitial) + real(r8), intent(in) :: qaercwpt(0:nmodes_oslo) ! cloud borne aerosol number and mass mixing ratios + real(r8), intent(in) :: rhoair ! air density (kg/m3) + real(r8), intent(in) :: f_acm(nmodes_oslo) + real(r8), intent(in) :: f_condm(nmodes_oslo) + real(r8), intent(in) :: cam(nmodes_oslo) + real(r8), intent(in) :: volumeCoat(nmodes_oslo) + real(r8), intent(in) :: volumeCore(nmodes_oslo) + real(r8) :: sigmag_amode(3) + + + ! output + real(r8), intent(out) :: total_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: total_interstial_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: total_cloudborne_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: uncoated_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: hetraer(3) ! BC and Dust mass mean radius [m] + real(r8), intent(out) :: awcam(3) ! modal added mass [mug m-3] + real(r8), intent(out) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) + real(r8), intent(out) :: dstcoat(3) ! coated fraction + real(r8), intent(out) :: na500 ! #/cm^3 interstitial aerosol number with D>500 nm (#/cm^3) + real(r8), intent(out) :: tot_na500 ! #/cm^3 total aerosol number with D>500 nm (#/cm^3) + !local variables + !------------coated variables-------------------- + real(r8), parameter :: n_so4_monolayers_dust = 1.0_r8 ! number of so4(+nh4) monolayers needed to coat a dust particle + real(r8), parameter :: dr_so4_monolayers_dust = n_so4_monolayers_dust * 4.76e-10 + real(r8) :: tmp1, tmp2 + + real(r8) :: bc_num ! bc number in accumulation mode + real(r8) :: dst1_num, dst3_num ! dust number in accumulation and corase mode + real(r8) :: dst1_num_imm, dst3_num_imm, bc_num_imm + real(r8) :: fac_volsfc_bc, fac_volsfc_dust_a1, fac_volsfc_dust_a3 + + real(r8) :: r_bc ! model radii of BC modes [m] + real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] + + integer :: i + + integer :: num_bc_idx, num_dst1_idx, num_dst3_idx ! mode indices + + num_bc_idx = MODE_IDX_OMBC_INTMIX_COAT_AIT + num_dst1_idx = MODE_IDX_DST_A2 + num_dst3_idx = MODE_IDX_DST_A3 + + + !***************************************************************************** + ! calculate intersitial aerosol + !***************************************************************************** + + dst1_num = qaerpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 + dst3_num = qaerpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 + bc_num = qaerpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 + + + !***************************************************************************** + ! calculate cloud borne aerosol + !***************************************************************************** + + dst1_num_imm = qaercwpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 + dst3_num_imm = qaercwpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 + bc_num_imm = qaercwpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 + + ! calculate mass mean radius + r_dust_a1 = lifeCycleNumberMedianRadius(num_dst1_idx) + r_dust_a3 = lifeCycleNumberMedianRadius(num_dst3_idx) + r_bc = lifeCycleNumberMedianRadius(num_bc_idx) + + hetraer(1) = r_bc + hetraer(2) = r_dust_a1 + hetraer(3) = r_dust_a3 + + + !***************************************************************************** + ! calculate coated fraction + !***************************************************************************** + + ! volumeCore and volumeCoat from subroutine calculateHygroscopicity in paramix_progncdnc.f90 + + sigmag_amode(1) = lifeCycleSigma(num_bc_idx) + sigmag_amode(2) = lifeCycleSigma(num_dst1_idx) + sigmag_amode(3) = lifeCycleSigma(num_dst3_idx) + + fac_volsfc_bc = exp(2.5*(log(sigmag_amode(1))**2)) + fac_volsfc_dust_a1 = exp(2.5*(log(sigmag_amode(2))**2)) + fac_volsfc_dust_a3 = exp(2.5*(log(sigmag_amode(3))**2)) + + tmp1 = volumeCoat(num_bc_idx)*(r_bc*2._r8)*fac_volsfc_bc + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_bc_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 + dstcoat(1) = tmp1/tmp2 + + tmp1 = volumeCoat(num_dst1_idx)*(r_dust_a1*2._r8)*fac_volsfc_dust_a1 + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst1_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 + dstcoat(2) = tmp1/tmp2 + + tmp1 = volumeCoat(num_dst3_idx)*(r_dust_a3*2._r8)*fac_volsfc_dust_a3 + tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst3_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 + dstcoat(3) = tmp1/tmp2 + + if (dstcoat(1) > 1._r8) dstcoat(1) = 1._r8 + if (dstcoat(1) < 0.001_r8) dstcoat(1) = 0.001_r8 + if (dstcoat(2) > 1._r8) dstcoat(2) = 1._r8 + if (dstcoat(2) < 0.001_r8) dstcoat(2) = 0.001_r8 + if (dstcoat(3) > 1._r8) dstcoat(3) = 1._r8 + if (dstcoat(3) < 0.001_r8) dstcoat(3) = 0.001_r8 + + !***************************************************************************** + ! prepare some variables for water activity + !***************************************************************************** + ! cam ([kg/m3] added mass distributed to modes) from paramix_progncdnc.f90 + + ! accumulation mode for dust_a1 + if (qaerpt(num_dst1_idx) > 0._r8) then + awcam(2) = cam(num_dst1_idx)*1.e9_r8 ! kg/m3 -> ug/m3 + else + awcam(2) = 0._r8 + end if + if (awcam(2) >0._r8) then + awfacm(2) = f_acm(num_dst1_idx) + else + awfacm(2) = 0._r8 + end if + + ! accumulation mode for dust_a3 + if (qaerpt(num_dst3_idx) > 0._r8) then + awcam(3) = cam(num_dst3_idx)*1.e9_r8 ! kg/m3 -> ug/m3 + else + awcam(3) = 0._r8 + end if + if (awcam(3) >0._r8) then + awfacm(3) = f_acm(num_dst3_idx) + else + awfacm(3) = 0._r8 + end if + + + ! accumulation mode for bc + if (qaerpt(num_bc_idx) > 0._r8) then + awcam(1) = cam(num_bc_idx)*1.e9_r8 ! kg/m3 -> ug/m3 + else + awcam(1) = 0._r8 + end if + if (awcam(1) >0._r8) then + awfacm(1) = f_acm(num_bc_idx) + else + awfacm(1) = 0._r8 + end if + + !***************************************************************************** + ! prepare output + !***************************************************************************** + + total_interstial_aer_num(1) = bc_num + total_interstial_aer_num(2) = dst1_num + total_interstial_aer_num(3) = dst3_num + + total_cloudborne_aer_num(1) = bc_num_imm + total_cloudborne_aer_num(2) = dst1_num_imm + total_cloudborne_aer_num(3) = dst3_num_imm + + do i = 1, 3 + total_aer_num(i) = total_interstial_aer_num(i)+total_cloudborne_aer_num(i) + coated_aer_num(i) = total_interstial_aer_num(i)*dstcoat(i) + uncoated_aer_num(i) = total_interstial_aer_num(i)*(1._r8-dstcoat(i)) + end do + + + tot_na500 = total_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 + +total_aer_num(3) + + na500 = total_interstial_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 + +total_interstial_aer_num(3) - ! input - real(r8), intent(in) :: qaerpt(0:nmodes_oslo) ! aerosol number and mass mixing ratios(instertitial) - real(r8), intent(in) :: qaercwpt(0:nmodes_oslo) ! cloud borne aerosol number and mass mixing ratios - real(r8), intent(in) :: rhoair ! air density (kg/m3) - real(r8), intent(in) :: f_acm(nmodes_oslo) - real(r8), intent(in) :: f_condm(nmodes_oslo) - real(r8), intent(in) :: cam(nmodes_oslo) - real(r8), intent(in) :: volumeCoat(nmodes_oslo) - real(r8), intent(in) :: volumeCore(nmodes_oslo) - real(r8) :: sigmag_amode(3) - - - ! output - real(r8), intent(out) :: total_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: total_interstial_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: total_cloudborne_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: uncoated_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: hetraer(3) ! BC and Dust mass mean radius [m] - real(r8), intent(out) :: awcam(3) ! modal added mass [mug m-3] - real(r8), intent(out) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) - real(r8), intent(out) :: dstcoat(3) ! coated fraction - real(r8), intent(out) :: na500 ! #/cm^3 interstitial aerosol number with D>500 nm (#/cm^3) - real(r8), intent(out) :: tot_na500 ! #/cm^3 total aerosol number with D>500 nm (#/cm^3) - !local variables - !------------coated variables-------------------- - real(r8), parameter :: n_so4_monolayers_dust = 1.0_r8 ! number of so4(+nh4) monolayers needed to coat a dust particle - real(r8), parameter :: dr_so4_monolayers_dust = n_so4_monolayers_dust * 4.76e-10 - real(r8) :: tmp1, tmp2 - - real(r8) :: bc_num ! bc number in accumulation mode - real(r8) :: dst1_num, dst3_num ! dust number in accumulation and corase mode - real(r8) :: dst1_num_imm, dst3_num_imm, bc_num_imm - real(r8) :: fac_volsfc_bc, fac_volsfc_dust_a1, fac_volsfc_dust_a3 - - real(r8) :: r_bc ! model radii of BC modes [m] - real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] - - integer :: i - - integer :: num_bc_idx, num_dst1_idx, num_dst3_idx ! mode indices - - num_bc_idx = MODE_IDX_OMBC_INTMIX_COAT_AIT - num_dst1_idx = MODE_IDX_DST_A2 - num_dst3_idx = MODE_IDX_DST_A3 - - - !***************************************************************************** - ! calculate intersitial aerosol - !***************************************************************************** - - dst1_num = qaerpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 - dst3_num = qaerpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 - bc_num = qaerpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - - - !***************************************************************************** - ! calculate cloud borne aerosol - !***************************************************************************** - - dst1_num_imm = qaercwpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 - dst3_num_imm = qaercwpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 - bc_num_imm = qaercwpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - - ! calculate mass mean radius - r_dust_a1 = lifeCycleNumberMedianRadius(num_dst1_idx) - r_dust_a3 = lifeCycleNumberMedianRadius(num_dst3_idx) - r_bc = lifeCycleNumberMedianRadius(num_bc_idx) - - hetraer(1) = r_bc - hetraer(2) = r_dust_a1 - hetraer(3) = r_dust_a3 - - - !***************************************************************************** - ! calculate coated fraction - !***************************************************************************** - - ! volumeCore and volumeCoat from subroutine calculateHygroscopicity in paramix_progncdnc.f90 - - sigmag_amode(1) = lifeCycleSigma(num_bc_idx) - sigmag_amode(2) = lifeCycleSigma(num_dst1_idx) - sigmag_amode(3) = lifeCycleSigma(num_dst3_idx) - - fac_volsfc_bc = exp(2.5*(log(sigmag_amode(1))**2)) - fac_volsfc_dust_a1 = exp(2.5*(log(sigmag_amode(2))**2)) - fac_volsfc_dust_a3 = exp(2.5*(log(sigmag_amode(3))**2)) - - tmp1 = volumeCoat(num_bc_idx)*(r_bc*2._r8)*fac_volsfc_bc - tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_bc_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 - dstcoat(1) = tmp1/tmp2 - - tmp1 = volumeCoat(num_dst1_idx)*(r_dust_a1*2._r8)*fac_volsfc_dust_a1 - tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst1_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 - dstcoat(2) = tmp1/tmp2 - - tmp1 = volumeCoat(num_dst3_idx)*(r_dust_a3*2._r8)*fac_volsfc_dust_a3 - tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst3_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 - dstcoat(3) = tmp1/tmp2 - - if (dstcoat(1) > 1._r8) dstcoat(1) = 1._r8 - if (dstcoat(1) < 0.001_r8) dstcoat(1) = 0.001_r8 - if (dstcoat(2) > 1._r8) dstcoat(2) = 1._r8 - if (dstcoat(2) < 0.001_r8) dstcoat(2) = 0.001_r8 - if (dstcoat(3) > 1._r8) dstcoat(3) = 1._r8 - if (dstcoat(3) < 0.001_r8) dstcoat(3) = 0.001_r8 - - !***************************************************************************** - ! prepare some variables for water activity - !***************************************************************************** - ! cam ([kg/m3] added mass distributed to modes) from paramix_progncdnc.f90 - - ! accumulation mode for dust_a1 - if (qaerpt(num_dst1_idx) > 0._r8) then - awcam(2) = cam(num_dst1_idx)*1.e9_r8 ! kg/m3 -> ug/m3 - else - awcam(2) = 0._r8 - end if - if (awcam(2) >0._r8) then - awfacm(2) = f_acm(num_dst1_idx) - else - awfacm(2) = 0._r8 - end if - - ! accumulation mode for dust_a3 - if (qaerpt(num_dst3_idx) > 0._r8) then - awcam(3) = cam(num_dst3_idx)*1.e9_r8 ! kg/m3 -> ug/m3 - else - awcam(3) = 0._r8 - end if - if (awcam(3) >0._r8) then - awfacm(3) = f_acm(num_dst3_idx) - else - awfacm(3) = 0._r8 - end if - - - ! accumulation mode for bc - if (qaerpt(num_bc_idx) > 0._r8) then - awcam(1) = cam(num_bc_idx)*1.e9_r8 ! kg/m3 -> ug/m3 - else - awcam(1) = 0._r8 - end if - if (awcam(1) >0._r8) then - awfacm(1) = f_acm(num_bc_idx) - else - awfacm(1) = 0._r8 - end if - - - !***************************************************************************** - ! prepare output - !***************************************************************************** - - total_interstial_aer_num(1) = bc_num - total_interstial_aer_num(2) = dst1_num - total_interstial_aer_num(3) = dst3_num - - total_cloudborne_aer_num(1) = bc_num_imm - total_cloudborne_aer_num(2) = dst1_num_imm - total_cloudborne_aer_num(3) = dst3_num_imm - - do i = 1, 3 - total_aer_num(i) = total_interstial_aer_num(i)+total_cloudborne_aer_num(i) - coated_aer_num(i) = total_interstial_aer_num(i)*dstcoat(i) - uncoated_aer_num(i) = total_interstial_aer_num(i)*(1._r8-dstcoat(i)) - end do - - - tot_na500 = total_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 - +total_aer_num(3) - - na500 = total_interstial_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 - +total_interstial_aer_num(3) - -end subroutine get_aer_num + end subroutine get_aer_num end module hetfrz_classnuc_oslo diff --git a/src/physics/cam_oslo/microp_aero.F90 b/src/physics/cam_oslo/microp_aero.F90 index 6086b59139..b0bf597d53 100644 --- a/src/physics/cam_oslo/microp_aero.F90 +++ b/src/physics/cam_oslo/microp_aero.F90 @@ -21,31 +21,26 @@ module microp_aero ! !--------------------------------------------------------------------------------- - use shr_kind_mod, only: r8=>shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, pverp - use ref_pres, only: top_lev => trop_cloud_top_lev - use physconst, only: rair - use constituents, only: cnst_get_ind - use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum, & - physics_state_copy, physics_update - use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field - use phys_control, only: phys_getopts, use_hetfrz_classnuc - use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, & - rad_cnst_get_mode_num - - use ndrop, only: ndrop_init, dropmixnuc - use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn - - use cam_history, only: addfld, add_default, outfld - use cam_logfile, only: iulog - use cam_abortutils, only: endrun + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp + use ref_pres, only: top_lev => trop_cloud_top_lev + use physconst, only: rair + use constituents, only: cnst_get_ind + use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum + use physics_types, only: physics_state_copy, physics_update + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field + use phys_control, only: phys_getopts, use_hetfrz_classnuc + use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, rad_cnst_get_mode_num + use ndrop, only: ndrop_init, dropmixnuc + use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn + use cam_history, only: addfld, add_default, outfld + use cam_logfile, only: iulog use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC & - ,MODE_IDX_OMBC_INTMIX_COAT_AIT, lifeCycleNumberMedianRadius, & - l_dst_a2, l_dst_a3, l_bc_ai, getNumberOfTracersInMode, & - getTracerIndex, getCloudTracerIndex - use oslo_utils, only: CalculateNumberConcentration + use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC, MODE_IDX_OMBC_INTMIX_COAT_AIT + use aerosoldef, only: lifeCycleNumberMedianRadius, l_dst_a2, l_dst_a3, l_bc_ai + use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex, getCloudTracerIndex + use oslo_utils, only: CalculateNumberConcentration use parmix_progncdnc use hetfrz_classnuc_oslo use nucleate_ice_oslo @@ -161,8 +156,7 @@ subroutine microp_aero_init !----------------------------------------------------------------------- ! Query the PBL eddy scheme - call phys_getopts(eddy_scheme_out = eddy_scheme, & - history_amwg_out = history_amwg ) + call phys_getopts(eddy_scheme_out=eddy_scheme, history_amwg_out=history_amwg ) ! Access the physical properties of the aerosols that are affecting the climate ! by using routines from the rad_constituents module. @@ -189,16 +183,14 @@ subroutine microp_aero_init ast_idx = pbuf_get_index('AST') - cldo_idx = pbuf_get_index('CLDO') + cldo_idx = pbuf_get_index('CLDO') clim_modal_aero = .true. !Needed to avoid ending up in BAM routines call ndrop_init() call addfld('LCLOUD', (/ 'lev' /), 'A', ' ', 'Liquid cloud fraction used in stratus activation') - call addfld('WSUB', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity' ) call addfld('WSUBI', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity for ice' ) - if (history_amwg) then call add_default ('WSUB ', 1, ' ') end if @@ -212,8 +204,8 @@ end subroutine microp_aero_init subroutine microp_aero_readnl(nlfile) - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit + use namelist_utils, only: find_group_name + use cam_abortutils, only: endrun use mpishorthand character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input @@ -229,8 +221,7 @@ subroutine microp_aero_readnl(nlfile) !----------------------------------------------------------------------------- if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) + open(newunit=unitn, file=trim(nlfile), status='old' ) call find_group_name(unitn, 'microp_aero_nl', status=ierr) if (ierr == 0) then read(unitn, microp_aero_nl, iostat=ierr) @@ -239,9 +230,7 @@ subroutine microp_aero_readnl(nlfile) end if end if close(unitn) - call freeunit(unitn) end if - #ifdef SPMD ! Broadcast namelist variable call mpibcast(microp_aero_bulk_scale, 1, mpir8, 0, mpicom) @@ -256,7 +245,6 @@ subroutine microp_aero_readnl(nlfile) end subroutine microp_aero_readnl !========================================================================================= - subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) ! arguments @@ -318,12 +306,8 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) real(r8) :: wsub(pcols,pver) ! diagnosed sub-grid vertical velocity st. dev. (m/s) real(r8) :: wsubi(pcols,pver) ! diagnosed sub-grid vertical velocity ice (m/s) real(r8) :: nucboas - real(r8) :: wght - - integer :: lchnk, ncol - - !++ MH_2015/04/10 + integer :: lchnk, ncol real(r8) :: factnum(pcols,pver,0:nmodes_oslo) ! activation fraction for aerosol number type qqcw_type real(r8), pointer :: fldcw(:,:) @@ -363,7 +347,7 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) ncol = state1%ncol itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) call pbuf_get_field(pbuf, npccn_idx, npccn) call pbuf_get_field(pbuf, nacon_idx, nacon) call pbuf_get_field(pbuf, rndst_idx, rndst) @@ -456,7 +440,7 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) if (trim(eddy_scheme) == 'CLUBB_SGS') deallocate(tke) - !Get size distributed interstitial aerosol + ! Get size distributed interstitial aerosol call parmix_progncdnc_sub( & ncol & !I [nbr] number of columns used ,state%q & !I [kg/kg] mass mixing ratio of tracers diff --git a/src/physics/cam_oslo/modal_aero_data.F90 b/src/physics/cam_oslo/modal_aero_data.F90 deleted file mode 100644 index e62b884de7..0000000000 --- a/src/physics/cam_oslo/modal_aero_data.F90 +++ /dev/null @@ -1,64 +0,0 @@ - module modal_aero_data - -!-------------------------------------------------------------- -! ... Basic aerosol mode parameters and arrays -!-------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst - use radconstants, only: nswbands, nlwbands - - implicit none - save - - integer, parameter :: ntot_amode = 0 - - integer, private :: qqcw(pcnst)=-1 ! Remaps modal_aero indices into pbuf - - contains - - subroutine qqcw_set_ptr(index, iptr) - use cam_abortutils, only : endrun - - - integer, intent(in) :: index, iptr - - if(index>0 .and. index <= pcnst ) then - qqcw(index)=iptr - else - call endrun('qqcw_set_ptr: attempting to set qqcw pointer already defined') - end if - end subroutine qqcw_set_ptr - -!-------------------------------------------------------------- -!-------------------------------------------------------------- - function qqcw_get_field(pbuf, index, lchnk, errorhandle) - use cam_abortutils, only : endrun - use physics_buffer, only : physics_buffer_desc, pbuf_get_field - - integer, intent(in) :: index, lchnk - real(r8), pointer :: qqcw_get_field(:,:) - logical, optional :: errorhandle - type(physics_buffer_desc), pointer :: pbuf(:) - - logical :: error - - nullify(qqcw_get_field) - error = .false. - if (index>0 .and. index <= pcnst) then - if (qqcw(index)>0) then - call pbuf_get_field(pbuf, qqcw(index), qqcw_get_field) - else - error = .true. - endif - else - error = .true. - end if - - if (error .and. .not. present(errorhandle)) then - call endrun('qqcw_get_field: attempt to access undefined qqcw') - end if - - end function qqcw_get_field - - end module modal_aero_data - From f1d822bad81958eb20ef5ee3aef7652fe42b4ec1 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 28 Aug 2023 20:01:23 +0200 Subject: [PATCH 21/71] moved hetfrz to this directory --- .../cam_oslo => chemistry/oslo_aero}/hetfrz_classnuc_oslo.F90 | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/{physics/cam_oslo => chemistry/oslo_aero}/hetfrz_classnuc_oslo.F90 (100%) diff --git a/src/physics/cam_oslo/hetfrz_classnuc_oslo.F90 b/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 similarity index 100% rename from src/physics/cam_oslo/hetfrz_classnuc_oslo.F90 rename to src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 From 669f3b4321ea5b910fbd973286f027e209bf8173 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 28 Aug 2023 21:53:21 +0200 Subject: [PATCH 22/71] more refactorization of hetfrz_classnuc_oslo.F90 --- .../oslo_aero/hetfrz_classnuc_oslo.F90 | 967 ++++++++++++++---- 1 file changed, 747 insertions(+), 220 deletions(-) diff --git a/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 b/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 index 71a78f7f01..529d30eb79 100644 --- a/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 +++ b/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 @@ -13,32 +13,26 @@ module hetfrz_classnuc_oslo use constituents, only: cnst_get_ind, pcnst use physics_types, only: physics_state use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field + use physics_buffer, only: pbuf_add_field, dtype_r8 use phys_control, only: phys_getopts, use_hetfrz_classnuc - - use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, & - pbuf_get_index, pbuf_get_field use cam_history, only: addfld, add_default, outfld - use ref_pres, only: top_lev => trop_cloud_top_lev use wv_saturation, only: svp_water, svp_ice - use cam_logfile, only: iulog use error_messages, only: handle_errmsg, alloc_err use cam_abortutils, only: endrun - - use hetfrz_classnuc, only: hetfrz_classnuc_init, hetfrz_classnuc_calc - use oslo_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius - use aerosoldef, only : MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT + use oslo_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius + use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT implicit none private - public :: & - hetfrz_classnuc_oslo_readnl, & - hetfrz_classnuc_oslo_register, & - hetfrz_classnuc_oslo_init, & - hetfrz_classnuc_oslo_calc, & - hetfrz_classnuc_oslo_save_cbaero + ! The following are called by microp_aero + public :: hetfrz_classnuc_oslo_readnl + public :: hetfrz_classnuc_oslo_register + public :: hetfrz_classnuc_oslo_init + public :: hetfrz_classnuc_oslo_calc + public :: hetfrz_classnuc_oslo_save_cbaero ! Namelist variables logical :: hist_hetfrz_classnuc = .false. @@ -47,68 +41,32 @@ module hetfrz_classnuc_oslo real(r8) :: mincld ! minimum allowed cloud fraction ! constituent indices - integer :: & - cldliq_idx = -1, & - cldice_idx = -1, & - numliq_idx = -1, & - numice_idx = -1 + integer :: cldliq_idx = -1 + integer :: cldice_idx = -1 + integer :: numliq_idx = -1 + integer :: numice_idx = -1 ! pbuf indices for fields provided by heterogeneous freezing - integer :: & - frzimm_idx, & - frzcnt_idx, & - frzdep_idx + integer :: frzimm_idx + integer :: frzcnt_idx + integer :: frzdep_idx ! pbuf indices for fields needed by heterogeneous freezing - integer :: & - ast_idx = -1 - - ! specie properties - real(r8) :: specdens_dust - real(r8) :: specdens_so4 - real(r8) :: specdens_bc - real(r8) :: specdens_soa - real(r8) :: specdens_pom - - ! List all species - integer :: ncnst = 0 ! Total number of constituents (mass and number) needed - ! by the parameterization (depends on aerosol model used) - - integer :: so4_accum ! sulfate in accumulation mode - integer :: bc_accum ! black-c in accumulation mode - integer :: pom_accum ! p-organic in accumulation mode - integer :: soa_accum ! s-organic in accumulation mode - integer :: dst_accum ! dust in accumulation mode - integer :: ncl_accum ! seasalt in accumulation mode - integer :: num_accum ! number in accumulation mode - - integer :: dst_coarse ! dust in coarse mode - integer :: ncl_coarse ! seasalt in coarse mode - integer :: so4_coarse ! sulfate in coarse mode - integer :: num_coarse ! number in coarse mode - - integer :: dst_finedust ! dust in finedust mode - integer :: so4_finedust ! sulfate in finedust mode - integer :: num_finedust ! number in finedust mode - - integer :: dst_coardust ! dust in coardust mode - integer :: so4_coardust ! sulfate in coardust mode - integer :: num_coardust ! number in coardust mode - - integer :: bc_pcarbon ! black-c in primary carbon mode - integer :: pom_pcarbon ! p-organic in primary carbon mode - integer :: num_pcarbon ! number in primary carbon mode - - ! Index arrays for looping over all constituents - integer, allocatable :: mode_idx(:) - integer, allocatable :: spec_idx(:) + integer :: ast_idx = -1 ! Copy of cloud borne aerosols before modification by droplet nucleation ! The basis is converted from mass to volume. real(r8), allocatable :: aer_cb(:,:,:,:) - ! Copy of interstitial aerosols with basis converted from mass to volume. - real(r8), allocatable :: aer(:,:,:,:) + logical :: pdf_imm_in = .true. + integer, parameter :: pdf_n_theta = 301 + integer, parameter :: i1 = 53 + integer, parameter :: i2 = 113 + real(r8) :: dim_theta(pdf_n_theta) = 0.0_r8 + real(r8) :: pdf_imm_theta(pdf_n_theta) = 0.0_r8 + real(r8) :: pdf_d_theta + real(r8) :: dim_f_imm_dust_a1(pdf_n_theta) = 0.0_r8 + real(r8) :: dim_f_imm_dust_a3(pdf_n_theta) = 0.0_r8 !=============================================================================== contains @@ -117,7 +75,6 @@ module hetfrz_classnuc_oslo subroutine hetfrz_classnuc_oslo_readnl(nlfile) use namelist_utils, only: find_group_name - use units, only: getunit, freeunit use mpishorthand character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input @@ -127,12 +84,10 @@ subroutine hetfrz_classnuc_oslo_readnl(nlfile) character(len=*), parameter :: subname = 'hetfrz_classnuc_cam_readnl' namelist /hetfrz_classnuc_nl/ hist_hetfrz_classnuc - !----------------------------------------------------------------------------- if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) + open( newunit=unitn, file=trim(nlfile), status='old' ) call find_group_name(unitn, 'hetfrz_classnuc_nl', status=ierr) if (ierr == 0) then read(unitn, hetfrz_classnuc_nl, iostat=ierr) @@ -141,10 +96,7 @@ subroutine hetfrz_classnuc_oslo_readnl(nlfile) end if end if close(unitn) - call freeunit(unitn) - end if - #ifdef SPMD ! Broadcast namelist variables call mpibcast(hist_hetfrz_classnuc, 1, mpilog, 0, mpicom) @@ -172,20 +124,16 @@ subroutine hetfrz_classnuc_oslo_init(mincld_in) real(r8), intent(in) :: mincld_in ! local variables - logical :: prog_modal_aero integer :: m, n, nspec integer :: istat - real(r8) :: sigma_logr_aer - character(len=32) :: str32 character(len=*), parameter :: routine = 'hetfrz_classnuc_cam_init' !-------------------------------------------------------------------------------------------- - if (.not. use_hetfrz_classnuc) return - ! This parameterization currently assumes that prognostic modal aerosols are on. Check... - call phys_getopts(prog_modal_aero_out=prog_modal_aero) + + if (.not. use_hetfrz_classnuc) return mincld = mincld_in @@ -195,7 +143,7 @@ subroutine hetfrz_classnuc_oslo_init(mincld_in) call cnst_get_ind('NUMICE', numice_idx) ! pbuf fields used by hetfrz_classnuc - ast_idx = pbuf_get_index('AST') + ast_idx = pbuf_get_index('AST') call addfld('bc_num', (/ 'lev' /), 'A', '#/cm3', 'total bc number') call addfld('dst1_num', (/ 'lev' /), 'A', '#/cm3', 'total dst1 number') @@ -302,7 +250,7 @@ subroutine hetfrz_classnuc_oslo_init(mincld_in) call add_default('BCFREZDEP', 1, ' ') call add_default('NIMIX_IMM', 1, ' ') - call add_default('NIMIX_CNT', 1, ' ') + call add_default('NIMIX_CNT', 1, ' ') call add_default('NIMIX_DEP', 1, ' ') call add_default('DSTNIDEP', 1, ' ') @@ -331,21 +279,27 @@ subroutine hetfrz_classnuc_oslo_init(mincld_in) ! Allocate space for copy of cloud borne aerosols before modification by droplet nucleation. allocate(aer_cb(pcols,pver,pcnst,begchunk:endchunk), stat=istat) - call alloc_err(istat, routine, 'aer_cb', pcols*pver*ncnst*(endchunk-begchunk+1)) - - ! Allocate space for copy of interstitial aerosols with modified basis - allocate(aer(pcols,pver,pcnst,begchunk:endchunk), stat=istat) - call alloc_err(istat, routine, 'aer', pcols*pver*ncnst*(endchunk-begchunk+1)) - call hetfrz_classnuc_init( & - rair, cpair, rh2o, rhoh2o, mwh2o, & - tmelt, pi, iulog) + call alloc_err(istat, routine, 'aer_cb', pcols*pver*pcnst*(endchunk-begchunk+1)) + + ! Initialize all the PDF theta variables: + ! With the original value of pdf_n_theta set to 101 the dust activation + ! fraction between -15 and 0 C could be overestimated. This problem was + ! eliminated by increasing pdf_n_theta to 301. To reduce the expense of + ! computing the dust activation fraction the integral is only evaluated + ! where dim_theta is non-zero. This was determined to be between + ! dim_theta index values of 53 through 113. These loop bounds are + ! hardcoded in the variables i1 and i2. + + if (pdf_imm_in) then + call hetfrz_classnuc_init_pdftheta() + end if end subroutine hetfrz_classnuc_oslo_init !================================================================================================ - subroutine hetfrz_classnuc_oslo_calc( & - state, deltatin, factnum, pbuf, & + subroutine hetfrz_classnuc_oslo_calc( & + state, deltatin, factnum, pbuf, & numberConcentration, volumeConcentration, & f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) @@ -354,44 +308,32 @@ subroutine hetfrz_classnuc_oslo_calc( & use aerosoldef, only : getNumberOfTracersInMode, getTracerIndex ! arguments - type(physics_state), target, intent(in) :: state - real(r8), intent(in) :: deltatin ! time step (s) - real(r8), intent(in) :: factnum(:,:,:) ! activation fraction for aerosol number - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes_oslo) - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes_oslo) - - real(r8),intent(in) :: f_acm(pcols,pver, nmodes_oslo) - real(r8),intent(in) :: f_bcm(pcols,pver, nmodes_oslo) - real(r8),intent(in) :: f_aqm(pcols, pver, nmodes_oslo) - real(r8),intent(in) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" - real(r8),intent(in) :: f_soam(pcols, pver, nmodes_oslo) - - real(r8),intent(in) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity - real(r8),intent(in) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma - real(r8),intent(in) :: cam(pcols,pver,nmodes_oslo) - real(r8),intent(in) :: volumeCore(pcols,pver,nmodes_oslo) - real(r8),intent(in) :: volumeCoat(pcols,pver,nmodes_oslo) - - type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_state), target, intent(in) :: state + real(r8), intent(in) :: deltatin ! time step (s) + real(r8), intent(in) :: factnum(:,:,:) ! activation fraction for aerosol number + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes_oslo) + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes_oslo) + real(r8), intent(in) :: f_acm(pcols,pver, nmodes_oslo) + real(r8), intent(in) :: f_bcm(pcols,pver, nmodes_oslo) + real(r8), intent(in) :: f_aqm(pcols, pver, nmodes_oslo) + real(r8), intent(in) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" + real(r8), intent(in) :: f_soam(pcols, pver, nmodes_oslo) + real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity + real(r8), intent(in) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma + real(r8), intent(in) :: cam(pcols,pver,nmodes_oslo) + real(r8), intent(in) :: volumeCore(pcols,pver,nmodes_oslo) + real(r8), intent(in) :: volumeCoat(pcols,pver,nmodes_oslo) ! local workspace - - ! outputs shared with the microphysics via the pbuf - real(r8), pointer :: frzimm(:,:) - real(r8), pointer :: frzcnt(:,:) - real(r8), pointer :: frzdep(:,:) - - integer :: itim_old - integer :: i, k - + real(r8), pointer :: frzimm(:,:) ! output shared with the microphysics via the pbuf + real(r8), pointer :: frzcnt(:,:) ! output shared with the microphysics via the pbuf + real(r8), pointer :: frzdep(:,:) ! output shared with the microphysics via the pbuf + real(r8), pointer :: ast(:,:) + integer :: itim_old + integer :: i, k, n, m, kk real(r8) :: rho(pcols,pver) ! air density (kg m-3) - - real(r8), pointer :: ast(:,:) - real(r8) :: lcldm(pcols,pver) - - real(r8), pointer :: ptr2d(:,:) - real(r8) :: fn(3) real(r8) :: awcam(pcols,pver,3) real(r8) :: awfacm(pcols,pver,3) @@ -402,19 +344,13 @@ subroutine hetfrz_classnuc_oslo_calc( & real(r8) :: total_aer_num(pcols,pver,3) real(r8) :: coated_aer_num(pcols,pver,3) real(r8) :: uncoated_aer_num(pcols,pver,3) - real(r8) :: fn_cloudborne_aer_num(pcols,pver,3) - - real(r8) :: con1, r3lx, supersatice - real(r8) :: qcic real(r8) :: ncic - real(r8) :: frzbcimm(pcols,pver), frzduimm(pcols,pver) real(r8) :: frzbccnt(pcols,pver), frzducnt(pcols,pver) real(r8) :: frzbcdep(pcols,pver), frzdudep(pcols,pver) - real(r8) :: freqimm(pcols,pver), freqcnt(pcols,pver), freqdep(pcols,pver), freqmix(pcols,pver) real(r8) :: nnuccc_bc(pcols,pver), nnucct_bc(pcols,pver), nnudep_bc(pcols,pver) real(r8) :: nnuccc_dst(pcols,pver), nnucct_dst(pcols,pver), nnudep_dst(pcols,pver) @@ -423,19 +359,11 @@ subroutine hetfrz_classnuc_oslo_calc( & real(r8) :: numice10s(pcols,pver) real(r8) :: numice10s_imm_dst(pcols,pver) real(r8) :: numice10s_imm_bc(pcols,pver) - - !++oslo aerosol specific - real(r8) :: qaercwpt(pcols,pver,pcnst) - real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) - real(r8) :: numberMedianRadius(pcols,pver,nmodes_oslo) - !--oslo aerosol specific - + real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) ! oslo aerosol specific + real(r8) :: numberMedianRadius(pcols,pver,nmodes_oslo) ! oslo aerosol specific real(r8) :: na500(pcols,pver) real(r8) :: tot_na500(pcols,pver) - character(128) :: errstring ! Error status - - integer :: n, m, kk !------------------------------------------------------------------------------- associate( & @@ -467,14 +395,6 @@ subroutine hetfrz_classnuc_oslo_calc( & ! being used in get_aer_num do i = 1, pcnst aer_cb(:ncol,:,i,lchnk) = aer_cb(:ncol,:,i,lchnk) * rho(:ncol,:) - - ! Check whether constituent is a mass or number mixing ratio - !if (spec_idx(i) == 0) then - ! call rad_cnst_get_mode_num(0, mode_idx(i), 'a', state, pbuf, ptr2d) - !else - ! call rad_cnst_get_aer_mmr(0, mode_idx(i), spec_idx(i), 'a', state, pbuf, ptr2d) - !end if - !aer(:ncol,:,i,lchnk) = ptr2d(:ncol,:) * rho(:ncol,:) end do ! Init top levels of outputs of get_aer_num @@ -490,7 +410,6 @@ subroutine hetfrz_classnuc_oslo_calc( & na500 = 0._r8 tot_na500 = 0._r8 - !Get estimate of number of aerosols inside clouds call calculateNumberConcentration(ncol, aer_cb, rho, CloudnumberConcentration) call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) @@ -499,18 +418,16 @@ subroutine hetfrz_classnuc_oslo_calc( & ! output aerosols as reference information for heterogeneous freezing do i = 1, ncol do k = top_lev, pver - call get_aer_num(numberConcentration(i,k,:), CloudnumberConcentration(i,k,:), rho(i,k), & - !++ MH_2015/04/10 + call get_aer_num(numberConcentration(i,k,:), CloudnumberConcentration(i,k,:), rho(i,k), & f_acm(i,k,:), f_so4_condm(i,k,:), cam(i,k,:), volumeCore(i,k,:), volumeCoat(i,k,:), & - !-- MH_2015/04/10 total_aer_num(i,k,:), coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), & - total_interstitial_aer_num(i,k,:), total_cloudborne_aer_num(i,k,:), & - hetraer(i,k,:), awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), & + total_interstitial_aer_num(i,k,:), total_cloudborne_aer_num(i,k,:), & + hetraer(i,k,:), awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), & na500(i,k), tot_na500(i,k)) fn_cloudborne_aer_num(i,k,1) = total_aer_num(i,k,1)*factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc - fn_cloudborne_aer_num(i,k,2) = total_aer_num(i,k,2)*factnum(i,k,MODE_IDX_DST_A2) - fn_cloudborne_aer_num(i,k,3) = total_aer_num(i,k,3)*factnum(i,k,MODE_IDX_DST_A3) + fn_cloudborne_aer_num(i,k,2) = total_aer_num(i,k,2)*factnum(i,k,MODE_IDX_DST_A2) + fn_cloudborne_aer_num(i,k,3) = total_aer_num(i,k,3)*factnum(i,k,MODE_IDX_DST_A3) end do end do @@ -594,8 +511,8 @@ subroutine hetfrz_classnuc_oslo_calc( & r3lx = max(4.e-6_r8, r3lx) supersatice = svp_water(t(i,k))/svp_ice(t(i,k)) fn(1) = factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc accumulation mode - fn(2) = factnum(i,k,MODE_IDX_DST_A2) ! dust_a1 accumulation mode - fn(3) = factnum(i,k,MODE_IDX_DST_A3) ! dust_a3 coarse mode + fn(2) = factnum(i,k,MODE_IDX_DST_A2) ! dust_a1 accumulation mode + fn(3) = factnum(i,k,MODE_IDX_DST_A3) ! dust_a3 coarse mode call hetfrz_classnuc_calc( & deltatin, t(i,k), pmid(i,k), supersatice, & @@ -626,7 +543,7 @@ subroutine hetfrz_classnuc_oslo_calc( & nnudep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*ast(i,k) nnuccc_dst(i,k) = frzduimm(i,k)*1.0e6_r8*ast(i,k) - nnucct_dst(i,k) = frzducnt(i,k)*1.0e6_r8*ast(i,k) + nnucct_dst(i,k) = frzducnt(i,k)*1.0e6_r8*ast(i,k) nnudep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*ast(i,k) niimm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin @@ -657,7 +574,7 @@ subroutine hetfrz_classnuc_oslo_calc( & call outfld('BCFREZDEP', nnudep_bc, pcols, lchnk) call outfld('NIMIX_IMM', niimm_bc+niimm_dst, pcols, lchnk) - call outfld('NIMIX_CNT', nicnt_bc+nicnt_dst, pcols, lchnk) + call outfld('NIMIX_CNT', nicnt_bc+nicnt_dst, pcols, lchnk) call outfld('NIMIX_DEP', nidep_bc+nidep_dst, pcols, lchnk) call outfld('DSTNICNT', nicnt_dst, pcols, lchnk) @@ -680,9 +597,9 @@ end subroutine hetfrz_classnuc_oslo_calc subroutine hetfrz_classnuc_oslo_save_cbaero(state, pbuf) - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only: getTracerIndex, getNumberOfTracersInMode - use aerosoldef, only: qqcw_get_field + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only: getTracerIndex, getNumberOfTracersInMode + use aerosoldef, only: qqcw_get_field ! Save the required cloud borne aerosol constituents. type(physics_state), intent(in) :: state @@ -690,23 +607,21 @@ subroutine hetfrz_classnuc_oslo_save_cbaero(state, pbuf) ! local variables integer :: i, lchnk, kk, ncol, m, n - real(r8), pointer :: ptr2d(:,:) type qqcw_type real(r8), pointer :: fldcw(:,:) end type qqcw_type type(qqcw_type) :: qqcw(pcnst) !------------------------------------------------------------------------------- - lchnk = state%lchnk - ncol = state%ncol - ! loop over the cloud borne constituents required by this module and save ! a local copy + lchnk = state%lchnk + ncol = state%ncol aer_cb(1:ncol,1:pver,:,lchnk) = 0.0_r8 do m=1,nmodes_oslo do n=1,getNumberOfTracersInMode(m) - kk=getTracerIndex(m,n,.false.)! This gives the tracer index used in the q-array + kk = getTracerIndex(m,n,.false.)! This gives the tracer index used in the q-array qqcw(kk)%fldcw => qqcw_get_field(pbuf,kk) if(associated(qqcw(kk)%fldcw))then aer_cb(:,:,kk,lchnk) = qqcw(kk)%fldcw @@ -726,41 +641,28 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input total_interstial_aer_num, & total_cloudborne_aer_num, & hetraer, awcam, awfacm, dstcoat, & - !++ wy4.0 na500, tot_na500) - !-- wy4.0 - - use spmd_utils, only: iam - use shr_kind_mod, only: r8 => shr_kind_r8 - ! use ppgrid, only : pcols, pver - use constituents, only: pcnst - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only:MODE_IDX_DST_A2, MODE_IDX_DST_A3, & - l_dst_a2, l_dst_a3, l_bc_ai, & - MODE_IDX_OMBC_INTMIX_COAT_AIT, l_bc_ac, & - lifeCycleNumberMedianRadius, & - lifeCycleSigma - - implicit none + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT + use aerosoldef, only: l_dst_a2, l_dst_a3, l_bc_ai, l_bc_ac + use aerosoldef, only: lifeCycleNumberMedianRadius, lifeCycleSigma ! input - real(r8), intent(in) :: qaerpt(0:nmodes_oslo) ! aerosol number and mass mixing ratios(instertitial) - real(r8), intent(in) :: qaercwpt(0:nmodes_oslo) ! cloud borne aerosol number and mass mixing ratios + real(r8), intent(in) :: qaerpt(0:nmodes_oslo) ! aerosol number and mass mixing ratios(instertitial) + real(r8), intent(in) :: qaercwpt(0:nmodes_oslo) ! cloud borne aerosol number and mass mixing ratios real(r8), intent(in) :: rhoair ! air density (kg/m3) real(r8), intent(in) :: f_acm(nmodes_oslo) real(r8), intent(in) :: f_condm(nmodes_oslo) real(r8), intent(in) :: cam(nmodes_oslo) real(r8), intent(in) :: volumeCoat(nmodes_oslo) real(r8), intent(in) :: volumeCore(nmodes_oslo) - real(r8) :: sigmag_amode(3) - ! output real(r8), intent(out) :: total_aer_num(3) ! #/cm^3 real(r8), intent(out) :: total_interstial_aer_num(3) ! #/cm^3 real(r8), intent(out) :: total_cloudborne_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 + real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 real(r8), intent(out) :: uncoated_aer_num(3) ! #/cm^3 real(r8), intent(out) :: hetraer(3) ! BC and Dust mass mean radius [m] real(r8), intent(out) :: awcam(3) ! modal added mass [mug m-3] @@ -768,47 +670,42 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input real(r8), intent(out) :: dstcoat(3) ! coated fraction real(r8), intent(out) :: na500 ! #/cm^3 interstitial aerosol number with D>500 nm (#/cm^3) real(r8), intent(out) :: tot_na500 ! #/cm^3 total aerosol number with D>500 nm (#/cm^3) - !local variables - !------------coated variables-------------------- + + ! local variables real(r8), parameter :: n_so4_monolayers_dust = 1.0_r8 ! number of so4(+nh4) monolayers needed to coat a dust particle real(r8), parameter :: dr_so4_monolayers_dust = n_so4_monolayers_dust * 4.76e-10 + real(r8) :: sigmag_amode(3) real(r8) :: tmp1, tmp2 - real(r8) :: bc_num ! bc number in accumulation mode real(r8) :: dst1_num, dst3_num ! dust number in accumulation and corase mode real(r8) :: dst1_num_imm, dst3_num_imm, bc_num_imm real(r8) :: fac_volsfc_bc, fac_volsfc_dust_a1, fac_volsfc_dust_a3 - - real(r8) :: r_bc ! model radii of BC modes [m] - real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] - - integer :: i - + real(r8) :: r_bc ! model radii of BC modes [m] + real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] + integer :: i integer :: num_bc_idx, num_dst1_idx, num_dst3_idx ! mode indices num_bc_idx = MODE_IDX_OMBC_INTMIX_COAT_AIT num_dst1_idx = MODE_IDX_DST_A2 num_dst3_idx = MODE_IDX_DST_A3 - !***************************************************************************** - ! calculate intersitial aerosol + ! calculate intersitial aerosol !***************************************************************************** dst1_num = qaerpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 dst3_num = qaerpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 bc_num = qaerpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - !***************************************************************************** - ! calculate cloud borne aerosol + ! calculate cloud borne aerosol !***************************************************************************** dst1_num_imm = qaercwpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 dst3_num_imm = qaercwpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 bc_num_imm = qaercwpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - ! calculate mass mean radius + ! calculate mass mean radius r_dust_a1 = lifeCycleNumberMedianRadius(num_dst1_idx) r_dust_a3 = lifeCycleNumberMedianRadius(num_dst3_idx) r_bc = lifeCycleNumberMedianRadius(num_bc_idx) @@ -817,9 +714,8 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input hetraer(2) = r_dust_a1 hetraer(3) = r_dust_a3 - !***************************************************************************** - ! calculate coated fraction + ! calculate coated fraction !***************************************************************************** ! volumeCore and volumeCoat from subroutine calculateHygroscopicity in paramix_progncdnc.f90 @@ -852,12 +748,12 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input if (dstcoat(3) < 0.001_r8) dstcoat(3) = 0.001_r8 !***************************************************************************** - ! prepare some variables for water activity + ! prepare some variables for water activity !***************************************************************************** ! cam ([kg/m3] added mass distributed to modes) from paramix_progncdnc.f90 - ! accumulation mode for dust_a1 - if (qaerpt(num_dst1_idx) > 0._r8) then + ! accumulation mode for dust_a1 + if (qaerpt(num_dst1_idx) > 0._r8) then awcam(2) = cam(num_dst1_idx)*1.e9_r8 ! kg/m3 -> ug/m3 else awcam(2) = 0._r8 @@ -869,26 +765,25 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input end if ! accumulation mode for dust_a3 - if (qaerpt(num_dst3_idx) > 0._r8) then + if (qaerpt(num_dst3_idx) > 0._r8) then awcam(3) = cam(num_dst3_idx)*1.e9_r8 ! kg/m3 -> ug/m3 else awcam(3) = 0._r8 end if if (awcam(3) >0._r8) then awfacm(3) = f_acm(num_dst3_idx) - else + else awfacm(3) = 0._r8 end if - ! accumulation mode for bc - if (qaerpt(num_bc_idx) > 0._r8) then + if (qaerpt(num_bc_idx) > 0._r8) then awcam(1) = cam(num_bc_idx)*1.e9_r8 ! kg/m3 -> ug/m3 else awcam(1) = 0._r8 end if if (awcam(1) >0._r8) then - awfacm(1) = f_acm(num_bc_idx) + awfacm(1) = f_acm(num_bc_idx) else awfacm(1) = 0._r8 end if @@ -897,12 +792,12 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input ! prepare output !***************************************************************************** - total_interstial_aer_num(1) = bc_num - total_interstial_aer_num(2) = dst1_num - total_interstial_aer_num(3) = dst3_num + total_interstial_aer_num(1) = bc_num + total_interstial_aer_num(2) = dst1_num + total_interstial_aer_num(3) = dst3_num - total_cloudborne_aer_num(1) = bc_num_imm - total_cloudborne_aer_num(2) = dst1_num_imm + total_cloudborne_aer_num(1) = bc_num_imm + total_cloudborne_aer_num(2) = dst1_num_imm total_cloudborne_aer_num(3) = dst3_num_imm do i = 1, 3 @@ -920,4 +815,636 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input end subroutine get_aer_num + !=================================================================================================== + + subroutine hetfrz_classnuc_calc( & + deltat, t, p, supersatice, & + fn, & + r3lx, icnlx, & + frzbcimm, frzduimm, & + frzbccnt, frzducnt, & + frzbcdep, frzdudep, & + hetraer, awcam, awfacm, dstcoat, & + total_aer_num, coated_aer_num, uncoated_aer_num, & + total_interstitial_aer_num, total_cloudborne_aer_num, errstring) + + real(r8), intent(in) :: deltat ! timestep [s] + real(r8), intent(in) :: t ! temperature [K] + real(r8), intent(in) :: p ! pressure [Pa] + real(r8), intent(in) :: supersatice ! supersaturation ratio wrt ice at 100%rh over water [ ] + real(r8), intent(in) :: r3lx ! volume mean drop radius [m] + real(r8), intent(in) :: icnlx ! in-cloud droplet concentration [cm-3] + real(r8), intent(in) :: fn(3) ! fraction activated [ ] for cloud borne aerosol number + ! index values are 1:bc, 2:dust_a1, 3:dust_a3 + real(r8), intent(in) :: hetraer(3) ! bc and dust mass mean radius [m] + real(r8), intent(in) :: awcam(3) ! modal added mass [mug m-3] + real(r8), intent(in) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) + real(r8), intent(in) :: dstcoat(3) ! coated fraction + real(r8), intent(in) :: total_aer_num(3) ! total bc and dust number concentration(interstitial+cloudborne) [#/cm^3] + real(r8), intent(in) :: coated_aer_num(3) ! coated bc and dust number concentration(interstitial) + real(r8), intent(in) :: uncoated_aer_num(3) ! uncoated bc and dust number concentration(interstitial) + real(r8), intent(in) :: total_interstitial_aer_num(3) ! total bc and dust concentration(interstitial) + real(r8), intent(in) :: total_cloudborne_aer_num(3) ! total bc and dust concentration(cloudborne) + real(r8), intent(out) :: frzbcimm ! het. frz by BC immersion nucleation [cm-3 s-1] + real(r8), intent(out) :: frzduimm ! het. frz by dust immersion nucleation [cm-3 s-1] + real(r8), intent(out) :: frzbccnt ! het. frz by BC contact nucleation [cm-3 s-1] + real(r8), intent(out) :: frzducnt ! het. frz by dust contact nucleation [cm-3 s-1] + real(r8), intent(out) :: frzbcdep ! het. frz by BC deposition nucleation [cm-3 s-1] + real(r8), intent(out) :: frzdudep ! het. frz by dust deposition nucleation [cm-3 s-1] + character(len=*), intent(out) :: errstring + + ! local variables + real(r8) , parameter :: Mso4 = 96.06_r8 + integer , parameter :: id_bc = 1 + integer , parameter :: id_dst1 = 2 + integer , parameter :: id_dst3 = 3 + real(r8) , parameter :: n1 = 1.e19_r8 ! number of water molecules in contact with unit area of substrate [m-2] + real(r8) , parameter :: kboltz = 1.38e-23_r8 + real(r8) , parameter :: hplanck = 6.63e-34_r8 + real(r8) , parameter :: rhplanck = 1._r8/hplanck + real(r8) , parameter :: amu = 1.66053886e-27_r8 + real(r8) , parameter :: nus = 1.e13_r8 ! frequ. of vibration [s-1] higher freq. (as in P&K, consistent with Anupam's data) + real(r8) , parameter :: taufrz = 195.435_r8 ! time constant for falloff of freezing rate [s] + real(r8) , parameter :: rhwincloud = 0.98_r8 ! 98% RH in mixed-phase clouds (Korolev & Isaac, JAS 2006) + real(r8) , parameter :: limfacbc = 0.01_r8 ! max. ice nucleating fraction soot + real(r8) :: aw(3) ! water activity [ ] + real(r8) :: molal(3) ! molality [moles/kg] + logical :: do_bc, do_dst1, do_dst3 + real(r8) :: tc + real(r8) :: vwice + real(r8) :: rhoice + real(r8) :: sigma_iw ! [J/m2] + real(r8) :: sigma_iv ! [J/m2] + real(r8) :: esice ! [Pa] + real(r8) :: eswtr ! [Pa] + real(r8) :: rgimm + real(r8) :: rgdep + real(r8) :: dg0dep + real(r8) :: Adep + real(r8) :: dg0cnt + real(r8) :: Acnt + real(r8) :: rgimm_bc + real(r8) :: rgimm_dust_a1, rgimm_dust_a3 + real(r8) :: dg0imm_bc + real(r8) :: dg0imm_dust_a1, dg0imm_dust_a3 + real(r8) :: Aimm_bc + real(r8) :: Aimm_dust_a1, Aimm_dust_a3 + real(r8) :: q, m, phi + real(r8) :: r_bc ! model radii of BC modes [m] + real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] + real(r8) :: f_imm_bc + real(r8) :: f_imm_dust_a1, f_imm_dust_a3 + real(r8) :: Jimm_bc + real(r8) :: Jimm_dust_a1, Jimm_dust_a3 + real(r8) :: f_dep_bc + real(r8) :: f_dep_dust_a1, f_dep_dust_a3 + real(r8) :: Jdep_bc + real(r8) :: Jdep_dust_a1, Jdep_dust_a3 + real(r8) :: f_cnt_bc + real(r8) :: f_cnt_dust_a1,f_cnt_dust_a3 + real(r8) :: Jcnt_bc + real(r8) :: Jcnt_dust_a1,Jcnt_dust_a3 + integer :: i + + !******************************************************** + ! Hoose et al., 2010 fitting parameters + !******************************************************** + !freezing parameters for immersion freezing + !real(r8),parameter :: theta_imm_bc = 40.17 ! contact angle [deg], converted to rad later + !real(r8),parameter :: dga_imm_bc = 14.4E-20 ! activation energy [J] + !real(r8),parameter :: theta_imm_dust = 30.98 ! contact angle [deg], converted to rad later + !real(r8),parameter :: dga_imm_dust = 15.7E-20 ! activation energy [J] + + !freezing parameters for deposition nucleation + !real(r8),parameter :: theta_dep_dust = 12.7 ! contact angle [deg], converted to rad later !Zimmermann et al (2008), illite + !real(r8),parameter :: dga_dep_dust = -6.21E-21 ! activation energy [J] + !real(r8),parameter :: theta_dep_bc = 28. ! contact angle [deg], converted to rad later !Moehler et al (2005), soot + !real(r8),parameter :: dga_dep_bc = -2.E-19 ! activation energy [J] + + !******************************************************** + ! Wang et al., 2014 fitting parameters + !******************************************************** + ! freezing parameters for immersion freezing + real(r8),parameter :: theta_imm_bc = 48.0_r8 ! contact angle [deg], converted to rad later !DeMott et al (1990) + real(r8),parameter :: dga_imm_bc = 14.15E-20_r8 ! activation energy [J] + real(r8),parameter :: theta_imm_dust = 46.0_r8 ! contact angle [deg], converted to rad later !DeMott et al (2011) SD + real(r8),parameter :: dga_imm_dust = 14.75E-20_r8 ! activation energy [J] + + ! freezing parameters for deposition nucleation + real(r8),parameter :: theta_dep_dust = 20.0_r8 ! contact angle [deg], converted to rad later !Koehler et al (2010) SD + real(r8),parameter :: dga_dep_dust = -8.1E-21_r8 ! activation energy [J] + real(r8),parameter :: theta_dep_bc = 28._r8 ! contact angle [deg], converted to rad later !Moehler et al (2005), soot + real(r8),parameter :: dga_dep_bc = -2.E-19_r8 ! activation energy [J] + + real(r8) :: Kcoll_bc ! collision kernel [cm3 s-1] + real(r8) :: Kcoll_dust_a1 ! collision kernel [cm3 s-1] + real(r8) :: Kcoll_dust_a3 ! collision kernel [cm3 s-1] + logical :: tot_in = .false. + real(r8) :: dim_Jimm_dust_a1(pdf_n_theta), dim_Jimm_dust_a3(pdf_n_theta) + real(r8) :: sum_imm_dust_a1, sum_imm_dust_a3 + !------------------------------------------------------------------------------------------------ + + ! get saturation vapor pressures + eswtr = svp_water(t) ! 0 for liquid + esice = svp_ice(t) ! 1 for ice + + tc = t - tmelt + rhoice = 916.7_r8-0.175_r8*tc-5.e-4_r8*tc**2 + vwice = mwh2o*amu/rhoice + sigma_iw = (28.5_r8+0.25_r8*tc)*1E-3_r8 + sigma_iv = (76.1_r8-0.155_r8*tc + 28.5_r8+0.25_r8*tc)*1E-3_r8 + + ! get mass mean radius + r_bc = hetraer(1) + r_dust_a1 = hetraer(2) + r_dust_a3 = hetraer(3) + + ! calculate collision kernels as a function of environmental parameters and aerosol/droplet sizes + call collkernel(t, p, eswtr, rhwincloud, r3lx, & + r_bc, & ! BC modes + r_dust_a1, r_dust_a3, & ! dust modes + Kcoll_bc, & ! collision kernel [cm3 s-1] + Kcoll_dust_a1, Kcoll_dust_a3) + + !***************************************************************************** + ! take water activity into account + !***************************************************************************** + ! solute effect + aw(:) = 1._r8 + molal(:) = 0._r8 + + ! The heterogeneous ice freezing temperatures of all IN generally decrease with + ! increasing total solute mole fraction. Therefore, the large solution concentration + ! will cause the freezing point depression and the ice freezing temperatures of all + ! IN will get close to the homogeneous ice freezing temperatures. Since we take into + ! account water activity for three heterogeneous freezing modes(immersion, deposition, + ! and contact), we utilize interstitial aerosols(not cloudborne aerosols) to calculate + ! water activity. + ! If the index of IN is 0, it means three freezing modes of this aerosol are depressed. + + do i = 1, 3 + !calculate molality + if ( total_interstitial_aer_num(i) > 0._r8 ) then + molal(i) = (1.e-6_r8*awcam(i)*(1._r8-awfacm(i))/(Mso4*total_interstitial_aer_num(i)*1.e6_r8))/ & + (4*pi/3*rhoh2o*(MAX(r3lx,4.e-6_r8))**3) + aw(i) = 1._r8/(1._r8+2.9244948e-2_r8*molal(i)+2.3141243e-3_r8*molal(i)**2+7.8184854e-7_r8*molal(i)**3) + end if + end do + + !***************************************************************************** + ! immersion freezing begin + !***************************************************************************** + + frzbcimm = 0._r8 + frzduimm = 0._r8 + frzbccnt = 0._r8 + frzducnt = 0._r8 + frzbcdep = 0._r8 + frzdudep = 0._r8 + + ! critical germ size + rgimm = 2*vwice*sigma_iw/(kboltz*t*LOG(supersatice)) + + ! take solute effect into account + rgimm_bc = rgimm + rgimm_dust_a1 = rgimm + rgimm_dust_a3 = rgimm + + ! if aw*Si<=1, the freezing point depression is strong enough to prevent freezing + + if (aw(id_bc)*supersatice > 1._r8 ) then + do_bc = .true. + rgimm_bc = 2*vwice*sigma_iw/(kboltz*t*LOG(aw(id_bc)*supersatice)) + else + do_bc = .false. + end if + + if (aw(id_dst1)*supersatice > 1._r8 ) then + do_dst1 = .true. + rgimm_dust_a1 = 2*vwice*sigma_iw/(kboltz*t*LOG(aw(id_dst1)*supersatice)) + else + do_dst1 = .false. + end if + + if (aw(id_dst3)*supersatice > 1._r8 ) then + do_dst3 = .true. + rgimm_dust_a3 = 2*vwice*sigma_iw/(kboltz*t*LOG(aw(id_dst3)*supersatice)) + else + do_dst3 = .false. + end if + + ! form factor + ! only consider flat surfaces due to uncertainty of curved surfaces + + m = COS(theta_imm_bc*pi/180._r8) + f_imm_bc = (2+m)*(1-m)**2/4._r8 + if (.not. pdf_imm_in) then + m = COS(theta_imm_dust*pi/180._r8) + f_imm_dust_a1 = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_imm_dust*pi/180._r8) + f_imm_dust_a3 = (2+m)*(1-m)**2/4._r8 + end if + + ! homogeneous energy of germ formation + dg0imm_bc = 4*pi/3._r8*sigma_iw*rgimm_bc**2 + dg0imm_dust_a1 = 4*pi/3._r8*sigma_iw*rgimm_dust_a1**2 + dg0imm_dust_a3 = 4*pi/3._r8*sigma_iw*rgimm_dust_a3**2 + + ! prefactor + Aimm_bc = n1*((vwice*rhplanck)/(rgimm_bc**3)*SQRT(3._r8/pi*kboltz*T*dg0imm_bc)) + Aimm_dust_a1 = n1*((vwice*rhplanck)/(rgimm_dust_a1**3)*SQRT(3._r8/pi*kboltz*T*dg0imm_dust_a1)) + Aimm_dust_a3 = n1*((vwice*rhplanck)/(rgimm_dust_a3**3)*SQRT(3._r8/pi*kboltz*T*dg0imm_dust_a3)) + + ! nucleation rate per particle + Jimm_bc = Aimm_bc*r_bc**2/SQRT(f_imm_bc)*EXP((-dga_imm_bc-f_imm_bc*dg0imm_bc)/(kboltz*T)) + if (.not. pdf_imm_in) then + ! 1/sqrt(f) + ! the expression of Chen et al. (sqrt(f)) may however lead to unphysical + ! behavior as it implies J->0 when f->0 (i.e. ice nucleation would be + ! more difficult on easily wettable materials). + Jimm_dust_a1 = Aimm_dust_a1*r_dust_a1**2/SQRT(f_imm_dust_a1)*EXP((-dga_imm_dust-f_imm_dust_a1*dg0imm_dust_a1)/(kboltz*T)) + Jimm_dust_a3 = Aimm_dust_a3*r_dust_a3**2/SQRT(f_imm_dust_a3)*EXP((-dga_imm_dust-f_imm_dust_a3*dg0imm_dust_a3)/(kboltz*T)) + end if + + if (pdf_imm_in) then + dim_Jimm_dust_a1 = 0.0_r8 + dim_Jimm_dust_a3 = 0.0_r8 + do i = i1,i2 + ! 1/sqrt(f) + dim_Jimm_dust_a1(i) = Aimm_dust_a1*r_dust_a1**2/SQRT(dim_f_imm_dust_a1(i))*EXP((-dga_imm_dust-dim_f_imm_dust_a1(i)* & + dg0imm_dust_a1)/(kboltz*T)) + dim_Jimm_dust_a1(i) = max(dim_Jimm_dust_a1(i), 0._r8) + + dim_Jimm_dust_a3(i) = Aimm_dust_a3*r_dust_a3**2/SQRT(dim_f_imm_dust_a3(i))*EXP((-dga_imm_dust-dim_f_imm_dust_a3(i)* & + dg0imm_dust_a3)/(kboltz*T)) + dim_Jimm_dust_a3(i) = max(dim_Jimm_dust_a3(i), 0._r8) + end do + end if + + ! Limit to 1% of available potential IN (for BC), no limit for dust + if (pdf_imm_in) then + sum_imm_dust_a1 = 0._r8 + sum_imm_dust_a3 = 0._r8 + do i = i1,i2-1 + sum_imm_dust_a1 = sum_imm_dust_a1+0.5_r8*((pdf_imm_theta(i)*exp(-dim_Jimm_dust_a1(i)*deltat)+ & + pdf_imm_theta(i+1)*exp(-dim_Jimm_dust_a1(i+1)*deltat)))*pdf_d_theta + sum_imm_dust_a3 = sum_imm_dust_a3+0.5_r8*((pdf_imm_theta(i)*exp(-dim_Jimm_dust_a3(i)*deltat)+ & + pdf_imm_theta(i+1)*exp(-dim_Jimm_dust_a3(i+1)*deltat)))*pdf_d_theta + end do + do i = i1,i2 + if (sum_imm_dust_a1 > 0.99_r8) then + sum_imm_dust_a1 = 1.0_r8 + end if + if (sum_imm_dust_a3 > 0.99_r8) then + sum_imm_dust_a3 = 1.0_r8 + end if + end do + + end if + + if (.not.tot_in) then + if (do_bc) frzbcimm = frzbcimm+MIN(limfacbc*total_cloudborne_aer_num(id_bc)/deltat, & + total_cloudborne_aer_num(id_bc)/deltat*(1._r8-exp(-Jimm_bc*deltat))) + + if (.not. pdf_imm_in) then + if (do_dst1) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst1)/deltat, & + total_cloudborne_aer_num(id_dst1)/deltat*(1._r8-exp(-Jimm_dust_a1*deltat))) + if (do_dst3) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst3)/deltat, & + total_cloudborne_aer_num(id_dst3)/deltat*(1._r8-exp(-Jimm_dust_a3*deltat))) + else + if (do_dst1) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst1)/deltat, & + total_cloudborne_aer_num(id_dst1)/deltat*(1._r8-sum_imm_dust_a1)) + if (do_dst3) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst3)/deltat, & + total_cloudborne_aer_num(id_dst3)/deltat*(1._r8-sum_imm_dust_a3)) + end if + + else + if (do_bc) frzbcimm = frzbcimm+MIN(limfacbc*fn(id_bc)*total_aer_num(id_bc)/deltat, & + fn(id_bc)*total_aer_num(id_bc)/deltat*(1._r8-exp(-Jimm_bc*deltat))) + + if (.not. pdf_imm_in) then + if (do_dst1) frzduimm = frzduimm+MIN(1*fn(id_dst1)*total_aer_num(id_dst1)/deltat, & + fn(id_dst1)*total_aer_num(id_dst1)/deltat*(1._r8-exp(-Jimm_dust_a1*deltat))) + if (do_dst3) frzduimm = frzduimm+MIN(1*fn(id_dst3)*total_aer_num(id_dst3)/deltat, & + fn(id_dst3)*total_aer_num(id_dst3)/deltat*(1._r8-exp(-Jimm_dust_a3*deltat))) + else + if (do_dst1) frzduimm = frzduimm+MIN(1*fn(id_dst1)*total_aer_num(id_dst1)/deltat, & + fn(id_dst1)*total_aer_num(id_dst1)/deltat*(1._r8-sum_imm_dust_a1)) + if (do_dst3) frzduimm = frzduimm+MIN(1*fn(id_dst3)*total_aer_num(id_dst3)/deltat, & + fn(id_dst3)*total_aer_num(id_dst3)/deltat*(1._r8-sum_imm_dust_a3)) + end if + end if + + if (t > 263.15_r8) then + frzduimm = 0._r8 + frzbcimm = 0._r8 + end if + + !---------------------------------- + ! Deposition nucleation + !---------------------------------- + ! critical germ size + ! assume 98% RH in mixed-phase clouds (Korolev & Isaac, JAS 2006) + rgdep=2*vwice*sigma_iv/(kboltz*t*LOG(rhwincloud*supersatice)) + + ! form factor + m = COS(theta_dep_bc*pi/180._r8) + f_dep_bc = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_dep_dust*pi/180._r8) + f_dep_dust_a1 = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_dep_dust*pi/180._r8) + f_dep_dust_a3 = (2+m)*(1-m)**2/4._r8 + + ! homogeneous energy of germ formation + dg0dep = 4*pi/3._r8*sigma_iv*rgdep**2 + + ! prefactor + ! attention: division of small numbers + Adep = (rhwincloud*eswtr)**2*(vwice/(mwh2o*amu))/(kboltz*T*nus)*SQRT(sigma_iv/(kboltz*T)) + + ! nucleation rate per particle + if (rgdep > 0) then + Jdep_bc = Adep*r_bc**2/SQRT(f_dep_bc)*EXP((-dga_dep_bc-f_dep_bc*dg0dep)/(kboltz*T)) + Jdep_dust_a1 = Adep*r_dust_a1**2/SQRT(f_dep_dust_a1)*EXP((-dga_dep_dust-f_dep_dust_a1*dg0dep)/(kboltz*T)) + Jdep_dust_a3 = Adep*r_dust_a3**2/SQRT(f_dep_dust_a3)*EXP((-dga_dep_dust-f_dep_dust_a3*dg0dep)/(kboltz*T)) + else + Jdep_bc = 0._r8 + Jdep_dust_a1 = 0._r8 + Jdep_dust_a3 = 0._r8 + end if + + ! Limit to 1% of available potential IN (for BC), no limit for dust + if (.not.tot_in) then + if (do_bc) frzbcdep = frzbcdep+MIN(limfacbc*uncoated_aer_num(id_bc)/deltat, & + uncoated_aer_num(id_bc)/deltat & + *(1._r8-exp(-Jdep_bc*deltat))) + if (do_dst1) frzdudep = frzdudep+MIN(uncoated_aer_num(id_dst1)/deltat, & + uncoated_aer_num(id_dst1)/deltat & + *(1._r8-exp(-Jdep_dust_a1*deltat))) + if (do_dst3) frzdudep = frzdudep+MIN(uncoated_aer_num(id_dst3)/deltat, & + uncoated_aer_num(id_dst3)/deltat & + *(1._r8-exp(-Jdep_dust_a3*deltat))) + else + if (do_bc) frzbcdep = frzbcdep+MIN(limfacbc*(1._r8-fn(id_bc)) & + *(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat, & + (1._r8-fn(id_bc))*(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat & + *(1._r8-exp(-Jdep_bc*deltat))) + if (do_dst1) frzdudep = frzdudep+MIN((1._r8-fn(id_dst1)) & + *(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat, & + (1._r8-fn(id_dst1))*(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat & + *(1._r8-exp(-Jdep_dust_a1*deltat))) + if (do_dst3) frzdudep = frzdudep+MIN((1._r8-fn(id_dst3)) & + *(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat, & + (1._r8-fn(id_dst3))*(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat & + *(1._r8-exp(-Jdep_dust_a3*deltat))) + end if + + ! --------------------------- + ! contact nucleation + ! --------------------------- + + ! form factor + m = COS(theta_dep_bc*pi/180._r8) + f_cnt_bc = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_dep_dust*pi/180._r8) + f_cnt_dust_a1 = (2+m)*(1-m)**2/4._r8 + + m = COS(theta_dep_dust*pi/180._r8) + f_cnt_dust_a3 = (2+m)*(1-m)**2/4._r8 + + ! homogeneous energy of germ formation + dg0cnt = 4*pi/3._r8*sigma_iv*rgimm**2 + + ! prefactor + ! attention: division of small numbers + Acnt = rhwincloud*eswtr*4*pi/(nus*SQRT(2*pi*mwh2o*amu*kboltz*T)) + + ! nucleation rate per particle + Jcnt_bc = Acnt*r_bc**2*EXP((-dga_dep_bc-f_cnt_bc*dg0cnt)/(kboltz*T))*Kcoll_bc*icnlx + Jcnt_dust_a1 = Acnt*r_dust_a1**2*EXP((-dga_dep_dust-f_cnt_dust_a1*dg0cnt)/(kboltz*T))*Kcoll_dust_a1*icnlx + Jcnt_dust_a3 = Acnt*r_dust_a3**2*EXP((-dga_dep_dust-f_cnt_dust_a3*dg0cnt)/(kboltz*T))*Kcoll_dust_a3*icnlx + + ! Limit to 1% of available potential IN (for BC), no limit for dust + if (.not.tot_in) then + if (do_bc) frzbccnt = frzbccnt+MIN(limfacbc*uncoated_aer_num(id_bc)/deltat, & + uncoated_aer_num(id_bc)/deltat & + *(1._r8-exp(-Jcnt_bc*deltat))) + if (do_dst1) frzducnt = frzducnt+MIN(uncoated_aer_num(id_dst1)/deltat, & + uncoated_aer_num(id_dst1)/deltat & + *(1._r8-exp(-Jcnt_dust_a1*deltat))) + if (do_dst3) frzducnt = frzducnt+MIN(uncoated_aer_num(id_dst3)/deltat, & + uncoated_aer_num(id_dst3)/deltat & + *(1._r8-exp(-Jcnt_dust_a3*deltat))) + else + if (do_bc) frzbccnt = frzbccnt+MIN(limfacbc*(1._r8-fn(id_bc))*(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat, & + (1._r8-fn(id_bc))*(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat & + *(1._r8-exp(-Jcnt_bc*deltat))) + if (do_dst1) frzducnt = frzducnt+MIN((1._r8-fn(id_dst1))*(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat, & + (1._r8-fn(id_dst1))*(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat & + *(1._r8-exp(-Jcnt_dust_a1*deltat))) + if (do_dst3) frzducnt = frzducnt+MIN((1._r8-fn(id_dst3))*(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat, & + (1._r8-fn(id_dst3))*(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat & + *(1._r8-exp(-Jcnt_dust_a3*deltat))) + end if + + errstring = ' ' + if (frzducnt <= -1._r8) then + write(iulog,*) 'hetfrz_classnuc_calc: frzducnt', frzducnt, Jcnt_dust_a1,Jcnt_dust_a3, & + Kcoll_dust_a1, Kcoll_dust_a3 + errstring = 'ERROR in hetfrz_classnuc_calc::frzducnt' + return + end if + + end subroutine hetfrz_classnuc_calc + + !=================================================================================================== + + subroutine collkernel( & + t, pres, eswtr, rhwincloud, r3lx, & + r_bc, & ! BC modes + r_dust_a1, r_dust_a3, & ! dust modes + Kcoll_bc, & ! collision kernel [cm3 s-1] + Kcoll_dust_a1, Kcoll_dust_a3) + + !----------------------------------------------------------------------- + ! Purpose: calculate collision kernels as a function of + ! environmental parameters and aerosol/droplet sizes + ! Author: Corinna Hoose, UiO, October 2009 + ! Modifications: Yong Wang and Xiaohong Liu, UWyo, 12/2012 + !----------------------------------------------------------------------- + + real(r8), intent(in) :: t ! temperature [K] + real(r8), intent(in) :: pres ! pressure [Pa] + real(r8), intent(in) :: eswtr ! saturation vapor pressure of water [Pa] + real(r8), intent(in) :: r3lx ! volume mean drop radius [m] + real(r8), intent(in) :: rhwincloud ! in-cloud relative humidity over water [ ] + real(r8), intent(in) :: r_bc ! model radii of BC modes [m] + real(r8), intent(in) :: r_dust_a1 ! model radii of dust modes [m] + real(r8), intent(in) :: r_dust_a3 ! model radii of dust modes [m] + real(r8), intent(out) :: Kcoll_bc ! collision kernel [cm3 s-1] + real(r8), intent(out) :: Kcoll_dust_a1 + real(r8), intent(out) :: Kcoll_dust_a3 + + ! local variables + real(r8) :: a, b, c, a_f, b_f, c_f, f + real(r8) :: tc ! temperature [deg C] + real(r8) :: rho_air ! air density [kg m-3] + real(r8) :: viscos_air ! dynamic viscosity of air [kg m-1 s-1] + real(r8) :: Ktherm_air ! thermal conductivity of air [J/(m s K)] + real(r8) :: lambda ! mean free path [m] + real(r8) :: Kn ! Knudsen number [ ] + real(r8) :: Re ! Reynolds number [ ] + real(r8) :: Pr ! Prandtl number [ ] + real(r8) :: Sc ! Schmidt number [ ] + real(r8) :: vterm ! terminal velocity [m s-1] + real(r8) :: Ktherm ! thermal conductivity of aerosol [J/(m s K)] + real(r8) :: Dvap ! water vapor diffusivity [m2 s-1] + real(r8) :: Daer ! aerosol diffusivity [m2 s-1] + real(r8) :: latvap ! latent heat of vaporization [J kg-1] + real(r8) :: kboltz ! Boltzmann constant [J K-1] + real(r8) :: G ! thermodynamic function in Cotton et al. [kg m-1 s-1] + real(r8) :: r_a ! aerosol radius [m] + real(r8) :: f_t ! factor by Waldmann & Schmidt [ ] + real(r8) :: Q_heat ! heat flux [J m-2 s-1] + real(r8) :: Tdiff_cotton ! temperature difference between droplet and environment [K] + real(r8) :: K_brownian,K_thermo_cotton,K_diffusio_cotton ! collision kernels [m3 s-1] + real(r8) :: K_total ! total collision kernel [cm3 s-1] + integer :: i + !------------------------------------------------------------------------------------------------ + + Kcoll_bc = 0._r8 + Kcoll_dust_a1 = 0._r8 + Kcoll_dust_a3 = 0._r8 + + tc = t - tmelt + kboltz = 1.38065e-23_r8 + + ! air viscosity for tc<0, from depvel_part.F90 + viscos_air = (1.718_r8+0.0049_r8*tc-1.2e-5_r8*tc*tc)*1.e-5_r8 + + ! air density + rho_air = pres/(rair*t) + + ! mean free path: Seinfeld & Pandis 8.6 + lambda = 2*viscos_air/(pres*SQRT(8/(pi*rair*t))) + + ! latent heat of vaporization, varies with T + latvap = 1000*(-0.0000614342_r8*tc**3 + 0.00158927_r8*tc**2 - 2.36418_r8*tc + 2500.79_r8) + + ! droplet terminal velocity after Chen & Liu, QJRMS 2004 + a = 8.8462e2_r8 + b = 9.7593e7_r8 + c = -3.4249e-11_r8 + a_f = 3.1250e-1_r8 + b_f = 1.0552e-3_r8 + c_f = -2.4023_r8 + f = EXP(EXP(a_f + b_f*(LOG(r3lx))**3 + c_f*rho_air**1.5_r8)) + vterm = (a+ (b + c*r3lx)*r3lx)*r3lx*f + + ! Reynolds number + Re = 2*vterm*r3lx*rho_air/viscos_air + + ! thermal conductivity of air: Seinfeld & Pandis eq. 15.75 + Ktherm_air = 1.e-3_r8*(4.39_r8+0.071_r8*t) !J/(m s K) + + ! Prandtl number + Pr = viscos_air*cpair/Ktherm_air + + ! water vapor diffusivity: Pruppacher & Klett 13-3 + Dvap = 0.211e-4_r8*(t/273.15_r8)*(101325._r8/pres) + + ! G-factor = rhoh2o*Xi in Rogers & Yau, p. 104 + G = rhoh2o/((latvap/(rh2o*t) - 1)*latvap*rhoh2o/(Ktherm_air*t) + rhoh2o*rh2o*t/(Dvap*eswtr)) + + ! variables depending on aerosol radius + ! loop over 3 aerosol modes + do i = 1, 3 + if (i == 1) r_a = r_bc + if (i == 2) r_a = r_dust_a1 + if (i == 3) r_a = r_dust_a3 + ! Knudsen number (Seinfeld & Pandis 8.1) + Kn = lambda/r_a + ! aerosol diffusivity + Daer = kboltz*t*(1 + Kn)/(6*pi*r_a*viscos_air) + ! Schmidt number + Sc = viscos_air/(Daer*rho_air) + + ! Young (1974) first equ. on page 771 + K_brownian = 4*pi*r3lx*Daer*(1 + 0.3_r8*Re**0.5_r8*Sc**0.33_r8) + + ! thermal conductivities from Seinfeld & Pandis, Table 8.6 + if (i == 1) Ktherm = 4.2_r8 ! Carbon + if (i == 2 .or. i == 3) Ktherm = 0.72_r8 ! clay + + ! form factor + f_t = 0.4_r8*(1._r8 + 1.45_r8*Kn + 0.4_r8*Kn*EXP(-1._r8/Kn)) & + *(Ktherm_air + 2.5_r8*Kn*Ktherm) & + /((1._r8 + 3._r8*Kn)*(2._r8*Ktherm_air + 5._r8*Kn*Ktherm+Ktherm)) + + ! calculate T-Tc as in Cotton et al. + Tdiff_cotton = -G*(rhwincloud - 1._r8)*latvap/Ktherm_air + Q_heat = Ktherm_air/r3lx*(1._r8 + 0.3_r8*Re**0.5_r8*Pr**0.33_r8)*Tdiff_cotton + K_thermo_cotton = 4._r8*pi*r3lx*r3lx*f_t*Q_heat/pres + K_diffusio_cotton = -(1._r8/f_t)*(rh2o*t/latvap)*K_thermo_cotton + K_total = 1.e6_r8*(K_brownian + K_thermo_cotton + K_diffusio_cotton) ! convert m3/s -> cm3/s + + ! set K to 0 if negative + if (K_total .lt. 0._r8) K_total = 0._r8 + + if (i == 1) Kcoll_bc = K_total + if (i == 2) Kcoll_dust_a1 = K_total + if (i == 3) Kcoll_dust_a3 = K_total + end do + + end subroutine collkernel + + !=================================================================================================== + + subroutine hetfrz_classnuc_init_pdftheta() + + use shr_spfn_mod, only: erf => shr_spfn_erf + + ! Local variables: + real(r8) :: theta_min, theta_max + real(r8) :: x1_imm, x2_imm + real(r8) :: norm_theta_imm + real(r8) :: imm_dust_mean_theta + real(r8) :: imm_dust_var_theta + integer :: i + real(r8) :: m + real(r8) :: temp + !---------------------------------------------------------------------------- + + theta_min = pi/180._r8 + theta_max = 179._r8/180._r8*pi + imm_dust_mean_theta = 46.0_r8/180.0_r8*pi + imm_dust_var_theta = 0.01_r8 + + pdf_d_theta = (179._r8-1._r8)/180._r8*pi/(pdf_n_theta-1) + + x1_imm = (LOG(theta_min) - LOG(imm_dust_mean_theta))/(sqrt(2.0_r8)*imm_dust_var_theta) + x2_imm = (LOG(theta_max) - LOG(imm_dust_mean_theta))/(sqrt(2.0_r8)*imm_dust_var_theta) + norm_theta_imm = (ERF(x2_imm) - ERF(x1_imm))*0.5_r8 + dim_theta = 0.0_r8 + pdf_imm_theta = 0.0_r8 + do i = i1, i2 + dim_theta(i) = 1._r8/180._r8*pi + (i-1)*pdf_d_theta + pdf_imm_theta(i) = exp(-((LOG(dim_theta(i)) - LOG(imm_dust_mean_theta))**2._r8) / & + (2._r8*imm_dust_var_theta**2._r8) ) / & + (dim_theta(i)*imm_dust_var_theta*SQRT(2*pi))/norm_theta_imm + end do + + do i = i1, i2 + m = cos(dim_theta(i)) + temp = (2+m)*(1-m)**2/4._r8 + dim_f_imm_dust_a1(i) = temp + dim_f_imm_dust_a3(i) = temp + end do + + end subroutine hetfrz_classnuc_init_pdftheta + end module hetfrz_classnuc_oslo From de3fd9e2dc6d486bb5d384ab8913e168398ea7a9 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 29 Aug 2023 10:15:43 +0200 Subject: [PATCH 23/71] more updates for refactoring --- src/chemistry/oslo_aero/condtend.F90 | 6 +- src/chemistry/oslo_aero/const.F90 | 28 +++--- .../{koagsub.F90 => oslo_aero_coag.F90} | 87 +++++++++---------- src/chemistry/oslo_aero/parmix_progncdnc.F90 | 8 +- src/physics/cam_oslo/aero_model.F90 | 8 +- 5 files changed, 63 insertions(+), 74 deletions(-) rename src/chemistry/oslo_aero/{koagsub.F90 => oslo_aero_coag.F90} (93%) diff --git a/src/chemistry/oslo_aero/condtend.F90 b/src/chemistry/oslo_aero/condtend.F90 index 3cd405e03e..f0fd96a43f 100644 --- a/src/chemistry/oslo_aero/condtend.F90 +++ b/src/chemistry/oslo_aero/condtend.F90 @@ -251,8 +251,8 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & ! Added input for h2so4 and soa nucleation: soa_lv_gasprod, soa_sv_gasprod, pblh,zm,qh20 (cka) use cam_history, only: outfld,fieldname_len - use koagsub, only: normalizedCoagulationSink, receiverMode,numberOfCoagulationReceivers - use koagsub, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd + use oslo_aero_coag, only: normalizedCoagulationSink, receiverMode,numberOfCoagulationReceivers + use oslo_aero_coag, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd use constituents, only: pcnst ! h2so4 and soa nucleation (cka) ! arguments @@ -321,7 +321,7 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & condensationSink(:,:) = 0.0_r8 !Sink to the coming "receiver" of any vapour - !NB: The following is duplicated code, coordinate with koagsub!! + !NB: The following is duplicated code, coordinate with oslo_aero_coag! !Initialize number concentration for this receiver !Air density diff --git a/src/chemistry/oslo_aero/const.F90 b/src/chemistry/oslo_aero/const.F90 index c20326140b..1dadac56c2 100644 --- a/src/chemistry/oslo_aero/const.F90 +++ b/src/chemistry/oslo_aero/const.F90 @@ -1,8 +1,7 @@ module const !----------------------------------------------------------------------------- - !Module containing subroutines constants, koagsub and parmix and declaration - !of the variables required by them. + ! Module containing oslo_aero constants !----------------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 @@ -12,24 +11,19 @@ module const implicit none public - real(r8), parameter:: smallNumber = 1.e-100_r8 - - !Essential size distribution parameters - real(r8), parameter :: rTabMin = 1.e-9_r8 ![m] smallest lookup table size - real(r8), parameter :: rTabMax = 20.e-6_r8 ![m] largest lookup table size - integer, parameter :: nBinsTab = 44 ![nbr] number of tabulated bins - - !Smallest particle which can receive aquous chemistry mass - real(r8), parameter :: rMinAquousChemistry = 0.05e-6_r8 - real(r8) :: nk(0:nmodes,nbinsTab) !dN/dlogr for modes - real(r8) :: normnk(0:nmodes,nbinsTab) !dN for modes (sums to one over size range) + real(r8), parameter :: smallNumber = 1.e-100_r8 + real(r8), parameter :: rTabMin = 1.e-9_r8 ![m] smallest lookup table size + real(r8), parameter :: rTabMax = 20.e-6_r8 ![m] largest lookup table size + integer, parameter :: nBinsTab = 44 ![nbr] number of tabulated bins + real(r8), parameter :: rMinAquousChemistry = 0.05e-6_r8 ! Smallest particle which can receive aquous chemistry mass + real(r8), parameter :: sq2pi = 1._r8/sqrt(2.0_r8*pi) + real(r8) :: nk(0:nmodes,nbinsTab) !dN/dlogr for modes + real(r8) :: normnk(0:nmodes,nbinsTab) !dN for modes (sums to one over size range) real(r8) :: rBinEdge(nBinsTab+1) real(r8) :: rBinMidpoint(nBinsTab) - - real(r8), parameter :: sq2pi = 1._r8/sqrt(2.0_r8*pi) - real(r8) :: volumeToNumber(0:nmodes) !m3 ==> # - real(r8) :: numberToSurface(0:nmodes) !# ==> m2 + real(r8) :: volumeToNumber(0:nmodes) !m3 ==> # + real(r8) :: numberToSurface(0:nmodes) !# ==> m2 end module const diff --git a/src/chemistry/oslo_aero/koagsub.F90 b/src/chemistry/oslo_aero/oslo_aero_coag.F90 similarity index 93% rename from src/chemistry/oslo_aero/koagsub.F90 rename to src/chemistry/oslo_aero/oslo_aero_coag.F90 index eaedc5ab6d..801759ae21 100644 --- a/src/chemistry/oslo_aero/koagsub.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_coag.F90 @@ -1,34 +1,36 @@ -module koagsub +module oslo_aero_coag + !---------------------------------------------------------------------- + ! modal aerosol coagulation + !---------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 use phys_control, only: phys_getopts - use aerosoldef use chem_mods, only: gas_pcnst use mo_tracname, only: solsym - use const - use shr_kind_mod, only: r8 => shr_kind_r8 use physconst, only: rair, gravit - use cam_logfile, only : iulog + use cam_logfile, only: iulog + use aerosoldef + use const implicit none private - real(r8), parameter :: kboltzmann = 1.3806488e-23_r8 ![m2 kg s-2 K-1] - real(r8), parameter :: temperatureLookupTables = 293.15_r8 !Temperature used in look up tables - real(r8), parameter :: mfpAir = 63.3e-9_r8 ![m] mean free path air - real(r8), parameter :: viscosityAir = 1.983e-5_r8 ![Pa s] viscosity of air - - real(r8), parameter :: rhoh2o = 1000._r8 ! Density of water + public :: initializeCoagulationReceivers ! called by oslo_aero/aero_model + public :: initializeCoagulationCoefficients ! called by oslo_aero/aero_model + public :: initializeCoagulationOutput ! called by oslo_aero/aero_model + public :: coagtend ! called by oslo_aero/aero_model + public :: clcoag ! called by oslo_aero/aero_model - integer, parameter :: numberOfCoagulatingModes = 6 integer, parameter, public :: numberOfCoagulationReceivers = 6 + integer, parameter, public :: numberOfAddCoagReceivers = 6 real(r8), public :: normalizedCoagulationSink(0:nmodes,0:nmodes) ![m3/#/s] - real(r8), public :: NCloudCoagulationSink(0:nmodes) ![m3/#/s] - - integer, parameter, public :: numberOfAddCoagReceivers = 6 - real(r8), public :: normCoagSinkAdd(numberOfAddCoagReceivers) ![m3/#/s] + real(r8), public :: NCloudCoagulationSink(0:nmodes) ![m3/#/s] + real(r8), public :: normCoagSinkAdd(numberOfAddCoagReceivers) ![m3/#/s] !These are the modes which are coagulating (belonging to mixtures no. 0, 1, 2, 4, 12, 14) + integer , parameter :: numberOfCoagulatingModes = 6 integer, public :: coagulatingMode(numberOfCoagulatingModes) = & (/MODE_IDX_BC_EXT_AC & !inert mode , MODE_IDX_SO4SOA_AIT, MODE_IDX_BC_AIT, MODE_IDX_OMBC_INTMIX_COAT_AIT & !internally mixed small modes @@ -44,7 +46,7 @@ module koagsub ! (belonging to mixtures no. 0, 1, 2, 4, 12, 14) integer, public :: addReceiverMode(numberOfAddCoagReceivers) = & (/MODE_IDX_BC_EXT_AC,MODE_IDX_SO4SOA_AIT,MODE_IDX_BC_AIT, & - MODE_IDX_OMBC_INTMIX_COAT_AIT,MODE_IDX_BC_NUC,MODE_IDX_OMBC_INTMIX_AIT /) + MODE_IDX_OMBC_INTMIX_COAT_AIT,MODE_IDX_BC_NUC,MODE_IDX_OMBC_INTMIX_AIT /) !Coagulation moves aerosol mass to the "coagulate" species, so some !lifecycle species will receive mass in this routine! @@ -62,11 +64,11 @@ module koagsub integer :: tableindexcloud real(r8),parameter :: rcoagdroplet = 10.e-6 ! m - public :: initializeCoagulationOutput - public :: initializeCoagulationReceivers - public :: initializeCoagulationCoefficients - public :: coagtend - public :: clcoag + real(r8), parameter :: kboltzmann = 1.3806488e-23_r8 ![m2 kg s-2 K-1] + real(r8), parameter :: temperatureLookupTables = 293.15_r8 !Temperature used in look up tables + real(r8), parameter :: mfpAir = 63.3e-9_r8 ![m] mean free path air + real(r8), parameter :: viscosityAir = 1.983e-5_r8 ![Pa s] viscosity of air + real(r8), parameter :: rhoh2o = 1000._r8 ! Density of water !================================================================ contains @@ -162,24 +164,16 @@ subroutine initializeCoagulationCoefficients(rhob,rk) real(r8), intent(in) :: rhob(0:nmodes) !density of background mode real(r8), dimension(numberOfCoagulationReceivers, numberOfCoagulatingModes, nBinsTab) :: K12 = 0.0_r8 !Coagulation coefficient (m3/s) - - !nuctst3+ - ! real(r8), dimension(nBinsTab) :: CoagCoeffMode1 = 0.0_r8 !Coagulation coefficient mode 1 with 1 (m3/s) - !nuctst3- - !ak+ real(r8), dimension(numberOfAddCoagReceivers,nBinsTab) :: CoagCoeffModeAdd = 0.0_r8 !Coagulation coefficient mode 1 (m3/s) - !ak- - real(r8), dimension(numberOfCoagulatingModes,nBinsTab) :: K12Cl = 0.0_r8 !Coagulation coefficient (m3/s) - real(r8), dimension(nBinsTab) :: coagulationCoefficient - integer :: aMode - integer :: modeIndex - integer :: modeIndexCoagulator !Index of coagulating mode - integer :: modeIndexReceiver !Index of receiving mode - integer :: iCoagulatingMode !Counter for coagulating mode - integer :: iReceiverMode !Counter for receiver modes - integer :: nsiz !counter for look up table sizes + integer :: aMode + integer :: modeIndex + integer :: modeIndexCoagulator !Index of coagulating mode + integer :: modeIndexReceiver !Index of receiving mode + integer :: iCoagulatingMode !Counter for coagulating mode + integer :: iReceiverMode !Counter for receiver modes + integer :: nsiz !counter for look up table sizes do iReceiverMode = 1, numberOfCoagulationReceivers do iCoagulatingMode = 1,numberOfCoagulatingModes @@ -273,10 +267,11 @@ subroutine initializeCoagulationCoefficients(rhob,rk) do nsiz=1,nBinsTab !aerotab bin sizes !Sum up coagulation sink for this coagulating species (for all receiving modes) - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) = & ![m3/#/s] - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] Previous value - + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode - * K12(iReceiverMode, iCoagulatingMode, nsiz) !Koagulation coefficient (m3/#/s) + normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) = & ![m3/#/s] + normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] Previous value + + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode + * K12(iReceiverMode, iCoagulatingMode, nsiz) !Coagulation coefficient (m3/#/s) + end do !Look up table size end do !receiver modes end do !coagulator @@ -293,10 +288,10 @@ subroutine initializeCoagulationCoefficients(rhob,rk) do nsiz=1,nBinsTab !aerotab bin sizes !Sum up coagulation sink for this coagulating species (for all receiving modes) - normCoagSinkAdd(iReceiverMode) = & ![m3/#/s] - normCoagSinkAdd(iReceiverMode) & ![m3/#/s] Previous value - + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode - * CoagCoeffModeAdd(iReceiverMode, nsiz) !Koagulation coefficient (m3/#/s) + normCoagSinkAdd(iReceiverMode) = & ![m3/#/s] + normCoagSinkAdd(iReceiverMode) & ![m3/#/s] Previous value + + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode + * CoagCoeffModeAdd(iReceiverMode, nsiz) !Koagulation coefficient (m3/#/s) end do !Look up table size end do !receiver modes !ak- @@ -765,4 +760,4 @@ function calculateGFactor(radius, meanFreePath) result(g) -2.0_r8*radius end function calculateGFactor -end module koagsub +end module oslo_aero_coag diff --git a/src/chemistry/oslo_aero/parmix_progncdnc.F90 b/src/chemistry/oslo_aero/parmix_progncdnc.F90 index c8279e8bca..bb0f847f5b 100644 --- a/src/chemistry/oslo_aero/parmix_progncdnc.F90 +++ b/src/chemistry/oslo_aero/parmix_progncdnc.F90 @@ -841,9 +841,9 @@ subroutine modalapp2d_sub(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm use commondefinitions use aerosoldef - use const, only: smallNumber - use koagsub, only: normalizedCoagulationSink - use condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV + use const, only: smallNumber + use oslo_aero_coag, only: normalizedCoagulationSink + use condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV implicit none ! @@ -896,7 +896,7 @@ subroutine modalapp2d_sub(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm integer :: i !counter for modes integer :: k !counter for levels - !Find the sink on any mode (0 is omitted here, WHY??, it does receive matter in koagsub/condtend!!)) + !Find the sink on any mode (0 is omitted here, WHY??, it does receive matter in oslo_aero_coag/condtend!!)) !Should either remove it from there or add something to it here! do i=1,nbmodes do k=1,pver diff --git a/src/physics/cam_oslo/aero_model.F90 b/src/physics/cam_oslo/aero_model.F90 index 6ae97402df..d23d0279cd 100644 --- a/src/physics/cam_oslo/aero_model.F90 +++ b/src/physics/cam_oslo/aero_model.F90 @@ -24,7 +24,7 @@ module aero_model use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName use aerosoldef, only: qqcw_get_field use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub - use koagsub, only: coagtend, clcoag + use oslo_aero_coag, only: coagtend, clcoag use sox_cldaero_mod, only: sox_cldaero_init use intlog, only: initlogn use ref_pres, only: top_lev => clim_modal_aero_top_lev @@ -783,9 +783,9 @@ subroutine constants use physconst, only: pi use const use aerosoldef - use koagsub, only : initializeCoagulationReceivers - use koagsub, only : initializeCoagulationCoefficients - use koagsub, only : initializeCoagulationOutput + use oslo_aero_coag, only : initializeCoagulationReceivers + use oslo_aero_coag, only : initializeCoagulationCoefficients + use oslo_aero_coag, only : initializeCoagulationOutput use oslo_utils integer :: kcomp,i From 7704c8e817093fd167b0b23e3637b1ec5800f313 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 29 Aug 2023 22:16:20 +0200 Subject: [PATCH 24/71] more cleanup still bfb --- .../oslo_aero}/aero_model.F90 | 139 ++- src/chemistry/oslo_aero/aerosoldef.F90 | 229 ++--- src/chemistry/oslo_aero/const.F90 | 2 +- .../oslo_aero}/dust_model.F90 | 0 .../oslo_aero/oslo_aero_deposition.F90 | 3 + .../oslo_aero/oslo_aerosols_intr.F90 | 829 +++++++++--------- src/chemistry/oslo_aero/oslo_utils.F90 | 324 ++++--- .../oslo_aero}/seasalt_model.F90 | 0 .../oslo_aero}/sox_cldaero_mod.F90 | 0 .../cam_oslo/modal_aero_deposition.F90 | 215 ----- 10 files changed, 765 insertions(+), 976 deletions(-) rename src/{physics/cam_oslo => chemistry/oslo_aero}/aero_model.F90 (88%) rename src/{physics/cam_oslo => chemistry/oslo_aero}/dust_model.F90 (100%) create mode 100644 src/chemistry/oslo_aero/oslo_aero_deposition.F90 rename src/{physics/cam_oslo => chemistry/oslo_aero}/seasalt_model.F90 (100%) rename src/{physics/cam_oslo => chemistry/oslo_aero}/sox_cldaero_mod.F90 (100%) delete mode 100644 src/physics/cam_oslo/modal_aero_deposition.F90 diff --git a/src/physics/cam_oslo/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 similarity index 88% rename from src/physics/cam_oslo/aero_model.F90 rename to src/chemistry/oslo_aero/aero_model.F90 index d23d0279cd..90480302c0 100644 --- a/src/physics/cam_oslo/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -3,40 +3,58 @@ !=============================================================================== module aero_model - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst, cnst_name, cnst_get_ind - use ppgrid, only: pcols, pver, pverp - use phys_control, only: phys_getopts, cam_physpkg_is - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use perf_mod, only: t_startf, t_stopf - use camsrfexch, only: cam_in_t, cam_out_t - use aerodep_flx, only: aerodep_flx_prescribed - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc - use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field - use physconst, only: gravit, rair, rhoh2o - use spmd_utils, only: masterproc - use infnan, only: nan, assignment(=) - use cam_history, only: outfld, fieldname_len - use chem_mods, only: gas_pcnst, adv_mass - use mo_tracname, only: solsym - use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName - use aerosoldef, only: qqcw_get_field - use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub - use oslo_aero_coag, only: coagtend, clcoag - use sox_cldaero_mod, only: sox_cldaero_init - use intlog, only: initlogn - use ref_pres, only: top_lev => clim_modal_aero_top_lev - use mo_setsox, only: setsox - use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, cnst_name, cnst_get_ind + use ppgrid, only: pcols, pver, pverp + use phys_control, only: phys_getopts, cam_physpkg_is + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use perf_mod, only: t_startf, t_stopf + use camsrfexch, only: cam_in_t, cam_out_t + use aerodep_flx, only: aerodep_flx_prescribed + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc + use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field + use physconst, only: gravit, rair, rhoh2o + use spmd_utils, only: masterproc + use time_manager, only: get_nstep + use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only + use chem_mods, only: gas_pcnst, adv_mass + use mo_tracname, only: solsym + use mo_setsox, only: setsox + use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri + use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx + use ref_pres, only: top_lev => clim_modal_aero_top_lev + use drydep_mod, only: inidrydep + use wetdep, only: wetdep_init + ! + use oslo_aerosols_intr, only: oslo_aero_initialize, oslo_aero_dry_intr, oslo_aero_wet_intr + use oslo_utils, only: calculateNumberConcentration + use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName + use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers + use aerosoldef, only: lifeCycleNumberMedianRadius + use aerosoldef, only: getCloudTracerName + use aerosoldef, only: aero_register + use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub + use condtend, only: registerCondensation, initializeCondensation, condtend_sub + use oslo_aero_coag, only: coagtend, clcoag + use sox_cldaero_mod, only: sox_cldaero_init + use intlog, only: initlogn + use seasalt_model, only: seasalt_init, seasalt_emis, seasalt_active + use dust_model, only: dust_init, dust_emis, dust_active + use oslo_ocean_intr, only: oslo_ocean_init, oslo_dms_emis_intr + use opttab, only: initopt, initopt_lw + use commondefinitions, only: originalSigma, originalNumberMedianRadius + use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes + use calcaersize #ifdef AEROCOM - use aerocom_opt_mod, only: initaeropt - use aerocom_dry_mod, only: initdryp + use aerocom_opt_mod, only: initaeropt + use aerocom_dry_mod, only: initdryp #endif implicit none private + public :: aero_model_readnl public :: aero_model_register public :: aero_model_init @@ -117,8 +135,6 @@ end subroutine aero_model_readnl !============================================================================= subroutine aero_model_register() - use aerosoldef, only: aero_register - use condtend, only: registerCondensation call aero_register() call registerCondensation() @@ -128,40 +144,14 @@ end subroutine aero_model_register !============================================================================= subroutine aero_model_init( pbuf2d ) - use cam_history, only: addfld, add_default, horiz_only - use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx - use dust_model, only: dust_init, dust_active - use seasalt_model, only: seasalt_init, seasalt_active - use drydep_mod, only: inidrydep - use wetdep, only: wetdep_init - use condtend, only: initializeCondensation - use oslo_ocean_intr, only: oslo_ocean_init - use oslo_aerosols_intr, only: oslo_aero_initialize - use opttab, only: initopt, initopt_lw - use modal_aero_deposition , only: modal_aero_deposition_init - ! args type(physics_buffer_desc), pointer :: pbuf2d(:,:) ! local vars - character(len=*), parameter :: subrname = 'aero_model_init' - integer :: m, n, id + integer :: m, n, id, l character(len=20) :: dummy - - logical :: history_aerosol ! Output MAM or SECT aerosol tendencies - - integer :: l - character(len=6) :: test_name - character(len=64) :: errmes - + logical :: history_aerosol ! Output MAM or SECT aerosol tendencies character(len=2) :: unit_basename ! Units 'kg' or '1' - integer :: errcode - character(len=fieldname_len) :: field_name - - character(len=32) :: spec_name - character(len=32) :: spec_type - character(len=32) :: mode_type - integer :: nspec !------------------------------------ call phys_getopts(history_aerosol_out=history_aerosol, convproc_do_aer_out=convproc_do_aer) @@ -180,7 +170,6 @@ subroutine aero_model_init( pbuf2d ) call dust_init() call seasalt_init() !seasalt_emis_scale) call wetdep_init() - call modal_aero_deposition_init() nwetdep = 0 ndrydep = 0 @@ -269,11 +258,6 @@ end subroutine aero_model_init !============================================================================= subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend ) - use calcaersize - use oslo_aerosols_intr, only: oslo_aero_dry_intr - use aerosoldef , only : numberOfProcessModeTracers - use commondefinitions, only: oslo_nmodes=>nmodes - ! args type(physics_state), intent(in) :: state ! Physics state variables real(r8), intent(in) :: obklen(:) @@ -286,8 +270,8 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ! local vars integer :: ncol - real(r8), dimension(pcols, pver, 0:oslo_nmodes) :: oslo_dgnumwet - real(r8), dimension(pcols, pver, 0:oslo_nmodes) :: oslo_wetdens + real(r8), dimension(pcols, pver, 0:nmodes_oslo) :: oslo_dgnumwet + real(r8), dimension(pcols, pver, 0:nmodes_oslo) :: oslo_wetdens real(r8), dimension(pcols, pver, numberOfProcessModeTracers) :: oslo_dgnumwet_processmodes real(r8), dimension(pcols, pver, numberOfProcessModeTracers) :: oslo_wetdens_processmodes @@ -305,8 +289,6 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, !============================================================================= subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) - use oslo_aerosols_intr, only: oslo_aero_wet_intr - type(physics_state), intent(in) :: state ! Physics state variables real(r8), intent(in) :: dt ! time step real(r8), intent(in) :: dlf(:,:) ! shallow+deep convective detrainment [kg/kg/s] @@ -328,10 +310,7 @@ subroutine aero_model_surfarea( & ! called from mo_usrrxt !------------------------------------------------------------------------- - use commondefinitions, only: nmodes_oslo => nmodes - use const , only: numberToSurface - use aerosoldef , only: lifeCycleNumberMedianRadius - use oslo_utils , only: calculateNumberConcentration + use const, only: numberToSurface ! dummy args real(r8), intent(in) :: pmid(:,:) @@ -430,10 +409,6 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ airdens, invariants, del_h2so4_gasprod, & vmr0, vmr, pbuf ) - use time_manager, only : get_nstep - use condtend, only : condtend_sub - use aerosoldef, only: getCloudTracerName - !----------------------------------------------------------------------- ! ... dummy arguments !----------------------------------------------------------------------- @@ -672,11 +647,6 @@ end subroutine aero_model_gasaerexch !============================================================================= subroutine aero_model_emissions( state, cam_in ) - use seasalt_model , only: seasalt_emis, seasalt_active - use dust_model , only: dust_emis, dust_active - use oslo_ocean_intr , only: oslo_dms_emis_intr - use physics_types , only: physics_state - ! Arguments: type(physics_state), intent(in) :: state ! Physics state variables type(cam_in_t), intent(inout) :: cam_in ! import state @@ -705,9 +675,6 @@ subroutine qqcw2vmr(lchnk, vmr, mbar, ncol, im, pbuf) ! ... Xfrom from mass to volume mixing ratio !----------------------------------------------------------------- - use physics_buffer , only : physics_buffer_desc - use chem_mods , only : adv_mass, gas_pcnst - !----------------------------------------------------------------- ! ... Dummy args !----------------------------------------------------------------- @@ -743,8 +710,6 @@ subroutine vmr2qqcw( lchnk, vmr, mbar, ncol, im, pbuf ) !----------------------------------------------------------------- use m_spc_id - use chem_mods, only : adv_mass, gas_pcnst - use physics_buffer, only : physics_buffer_desc !----------------------------------------------------------------- ! ... Dummy args diff --git a/src/chemistry/oslo_aero/aerosoldef.F90 b/src/chemistry/oslo_aero/aerosoldef.F90 index 9464447cc4..da2600225f 100644 --- a/src/chemistry/oslo_aero/aerosoldef.F90 +++ b/src/chemistry/oslo_aero/aerosoldef.F90 @@ -1,14 +1,14 @@ module aerosoldef !--------------------------------------------------------------------------------- - ! Module to set up register aerosols indexes, number of gas and particle + ! Module to set up register aerosols indexes, number of gas and particle ! species and their scavenging rates. Tables for humidity growth !--------------------------------------------------------------------------------- use commondefinitions use shr_kind_mod, only: r8 => shr_kind_r8 use mo_tracname, only: solsym - use constituents, only: pcnst, cnst_name,cnst_get_ind + use constituents, only: pcnst, cnst_name, cnst_get_ind use cam_abortutils, only: endrun implicit none @@ -31,7 +31,7 @@ module aerosoldef public is_process_mode ! Check is an aerosol specie is a process mode public isAerosol ! Check is specie is aerosol (i.e. gases get .FALSE. here) public getTracerIndex - public getNumberOfTracersInMode + public getNumberOfTracersInMode public getNumberOfBackgroundTracersInMode public getCloudTracerIndex public getCloudTracerIndexDirect @@ -59,7 +59,7 @@ module aerosoldef integer, parameter, public :: MODE_IDX_SS_A3 = 10 !Coarse mode sea-salt (mode will have other comps added) integer, parameter, public :: MODE_IDX_SO4SOA_NUC = 11 !SO4 and SOA nucleation mode integer, parameter, public :: MODE_IDX_BC_NUC = 12 !BC nucleation mode - integer, parameter, public :: MODE_IDX_LUMPED_ORGANICS = 13 !not used in lifecycle, but some extra mass goes here when max. allowed LUT conc. are too small + integer, parameter, public :: MODE_IDX_LUMPED_ORGANICS = 13 !not used in lifecycle, but some extra mass goes here when max. allowed LUT conc. are too small integer, parameter, public :: MODE_IDX_OMBC_INTMIX_AIT = 14 !mix quickly formed in fire-plumes integer, parameter, public :: numberOfExternallyMixedModes = 4 !Modes 0;11-14 (13 is not used in lifecycle) @@ -77,22 +77,21 @@ module aerosoldef ,MODE_IDX_SO4_AC, MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SS_A1 & ,MODE_IDX_SS_A2, MODE_IDX_SS_A3 /) - ! following are species indices for individual camuio species - integer,public :: & - l_so4_na, l_so4_a1, l_so4_a2, l_so4_ac, & - l_bc_n, l_bc_ax, l_bc_ni, l_bc_a, l_bc_ai,l_bc_ac, & - l_om_ni, l_om_ai ,l_om_ac, & - l_so4_pr, & - l_dst_a2, l_dst_a3, & - l_ss_a1, l_ss_a2, l_ss_a3, l_h2so4, & - l_soa_na, l_soa_a1, l_soa_lv, l_soa_sv + ! species indices for individual camuio species + integer,public :: l_so4_na, l_so4_a1, l_so4_a2, l_so4_ac + integer,public :: l_bc_n, l_bc_ax, l_bc_ni, l_bc_a, l_bc_ai,l_bc_ac + integer,public :: l_om_ni, l_om_ai, l_om_ac + integer,public :: l_so4_pr + integer,public :: l_dst_a2, l_dst_a3 + integer,public :: l_ss_a1, l_ss_a2, l_ss_a3, l_h2so4 + integer,public :: l_soa_na, l_soa_a1, l_soa_lv, l_soa_sv integer :: n_aerosol_tracers !number of aerosol tracers integer :: imozart - !Number of transported tracers in each mode - integer, parameter, dimension(0:nmodes) :: n_tracers_in_mode = (/ 1, 4, 3, 0, 5, 7, 7, 7, 7, 7, 7, 0, 1, 0, 2 /) - integer, parameter, dimension(0:nmodes) :: n_background_tracers_in_mode = (/ 1,2,1,0,2,1,1,1,1,1,1,0,1,0,2 /) + !Number of transported tracers in each mode + integer, parameter, dimension(0:nmodes) :: n_tracers_in_mode = (/ 1, 4, 3, 0, 5, 7, 7, 7, 7, 7, 7, 0, 1, 0, 2 /) + integer, parameter, dimension(0:nmodes) :: n_background_tracers_in_mode = (/ 1,2,1,0,2,1,1,1,1,1,1,0,1,0,2 /) integer, dimension(0:nmodes, max_tracers_per_mode) :: tracer_in_mode !Radius used for the modes in the lifeCycle MAY ASSUME SOME GROWTH ALREADY HAPPENED @@ -120,10 +119,10 @@ module aerosoldef !The process modes need an "efficient size" (Why does A1 have a different size than the others??) real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeNumberMedianRadius = & - (/ 0.04e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.04e-6_r8 /) + (/ 0.04e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.04e-6_r8 /) - !The process modes need an "efficient sigma" - real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeSigma = & + !The process modes need an "efficient sigma" + real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeSigma = & (/ 1.8_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.8_r8 /) @@ -143,40 +142,40 @@ module aerosoldef contains - !For a tracer in an aerosol mode, check if this is - !actually a real tracer or a process mode + !=============================================================================== function is_process_mode(l_index_in, isChemistry) result(answer) + !For a tracer in an aerosol mode, check if this is!actually a real tracer or a process mode + integer, intent(in) :: l_index_in logical, intent(in) :: isChemistry !true if called from chemistry - integer :: l_index_phys - logical :: answer + + integer :: l_index_phys + logical :: answer l_index_phys = l_index_in - if(isChemistry .eqv. .true.)then + if (isChemistry) then l_index_phys = l_index_phys + iMozart - 1 endif - !answer becomes true if tracer is a "process mode" - answer = .FALSE. - if(l_index_phys .eq. l_so4_a1 & - .OR. l_index_phys .eq. l_so4_a2 & - .OR. l_index_phys .eq. l_so4_ac & - .OR. l_index_phys .eq. l_bc_ac & - .OR. l_index_phys .eq. l_om_ac & - .OR. l_index_phys .eq. l_soa_a1 ) then - answer = .TRUE. + ! return true if tracer is a "process mode" + answer = .false. + if(l_index_phys .eq. l_so4_a1 .or. & + l_index_phys .eq. l_so4_a2 .or. & + l_index_phys .eq. l_so4_ac .or. & + l_index_phys .eq. l_bc_ac .or. & + l_index_phys .eq. l_om_ac .or. & + l_index_phys .eq. l_soa_a1 ) then + answer = .true. endif - return end function is_process_mode !=============================================================================== subroutine aero_register - !----------------------------------------------------------------------- - ! - ! Register aerosol modes and indices, should be changed to read in values - ! instead of hard-coding it. - ! + + !----------------------------------------------------------------------- + ! Register aerosol modes and indices, should be changed to read in values + ! instead of hard-coding it. !----------------------------------------------------------------------- use mpishorthand @@ -184,42 +183,42 @@ subroutine aero_register use ppgrid, only: pcols, pver, pverp integer :: idx_dum, l,m,mm - logical isAlreadyCounted(pcnst) + logical :: isAlreadyCounted(pcnst) ! register the species - call cnst_get_ind('SO4_NA',l_so4_na, abort=.true.) !Aitken mode sulfate (growth from so4_n) - call cnst_get_ind('SO4_A1',l_so4_a1, abort=.true.) !sulfate condensate (gas phase production) - call cnst_get_ind('SO4_A2',l_so4_a2, abort=.true.) !sulfate produced in aq. chemistry - call cnst_get_ind('SO4_AC',l_so4_ac, abort=.true.) !sulfate from coagulation processes - call cnst_get_ind('SO4_PR',l_so4_pr, abort=.true.) !sulfate emitted as primary + call cnst_get_ind('SO4_NA' ,l_so4_na, abort=.true.) !Aitken mode sulfate (growth from so4_n) + call cnst_get_ind('SO4_A1' ,l_so4_a1, abort=.true.) !sulfate condensate (gas phase production) + call cnst_get_ind('SO4_A2' ,l_so4_a2, abort=.true.) !sulfate produced in aq. chemistry + call cnst_get_ind('SO4_AC' ,l_so4_ac, abort=.true.) !sulfate from coagulation processes + call cnst_get_ind('SO4_PR' ,l_so4_pr, abort=.true.) !sulfate emitted as primary - call cnst_get_ind('BC_N',l_bc_n, abort=.true.) !emissions (mainly industry) lost through coagulation - call cnst_get_ind('BC_AX',l_bc_ax, abort=.true.) !externally mixed (fluffy and impossible to activate) - call cnst_get_ind('BC_NI',l_bc_ni, abort=.true.) !mixed with oc (mainly biomass), externally mixed otherwise (before condensation etc) - call cnst_get_ind('BC_A',l_bc_a, abort=.true.) !formed when bc_n grows by condensation - call cnst_get_ind('BC_AI',l_bc_ai, abort=.true.) !formed when bc_ni grows by condensation - call cnst_get_ind('BC_AC',l_bc_ac, abort=.true.) !bc from coagulation processes + call cnst_get_ind('BC_N' ,l_bc_n, abort=.true.) !emissions (mainly industry) lost through coagulation + call cnst_get_ind('BC_AX' ,l_bc_ax, abort=.true.) !externally mixed (fluffy and impossible to activate) + call cnst_get_ind('BC_NI' ,l_bc_ni, abort=.true.) !mixed with oc (mainly biomass), externally mixed otherwise (before condensation etc) + call cnst_get_ind('BC_A' ,l_bc_a, abort=.true.) !formed when bc_n grows by condensation + call cnst_get_ind('BC_AI' ,l_bc_ai, abort=.true.) !formed when bc_ni grows by condensation + call cnst_get_ind('BC_AC' ,l_bc_ac, abort=.true.) !bc from coagulation processes - call cnst_get_ind('OM_NI',l_om_ni, abort=.true.) !om (mainly from biomass), emitted - call cnst_get_ind('OM_AI',l_om_ai, abort=.true.) !om formed when condensation growth of om_ni - call cnst_get_ind('OM_AC',l_om_ac, abort=.true.) !om from coagulation processes + call cnst_get_ind('OM_NI' ,l_om_ni, abort=.true.) !om (mainly from biomass), emitted + call cnst_get_ind('OM_AI' ,l_om_ai, abort=.true.) !om formed when condensation growth of om_ni + call cnst_get_ind('OM_AC' ,l_om_ac, abort=.true.) !om from coagulation processes - call cnst_get_ind('DST_A2',l_dst_a2, abort=.true.) !Dust accumulation mode - call cnst_get_ind('DST_A3',l_dst_a3, abort=.true.) !Dust coarse mode + call cnst_get_ind('DST_A2' ,l_dst_a2, abort=.true.) !Dust accumulation mode + call cnst_get_ind('DST_A3' ,l_dst_a3, abort=.true.) !Dust coarse mode - call cnst_get_ind('SS_A1',l_ss_a1, abort=.true.) !Sea salt fine mode - call cnst_get_ind('SS_A2',l_ss_a2, abort=.true.) !Sea salt accumulation mode - call cnst_get_ind('SS_A3',l_ss_a3, abort=.true.) !Sea salt coarse mode + call cnst_get_ind('SS_A1' ,l_ss_a1, abort=.true.) !Sea salt fine mode + call cnst_get_ind('SS_A2' ,l_ss_a2, abort=.true.) !Sea salt accumulation mode + call cnst_get_ind('SS_A3' ,l_ss_a3, abort=.true.) !Sea salt coarse mode - !cka: register SOA species - call cnst_get_ind('SOA_NA',l_soa_na, abort=.true.) !Aitken mode SOA with SO4 and SOA condensate - call cnst_get_ind('SOA_A1',l_soa_a1, abort=.true.) !SOA condensate - call cnst_get_ind('SOA_LV',l_soa_lv, abort=.true.) !Gas phase low volatile SOA - call cnst_get_ind('SOA_SV',l_soa_sv, abort=.true.) !Gas phase semi volatile SOA + ! register SOA species + call cnst_get_ind('SOA_NA' ,l_soa_na, abort=.true.) !Aitken mode SOA with SO4 and SOA condensate + call cnst_get_ind('SOA_A1' ,l_soa_a1, abort=.true.) !SOA condensate + call cnst_get_ind('SOA_LV' ,l_soa_lv, abort=.true.) !Gas phase low volatile SOA + call cnst_get_ind('SOA_SV' ,l_soa_sv, abort=.true.) !Gas phase semi volatile SOA !gas phase h2so4 - call cnst_get_ind('H2SO4', l_h2so4, abort=.true.) + call cnst_get_ind('H2SO4' ,l_h2so4, abort=.true.) !Register the tracers in modes call registerTracersInMode() @@ -245,8 +244,8 @@ subroutine aero_register aerosolType(l_ss_a1) = AEROSOL_TYPE_SALT aerosolType(l_ss_a2) = AEROSOL_TYPE_SALT aerosolType(l_ss_a3) = AEROSOL_TYPE_SALT - aerosolType(l_soa_na) = AEROSOL_TYPE_OM - aerosolType(l_soa_a1) = AEROSOL_TYPE_OM + aerosolType(l_soa_na) = AEROSOL_TYPE_OM + aerosolType(l_soa_a1) = AEROSOL_TYPE_OM rhopart(:)= 1000.0_r8 @@ -257,11 +256,11 @@ subroutine aero_register osmoticCoefficient(mm) = aerosol_type_osmotic_coefficient(aerosolType(mm)) rhopart(mm) = aerosol_type_density(aerosolType(mm)) solubleMassFraction(mm) = aerosol_type_soluble_mass_fraction(aerosolType(mm)) - numberOfIons(mm) = aerosol_type_number_of_ions(aerosolType(mm)) + numberOfIons(mm) = aerosol_type_number_of_ions(aerosolType(mm)) end do end do - !SPECIAL CASES OF AEROSOL PROPERTIES: + !SPECIAL CASES OF AEROSOL PROPERTIES: !Density of bc_ax is rewritten later (calculated from fractal dimension) !so4_a2 is different since it is ammonium sulfate and not sulf. acid. rhopart(l_so4_a2) = 1769.0_r8 @@ -324,11 +323,13 @@ subroutine aero_register end subroutine aero_register + !============================================================================= function getNumberOfAerosolTracers()RESULT(numberOfTracers) integer :: numberOfTracers numberOfTracers = n_aerosol_tracers end function getNumberOfAerosolTracers + !============================================================================= function chemistryIndex(phys_index) RESULT (chemistryIndexOut) implicit none integer, intent(in) :: phys_index @@ -336,12 +337,14 @@ function chemistryIndex(phys_index) RESULT (chemistryIndexOut) chemistryIndexOut = phys_index - imozart + 1 end function chemistryIndex + !============================================================================= function physicsIndex(chem_index) RESULT(physIndexOut) integer, intent(in) :: chem_index integer :: physIndexOut physIndexOut = chem_index + imozart - 1 end function physicsIndex + !============================================================================= function isAerosol(phys_index) RESULT(answer) integer, intent(in) :: phys_index logical answer @@ -351,20 +354,22 @@ function isAerosol(phys_index) RESULT(answer) endif return end function isAerosol - !============================================================================= + !============================================================================= function getNumberOfTracersInMode(modeIndex) RESULT(numberOfSpecies) integer, intent(in) :: modeIndex integer numberOfSpecies numberOfSpecies = n_tracers_in_mode(modeIndex) end function getNumberOfTracersInMode + !============================================================================= function getNumberOfBackgroundTracersInMode(modeIndex) RESULT (numberOfBackgroundSpecies) integer, intent(in) :: modeIndex integer numberOfBackgroundSpecies numberOfBackgroundSpecies = n_background_tracers_in_mode(modeIndex) end function getNumberOfBackgroundTracersInMode + !============================================================================= function getTracerIndex(modeIndex, componentIndex, isChemistry) RESULT(tracerIndex) !purpose: Ask for an index in mode !The index is the index in the q-array @@ -381,17 +386,20 @@ function getTracerIndex(modeIndex, componentIndex, isChemistry) RESULT(tracerInd endif end function getTracerIndex - !Obtain an index in the physics-buffer for a component in the lifecycle scheme + !=============================================================================== function getCloudTracerIndex(modeIndex, componentIndex) RESULT(cloud_tracer_index) + + ! Obtain an index in the physics-buffer for a component in the lifecycle scheme + integer, intent(in) :: modeIndex integer, intent(in) :: componentIndex - integer :: tracerIndex - integer cloud_tracer_index + + integer :: tracerIndex + integer :: cloud_tracer_index if(componentIndex == 0)then !Special key for number concentration of a mode - print*,"error no such species" - stop + call endrun("error no such species") else if (componentIndex > 0)then !Lifecycle specie in a mode tracerIndex = getTracerIndex(modeIndex,componentIndex,.false.) @@ -401,14 +409,16 @@ function getCloudTracerIndex(modeIndex, componentIndex) RESULT(cloud_tracer_inde endif end function getCloudTracerIndex - !returns index in pbuf for the corresponding cloud tracer with physics index "tracerIndex" - !returns "-1" if the tracer does not have any corresponding cloud tracer + !=============================================================================== function getCloudTracerIndexDirect(tracerIndex) RESULT(cloudTracerIndexOut) + !returns index in pbuf for the corresponding cloud tracer with physics index "tracerIndex" + !returns "-1" if the tracer does not have any corresponding cloud tracer integer, intent(in) :: tracerIndex integer :: cloudTracerIndexOut cloudTracerIndexOut = cloudTracerIndex(tracerIndex) end function getCloudTracerIndexDirect + !=============================================================================== function getDryDensity(m,l) RESULT(density) integer, intent(in) :: m !mode index integer, intent(in) :: l !tracer index @@ -416,12 +426,14 @@ function getDryDensity(m,l) RESULT(density) density = rhopart(tracer_in_mode(m,l)) end function getDryDensity + !=============================================================================== function getCloudTracerName(tracerIndex) RESULT(cloudTracerNameOut) integer, intent(in) :: tracerIndex character(len=20) :: cloudTracerNameOut cloudTracerNameOut = trim(cloudTracerName(tracerIndex)) end function getCloudTracerName + !=============================================================================== subroutine fillAerosolTracerList(aerosolTracerList) integer, dimension (:), intent(out) :: aerosolTracerList logical, dimension(pcnst) :: alreadyFound @@ -440,6 +452,7 @@ subroutine fillAerosolTracerList(aerosolTracerList) end do end subroutine fillAerosolTracerList + !=============================================================================== subroutine fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) integer, dimension(:), intent(in) :: aerosolTracerList integer, intent(in) :: n_aerosol_tracers @@ -452,6 +465,7 @@ subroutine fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerL end do end subroutine fillInverseAerosolTracerList + !=============================================================================== subroutine registerTracersInMode() !Register tracer index in modes tracer_in_mode(:,:) = -1 !undefined @@ -459,18 +473,18 @@ subroutine registerTracersInMode() !externally mixed bc tracer_in_mode(MODE_IDX_BC_EXT_AC, 1:n_tracers_in_mode(MODE_IDX_BC_EXT_AC)) = (/l_bc_ax/) - !sulphate + soa, sulfate condensate. + !sulphate + soa, sulfate condensate. tracer_in_mode(MODE_IDX_SO4SOA_AIT, 1:n_tracers_in_mode(MODE_IDX_SO4SOA_AIT) ) = & - (/l_so4_na, l_soa_na, l_so4_a1, l_soa_a1/) + (/l_so4_na, l_soa_na, l_so4_a1, l_soa_a1/) - !bc + sulfate condensate + !bc + sulfate condensate tracer_in_mode(MODE_IDX_BC_AIT,1:n_tracers_in_mode(MODE_IDX_BC_AIT)) = & - (/l_bc_a, l_so4_a1, l_soa_a1/) + (/l_bc_a, l_so4_a1, l_soa_a1/) !index not used !tracer_in_mode(MODE_IDX_NOT_USED, 1:n_tracers_in_mode(MODE_IDX_NOT_USED)) = (/-1/) - !om / bc internally mixed with sulfate condensate and aquous phase sulfate + !om / bc internally mixed with sulfate condensate and aquous phase sulfate tracer_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT))= & (/l_bc_ai, l_om_ai, l_so4_a1, l_so4_a2, l_soa_a1 /) @@ -480,7 +494,7 @@ subroutine registerTracersInMode() !ac-mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate tracer_in_mode(MODE_IDX_DST_A2, 1:n_tracers_in_mode(MODE_IDX_DST_A2)) = & -(/l_dst_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) + (/l_dst_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) !coarse mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate tracer_in_mode(MODE_IDX_DST_A3, 1:n_tracers_in_mode(MODE_IDX_DST_A3)) = & @@ -511,11 +525,12 @@ subroutine registerTracersInMode() tracer_in_mode(MODE_IDX_OMBC_INTMIX_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_AIT)) = (/l_bc_ni, l_om_ni/) end subroutine registerTracersInMode + !=============================================================================== function isTracerInMode(modeIndex, constituentIndex)RESULT(answer) integer, intent(in) :: modeIndex integer, intent(in) :: constituentIndex integer :: i - logical :: answer + logical :: answer answer = .FALSE. do i=1,n_tracers_in_mode(modeIndex) if(tracer_in_mode(modeIndex,i) == constituentIndex)then @@ -525,8 +540,10 @@ function isTracerInMode(modeIndex, constituentIndex)RESULT(answer) return end function isTracerInMode + !=============================================================================== function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond,f_soa & ,Cam, f_acm, f_bcm, f_aqm, f_so4_condm,f_soam, constituentIndex,debugPrint ) RESULT(fraction) ! mass fraction + real(r8), intent(in) :: CProcessModes real(r8), intent(in) :: f_c real(r8), intent(in) :: f_bc @@ -545,27 +562,27 @@ function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond,f_soa real(r8) :: fraction if(present(debugPrint))then - if(debugPrint .eqv. .true.)then + if(debugPrint) then doPrint=.true. endif endif - fraction = 1.0_r8 ! fraction = 1 for all tracers, except special cases (process modes) below + fraction = 1.0_r8 ! fraction = 1 for all tracers, except special cases (process modes) below !This fraction is the mass of a certain tracer in a specific size-mode divided by the total - !mass of the same tracer for (i.e. summed up over) all size-modes. This total mass is what - !is transported in the model, in the life cycle scheme. The word size-mode is here used for a mode in the - !aerosol size-distribution, which is assumed to be log-normal prior to growth. + !mass of the same tracer for (i.e. summed up over) all size-modes. This total mass is what + !is transported in the model, in the life cycle scheme. The word size-mode is here used for a mode in the + !aerosol size-distribution, which is assumed to be log-normal prior to growth. if((l_so4_a1 .eq. constituentIndex))then !so4 condensation - fraction= (cam & - *(1.0_r8-f_acm) & !sulfate fraction - *(1.0_r8-f_aqm) & !fraction not from aq phase - *(f_so4_condm) & !fraction being condensate - ) & - / & - (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*f_so4_cond+smallConcentration) !total so4 condensate - - if(doPrint .eqv. .true.)then + fraction= (cam & + *(1.0_r8-f_acm) & !sulfate fraction + *(1.0_r8-f_aqm) & !fraction not from aq phase + *(f_so4_condm) & !fraction being condensate + ) & + / & + (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*f_so4_cond+smallConcentration) !total so4 condensate + + if (doPrint) then print*, " " print*, "conc ==>", CProcessmodes, cam print*, "modefrc ==>", f_acm, f_aqm, f_so4_condm @@ -592,10 +609,10 @@ function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond,f_soa else if(l_bc_ac .eq. constituentIndex)then !bc coagulated fraction = (cam & - *f_acm & ! carbonaceous fraction + *f_acm & ! carbonaceous fraction *f_bcm) & ! bc fraction of carbonaceous / & - (CProcessModes*f_c*f_bc+smallConcentration) + (CProcessModes*f_c*f_bc+smallConcentration) else if(l_om_ac .eq. constituentIndex ) then !oc coagulated fraction = (cam & @@ -619,7 +636,7 @@ function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond,f_soa endif end function getConstituentFraction - !********************************************** + !=============================================================================== subroutine inittabrh() ! Tables for hygroscopic growth @@ -628,7 +645,7 @@ subroutine inittabrh() real(r8) :: rr0ss(10),rr0so4(10),rr0bcoc(10) data rr0ss / 1.00_r8, 1.00_r8, 1.02_r8, 1.57_r8, 1.88_r8, 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 3.62_r8 / - data rr0so4 / 1.00_r8, 1.34_r8, 1.39_r8, 1.52_r8, 1.62_r8, 1.69_r8, 1.78_r8, 1.92_r8, 2.22_r8, 2.79_r8 / + data rr0so4 / 1.00_r8, 1.34_r8, 1.39_r8, 1.52_r8, 1.62_r8, 1.69_r8, 1.78_r8, 1.92_r8, 2.22_r8, 2.79_r8 / data rr0bcoc / 1.00_r8, 1.02_r8, 1.03_r8, 1.12_r8, 1.17_r8, 1.20_r8, 1.25_r8, 1.31_r8, 1.46_r8, 1.71_r8 / rdivr0(:,:)=1._r8 @@ -640,7 +657,7 @@ subroutine inittabrh() rdivr0(i,l_so4_ac)=rr0so4(i) rdivr0(i,l_so4_pr)=rr0so4(i) - rdivr0(i,l_bc_a)=rr0bcoc(i) + rdivr0(i,l_bc_a)=rr0bcoc(i) rdivr0(i,l_bc_ni)=rr0bcoc(i) rdivr0(i,l_bc_ai)=rr0bcoc(i) @@ -658,6 +675,7 @@ subroutine inittabrh() end do end subroutine inittabrh + !=============================================================================== subroutine qqcw_set_ptr(index, iptr) integer, intent(in) :: index, iptr if(index>0 .and. index <= pcnst ) then @@ -667,6 +685,7 @@ subroutine qqcw_set_ptr(index, iptr) end if end subroutine qqcw_set_ptr + !=============================================================================== function qqcw_get_field(pbuf, index) use physics_buffer, only : physics_buffer_desc, pbuf_get_field @@ -676,12 +695,10 @@ function qqcw_get_field(pbuf, index) nullify(qqcw_get_field) if (index>0 .and. index <= pcnst) then - if (qqcw(index)>0) then + if (qqcw(index)>0) then call pbuf_get_field(pbuf, qqcw(index), qqcw_get_field) endif end if end function qqcw_get_field end module aerosoldef - - diff --git a/src/chemistry/oslo_aero/const.F90 b/src/chemistry/oslo_aero/const.F90 index 1dadac56c2..0733e3432f 100644 --- a/src/chemistry/oslo_aero/const.F90 +++ b/src/chemistry/oslo_aero/const.F90 @@ -7,7 +7,7 @@ module const use shr_kind_mod, only: r8 => shr_kind_r8 use commondefinitions, only: nmodes use physconst, only: pi - ! + ! implicit none public diff --git a/src/physics/cam_oslo/dust_model.F90 b/src/chemistry/oslo_aero/dust_model.F90 similarity index 100% rename from src/physics/cam_oslo/dust_model.F90 rename to src/chemistry/oslo_aero/dust_model.F90 diff --git a/src/chemistry/oslo_aero/oslo_aero_deposition.F90 b/src/chemistry/oslo_aero/oslo_aero_deposition.F90 new file mode 100644 index 0000000000..28e16369a2 --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_aero_deposition.F90 @@ -0,0 +1,3 @@ +module oslo_aero_deposition + +end module oslo_aero_deposition diff --git a/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 b/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 index 4f52d83d15..4f8ff72c7b 100644 --- a/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 +++ b/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 @@ -1,96 +1,73 @@ module oslo_aerosols_intr + !------------------------------------------------------------------------------------------------ + ! Partition the contributions from modal components of wet and dry + ! deposition at the surface into the fields passed to the coupler. + !------------------------------------------------------------------------------------------------ + + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, cnst_name, cnst_get_ind + use ppgrid, only: pcols, pver, pverp, begchunk, endchunk + use phys_control, only: phys_getopts + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use camsrfexch, only: cam_in_t, cam_out_t + use time_manager, only: is_first_step + use aerodep_flx, only: aerodep_flx_prescribed + use mo_drydep, only: n_land_type, fraction_landuse + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk + use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field + use physconst, only: gravit, rair, rhoh2o, boltz, pi + use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only + use ref_pres, only: top_lev => clim_modal_aero_top_lev + use drydep_mod, only: d3ddflux, calcram + use dust_sediment_mod, only: dust_sediment_tend, dust_sediment_vel + ! use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac + ! use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 use aerosoldef use commondefinitions - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst, cnst_name, cnst_get_ind - use ppgrid, only: pcols, pver, pverp - use phys_control, only: phys_getopts - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use perf_mod, only: t_startf, t_stopf - use camsrfexch, only: cam_in_t, cam_out_t - use aerodep_flx, only: aerodep_flx_prescribed - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc - use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field - use physconst, only: gravit, rair, rhoh2o - use cam_history, only: outfld, fieldname_len - use chem_mods, only: gas_pcnst, adv_mass - use mo_tracname, only: solsym - - use ref_pres, only: top_lev => clim_modal_aero_top_lev - - use modal_aero_wateruptake, only: modal_strat_sulfate - use mo_setsox, only: setsox, has_sox implicit none - private ! Make default type private to the module - save - - ! ! Public interfaces - ! - public :: oslo_aero_wet_intr ! interface to wet deposition public :: sol_facti_cloud_borne public :: oslo_aero_dry_intr ! interface to dry deposition public :: oslo_aero_initialize - logical :: inv_o3, inv_oh, inv_no3, inv_ho2 - integer, pointer :: id_so2, id_so4, id_dms, id_o3, id_h2o2, id_oh, id_no3, id_ho2 - integer, target :: spc_ids(8) - - integer :: fracis_idx = 0 - integer :: prain_idx = 0 - integer :: rprddp_idx = 0 - integer :: rprdsh_idx = 0 - integer :: nevapr_shcu_idx = 0 - integer :: nevapr_dpcu_idx = 0 + private :: modal_aero_depvel_part + private :: oslo_set_srf_drydep + private :: oslo_set_srf_wetdep + + integer :: fracis_idx = 0 + integer :: prain_idx = 0 + integer :: rprddp_idx = 0 + integer :: rprdsh_idx = 0 + integer :: nevapr_shcu_idx = 0 + integer :: nevapr_dpcu_idx = 0 + logical :: convproc_do_aer = .FALSE. real(r8) :: sol_facti_cloud_borne + logical :: drydep_lq(pcnst) + logical :: wetdep_lq(pcnst) -! variables for table lookup of aerosol impaction/interception scavenging rates - integer, parameter :: nimptblgrow_mind=-7, nimptblgrow_maxd=12 - real(r8) dlndg_nimptblgrow - real(r8) scavimptblnum(nimptblgrow_mind:nimptblgrow_maxd, nmodes) - real(r8) scavimptblvol(nimptblgrow_mind:nimptblgrow_maxd, nmodes) - - - integer :: ndrydep = 0 - integer,allocatable :: drydep_indices(:) - integer :: nwetdep = 0 - integer,allocatable :: wetdep_indices(:) - logical :: drydep_lq(pcnst) - logical :: wetdep_lq(pcnst) - - logical :: convproc_do_aer = .FALSE. - +!=============================================================================== contains +!=============================================================================== - !=============================================================================== subroutine oslo_aero_initialize(pbuf2d ) - use cam_history, only : addfld, add_default, horiz_only - use mo_chem_utls, only : get_inv_ndx - use gas_wetdep_opts, only : gas_wetdep_list, gas_wetdep_cnt - use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk - use ppgrid, only: pcols, pver, begchunk, endchunk - use time_manager, only: is_first_step type(physics_buffer_desc), pointer :: pbuf2d(:,:) - integer :: m - integer :: l - integer :: i - integer :: lchnk - integer :: tracerIndex - integer :: astat, id - real(r8), pointer :: qqcw(:,:) - - logical :: history_aerosol ! Output the MAM aerosol tendencies - character(len=2) :: unit_basename='kg' ! Units 'kg' or '1' - character(len=100) :: aName ! tracer name + integer :: m, l, i + integer :: lchnk + integer :: tracerIndex + integer :: astat, id + real(r8), pointer :: qqcw(:,:) + logical :: history_aerosol ! Output the MAM aerosol tendencies + character(len=2) :: unit_basename='kg' ! Units 'kg' or '1' + character(len=100) :: aName ! tracer name logical :: is_in_output(pcnst) !----------------------------------------------------------------------- @@ -111,7 +88,6 @@ subroutine oslo_aero_initialize(pbuf2d ) do l=1,getNumberOfTracersInMode(m) tracerIndex = getTracerIndex(m,l,.false.) - drydep_lq(tracerIndex)=.true. wetdep_lq(tracerIndex)=.true. @@ -121,18 +97,18 @@ subroutine oslo_aero_initialize(pbuf2d ) aName = cnst_name(tracerIndex) - print*, m,l,tracerIndex, trim(aName) + !print*, m,l,tracerIndex, trim(aName) call addfld (trim(aName)//'SFWET',horiz_only, 'A', unit_basename//'/m2/s', & - 'Wet deposition flux at surface') + 'Wet deposition flux at surface') call addfld (trim(aName)//'SFSIC',horiz_only, 'A', unit_basename//'/m2/s ', & - 'Wet deposition flux (incloud, convective) at surface') + 'Wet deposition flux (incloud, convective) at surface') call addfld (trim(aName)//'SFSIS',horiz_only, 'A', unit_basename//'/m2/s ', & - 'Wet deposition flux (incloud, stratiform) at surface') + 'Wet deposition flux (incloud, stratiform) at surface') call addfld (trim(aName)//'SFSBC',horiz_only, 'A', unit_basename//'/m2/s ', & - 'Wet deposition flux (belowcloud, convective) at surface') + 'Wet deposition flux (belowcloud, convective) at surface') call addfld (trim(aName)//'SFSBS',horiz_only, 'A', unit_basename//'/m2/s ', & - 'Wet deposition flux (belowcloud, stratiform) at surface') + 'Wet deposition flux (belowcloud, stratiform) at surface') call addfld (trim(aName)//'WET',(/'lev'/), 'A', unit_basename//'/kg/s ','wet deposition tendency') call addfld (trim(aName)//'SIC',(/'lev'/), 'A', unit_basename//'/kg/s ', & trim(aName)//' ic wet deposition') @@ -142,7 +118,7 @@ subroutine oslo_aero_initialize(pbuf2d ) trim(aName)//' bc wet deposition') call addfld (trim(aName)//'SBS',(/'lev'/), 'A', unit_basename//'/kg/s ', & trim(aName)//' bs wet deposition') - + !Extra wd ouptut if ( history_aerosol ) then call add_default (trim(aName)//'SFWET', 1, ' ') @@ -180,9 +156,9 @@ subroutine oslo_aero_initialize(pbuf2d ) aName = trim(getCloudTracerName(tracerIndex)) !Cloud water fields (from mo_chm_diags.F90) call addfld (trim(aName)//'SFWET', horiz_only, 'A', unit_basename//'/m2/s', & - trim(aName)//' wet deposition flux at surface') + trim(aName)//' wet deposition flux at surface') call addfld (trim(aName)//'SFSIC', horiz_only, 'A',unit_basename//'/m2/s ', & - trim(aName)//' wet deposition flux (incloud, convective) at surface') + trim(aName)//' wet deposition flux (incloud, convective) at surface') call addfld (trim(aName)//'SFSIS', horiz_only, 'A', unit_basename//'/m2/s ', & trim(aName)//' wet deposition flux (incloud, stratiform) at surface') call addfld (trim(aName)//'SFSBC', horiz_only, 'A', unit_basename//'/m2/s ' , & @@ -199,11 +175,10 @@ subroutine oslo_aero_initialize(pbuf2d ) is_in_output(tracerIndex) = .true. - end do !tracers + end do !tracers enddo !modes !initialize cloud concentrations - if (is_first_step()) then ! initialize cloud bourne constituents in physics buffer do i = 1, pcnst @@ -218,36 +193,26 @@ subroutine oslo_aero_initialize(pbuf2d ) end subroutine oslo_aero_initialize + !=============================================================================== subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend, & - dgncur_awet, wetdens, dgncur_awet_processmode, wetdens_processmode, cflx) - - use cam_history, only: outfld - use ppgrid, only: pverp - use physics_types, only: physics_state, physics_ptend - use camsrfexch, only: cam_out_t - use physconst, only: gravit, rair, rhoh2o - use drydep_mod, only: setdvel, d3ddflux, calcram - use dust_sediment_mod, only: dust_sediment_tend, dust_sediment_vel - use modal_aero_deposition, only: set_srf_drydep - use physics_buffer, only : physics_buffer_desc + dgncur_awet, wetdens, dgncur_awet_processmode, wetdens_processmode, cflx) ! Arguments: - type(physics_state), intent(in) :: state ! Physics state variables - real(r8), intent(in) :: obklen(:) - real(r8), intent(in) :: ustar(:) ! sfc fric vel - type(cam_in_t), target, intent(in) :: cam_in ! import state - real(r8), intent(in) :: dt ! time step - type(cam_out_t), intent(inout) :: cam_out ! export state - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + type(physics_state), intent(in) :: state ! Physics state variables type(physics_buffer_desc), pointer :: pbuf(:) - ! - real(r8), intent(in) :: dgncur_awet(pcols,pver,0:nmodes) - real(r8), intent(in) :: wetdens(pcols,pver,0:nmodes) - real(r8), intent(in) :: dgncur_awet_processmode(pcols, pver, numberOfProcessModeTracers) - real(r8), intent(in) :: wetdens_processmode(pcols, pver, numberOfProcessModeTracers) - real(r8), intent(in) :: cflx(pcols,pcnst) !Surface fluxes - - ! local vars + real(r8), intent(in) :: obklen(:) + real(r8), intent(in) :: ustar(:) ! sfc fric vel + type(cam_in_t), target, intent(in) :: cam_in ! import state + real(r8), intent(in) :: dt ! time step + type(cam_out_t), intent(inout) :: cam_out ! export state + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + real(r8), intent(in) :: dgncur_awet(pcols,pver,0:nmodes) + real(r8), intent(in) :: wetdens(pcols,pver,0:nmodes) + real(r8), intent(in) :: dgncur_awet_processmode(pcols, pver, numberOfProcessModeTracers) + real(r8), intent(in) :: wetdens_processmode(pcols, pver, numberOfProcessModeTracers) + real(r8), intent(in) :: cflx(pcols,pcnst) ! Surface fluxes + + ! local vars real(r8), pointer :: landfrac(:) ! land fraction real(r8), pointer :: icefrac(:) ! ice fraction real(r8), pointer :: ocnfrac(:) ! ocean fraction @@ -288,14 +253,13 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out real(r8) :: aerdepdrycw(pcols,pcnst) ! aerosol dry deposition (cloud water) real(r8), pointer :: fldcw(:,:) - !++oslo aerosols + !oslo aerosols real(r8) :: interfaceTendToLowestLayer(pcols) real(r8) :: deltaH(pcols) real(r8) :: massLostDD(pcols) real(r8) :: MMRNew(pcols) real(r8) :: lossRate(pcols) real(r8) :: totalProd(pcols) - real(r8) :: fallFromAbove(pcols) real(r8) :: logSigma logical :: is_done(pcnst,2) @@ -311,40 +275,42 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out ncol = state%ncol aerdepdryis(:,:)=0._r8 aerdepdrycw(:,:)=0._r8 + ! calc ram and fv over ocean and sea ice ... call calcram( ncol,landfrac,icefrac,ocnfrac,obklen,& - ustar,ram1in,ram1,state%t(:,pver),state%pmid(:,pver),& - state%pdel(:,pver),fvin,fv) + ustar,ram1in,ram1,state%t(:,pver),state%pmid(:,pver),& + state%pdel(:,pver),fvin,fv) call outfld( 'airFV', fv(:), pcols, lchnk ) call outfld( 'RAM1', ram1(:), pcols, lchnk ) - + ! note that tendencies are not only in sfc layer (because of sedimentation) ! and that ptend is updated within each subroutine for different species - + call physics_ptend_init(ptend, state%psetcols, 'aero_model_drydep', lq=drydep_lq) tvs(:ncol,:) = state%t(:ncol,:)!*(1+state%q(:ncol,k) rho(:ncol,:)= state%pmid(:ncol,:)/(rair*state%t(:ncol,:)) - is_done(:,:) = .false. -! -! calc settling/deposition velocities for cloud droplets (and cloud-borne aerosols) -! -! *** mean drop radius should eventually be computed from ndrop and qcldwtr + ! + ! calc settling/deposition velocities for cloud droplets (and cloud-borne aerosols) + ! + ! *** mean drop radius should eventually be computed from ndrop and qcldwtr rad_drop(:,:) = 5.0e-6_r8 dens_drop(:,:) = rhoh2o sg_drop(:,:) = 1.46_r8 + !jvlc = 3 !call modal_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & ! vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & ! rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 0, lchnk) + jvlc = 4 call modal_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & - vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 3, lchnk) + vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & + rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 3, lchnk) @@ -356,203 +322,204 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out !The following logic is based on that process-mode tracers !always follow AFTER the actual tracers!! - dens_aer(:,:) = 0._r8 - do m = 0, nmodes ! main loop over aerosol modes + dens_aer(:,:) = 0._r8 + do m = 0, nmodes ! main loop over aerosol modes do lphase = 1, 2 ! loop over interstitial / cloud-borne forms if (lphase == 1) then ! interstial aerosol - calc settling/dep velocities of mode - logSigma = log(lifeCycleSigma(m)) + logSigma = log(lifeCycleSigma(m)) ! rad_aer = volume mean wet radius (m) ! dgncur_awet = geometric mean wet diameter for number distribution (m) - if(top_lev.gt.1) then - rad_aer(1:ncol,:top_lev-1) = 0._r8 + if(top_lev .gt. 1) then + rad_aer(1:ncol,:top_lev-1) = 0._r8 end if - rad_aer(1:ncol,top_lev:) = 0.5_r8*dgncur_awet(1:ncol,top_lev:,m) & - *exp(1.5_r8*(logSigma)) + rad_aer(1:ncol,top_lev:) = 0.5_r8*dgncur_awet(1:ncol,top_lev:,m) *exp(1.5_r8*(logSigma)) ! dens_aer(1:ncol,:) = wet density (kg/m3) if(top_lev.gt.1)then - dens_aer(1:ncol,:top_lev-1) = 0._r8 + dens_aer(1:ncol,:top_lev-1) = 0._r8 end if dens_aer(1:ncol,top_lev:) = wetdens(1:ncol,top_lev:,m) + sg_aer(1:ncol,:) = lifecycleSigma(m) jvlc = 2 call modal_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & - vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) - -! if(m .eq. MODE_IDX_SS_A3)then -! do i=1,ncol -! print*, "rad_aer", rad_aer(i,pver)*1.e6, ' um ', vlc_dry(i,pver,jvlc)*1.e2, " cm/s" -! end do -! end if + vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & + rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) + + ! if(m .eq. MODE_IDX_SS_A3)then + ! do i=1,ncol + ! print*, "rad_aer", rad_aer(i,pver)*1.e6, ' um ', vlc_dry(i,pver,jvlc)*1.e2, " cm/s" + ! end do + ! end if end if do lspec = 1, getNumberOfTracersInMode(m) ! loop over number + constituents - mm = getTracerIndex(m,lspec,.false.) - if(is_done(mm,lphase) .eqv. .true. )then - cycle - endif - is_done(mm,lphase)=.true. - - if (lphase == 1) then - jvlc = 2 !mass in clean air tracers - - !Process tracers have their own velocity based on fixed size / density - !Calculate the velocity to use for this specie.. - if ( is_process_mode(mm, .false.) ) then - jvlc = 1 - logSigma = log(processModeSigma(processModeMap(mm))) - if(top_lev.gt.1)then - rad_aer(1:ncol, top_lev-1) = 0.0_r8 - end if - rad_aer(1:ncol,top_lev:) = 0.5_r8*dgncur_awet_processmode(1:ncol,top_lev:,processModeMap(mm)) & - *exp(1.5_r8*(logSigma)) - call modal_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & - vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) + mm = getTracerIndex(m,lspec,.false.) + if(is_done(mm,lphase) .eqv. .true. )then + cycle endif + is_done(mm,lphase)=.true. - else - jvlc = 4 !mass in cloud tracers - endif + if (lphase == 1) then + jvlc = 2 !mass in clean air tracers + + !Process tracers have their own velocity based on fixed size / density + !Calculate the velocity to use for this specie.. + if ( is_process_mode(mm, .false.) ) then + jvlc = 1 + logSigma = log(processModeSigma(processModeMap(mm))) + if(top_lev.gt.1)then + rad_aer(1:ncol, top_lev-1) = 0.0_r8 + end if + rad_aer(1:ncol,top_lev:) = 0.5_r8*dgncur_awet_processmode(1:ncol,top_lev:,processModeMap(mm)) & + *exp(1.5_r8*(logSigma)) - if (mm <= 0) cycle + call modal_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & + vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & + rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) + endif -! if (lphase == 1) then - if ((lphase == 1) .and. (lspec <= getNumberOfTracersInMode(m))) then - ptend%lq(mm) = .TRUE. + else + jvlc = 4 !mass in cloud tracers + endif - ! use pvprogseasalts instead (means making the top level 0) - pvmzaer(:ncol,1)=0._r8 - pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) + if (mm <= 0) cycle - call outfld( trim(cnst_name(mm))//'DDV', pvmzaer(:,2:pverp), pcols, lchnk ) + ! if (lphase == 1) then + if ((lphase == 1) .and. (lspec <= getNumberOfTracersInMode(m))) then + ptend%lq(mm) = .TRUE. - if(.true.) then ! use phil's method - ! convert from meters/sec to pascals/sec - ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion - pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit + ! use pvprogseasalts instead (means making the top level 0) + pvmzaer(:ncol,1)=0._r8 + pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) - ! calculate the tendencies and sfc fluxes from the above velocities - call dust_sediment_tend( & - ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, interfaceTendToLowestLayer ) - else !use charlie's method - call d3ddflux( ncol, vlc_dry(:,:,jvlc), state%q(:,:,mm), state%pmid, & - state%pdel, tvs, sflx, ptend%q(:,:,mm), dt ) - endif + call outfld( trim(cnst_name(mm))//'DDV', pvmzaer(:,2:pverp), pcols, lchnk ) - !write(iulog,*)"starting ddep proc", mm, pcnst - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - !%%%%%% FIX FOR SHORT DRYDEP LIFE-TIMES - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - !Some tracers have short lifetime with respect to dry dep: - !Solve implicitly for eqn for emission and dry dep in lowest layer - deltaH(:ncol)=state%pdel(:ncol,pver)/rho(:ncol,pver)/gravit ![m] height of layer - !print*, "deltaH", deltaH(:ncol) - lossRate(:ncol) = vlc_dry(:ncol,pver,jvlc)/deltaH(:ncol) ![1/s] loss rate out of layer - !print*, "lossRate", lossRate(:ncol) - !print*, "interfaceFluxesToLowestLayer", interfaceFluxToLowestLayer(:ncol) - - !OBS OBS OBS DIRTY FIX but need approx 2-3 weeks for proper solution - !special treatment of BC_AX because BC_AX is not treated with - !boundary mixing in activation (is by definition not activated!) - !Therefor emissions are already added in "normal" boundary layer - !mixing routine.. - !The proper fix to this is to skip the special treatment of BC_AX - !and skip the index "0" for that mixture alltogether! - if(mm .eq. l_bc_ax) then - totalProd(:ncol) = interfaceTendToLowestLayer(:ncol) - else - totalProd(:ncol) = cflx(:ncol,mm)*gravit/state%pdel(:ncol,pver) + interfaceTendToLowestLayer(:ncol) - end if + if(.true.) then ! use phil's method + ! convert from meters/sec to pascals/sec + ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion + pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit - !Do solution - where(lossRate(:ncol)*dt .gt. 1.e-2_r8) - MMRNew(:ncol) = state%q(:ncol,pver,mm)*exp(-lossRate(:ncol)*dt) & - + totalProd(:ncol)/lossRate(:ncol)*(1.0_r8 - exp(-lossRate(:ncol)*dt)) - elsewhere - MMRNew(:ncol) = state%q(:ncol,pver,mm) & - + totalProd(:ncol)*dt & - - state%q(:ncol,pver,mm)*lossRate(:ncol)*dt - end where - - !C0 + Pdt -massLostDD = CNew ==> - massLostDD(:ncol) = state%q(:ncol,pver,mm) - MMRNew(:ncol) + totalProd(:ncol)*dt - !Overwrite tendency in lowest layer to include emissions - !They are then not included in vertical diffusion!! - ptend%q(:ncol,pver,mm) = (MMRNew(:ncol)-state%q(:ncol,pver,mm))/dt - sflx(:ncol) = massLostDD(:ncol)*state%pdel(:ncol,pver) / gravit / dt - !write(iulog,*)"done ddep" - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - ! apportion dry deposition into turb and gravitational settling for tapes - dep_trb = 0._r8 - dep_grv = 0._r8 - do i=1,ncol - if (vlc_dry(i,pver,jvlc) /= 0._r8) then - dep_trb(i)=sflx(i)*vlc_trb(i,jvlc)/vlc_dry(i,pver,jvlc) - dep_grv(i)=sflx(i)*vlc_grv(i,pver,jvlc)/vlc_dry(i,pver,jvlc) + ! calculate the tendencies and sfc fluxes from the above velocities + call dust_sediment_tend( & + ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & + state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, interfaceTendToLowestLayer ) + else !use charlie's method + call d3ddflux( ncol, vlc_dry(:,:,jvlc), state%q(:,:,mm), state%pmid, & + state%pdel, tvs, sflx, ptend%q(:,:,mm), dt ) endif - enddo - call outfld( trim(cnst_name(mm))//'DDF', sflx, pcols, lchnk) - call outfld( trim(cnst_name(mm))//'TBF', dep_trb, pcols, lchnk ) - call outfld( trim(cnst_name(mm))//'GVF', dep_grv, pcols, lchnk ) - call outfld( trim(cnst_name(mm))//'DTQ', ptend%q(:,:,mm), pcols, lchnk) - aerdepdryis(:ncol,mm) = sflx(:ncol) + !write(iulog,*)"starting ddep proc", mm, pcnst + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !%%%%%% FIX FOR SHORT DRYDEP LIFE-TIMES + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !Some tracers have short lifetime with respect to dry dep: + !Solve implicitly for eqn for emission and dry dep in lowest layer + deltaH(:ncol)=state%pdel(:ncol,pver)/rho(:ncol,pver)/gravit ![m] height of layer + !print*, "deltaH", deltaH(:ncol) + lossRate(:ncol) = vlc_dry(:ncol,pver,jvlc)/deltaH(:ncol) ![1/s] loss rate out of layer + !print*, "lossRate", lossRate(:ncol) + !print*, "interfaceFluxesToLowestLayer", interfaceFluxToLowestLayer(:ncol) + + !OBS OBS OBS DIRTY FIX but need approx 2-3 weeks for proper solution + !special treatment of BC_AX because BC_AX is not treated with + !boundary mixing in activation (is by definition not activated!) + !Therefor emissions are already added in "normal" boundary layer + !mixing routine.. + !The proper fix to this is to skip the special treatment of BC_AX + !and skip the index "0" for that mixture alltogether! + if(mm .eq. l_bc_ax) then + totalProd(:ncol) = interfaceTendToLowestLayer(:ncol) + else + totalProd(:ncol) = cflx(:ncol,mm)*gravit/state%pdel(:ncol,pver) + interfaceTendToLowestLayer(:ncol) + end if - else ! lphase == 2 + !Do solution + where(lossRate(:ncol)*dt .gt. 1.e-2_r8) + MMRNew(:ncol) = state%q(:ncol,pver,mm)*exp(-lossRate(:ncol)*dt) & + + totalProd(:ncol)/lossRate(:ncol)*(1.0_r8 - exp(-lossRate(:ncol)*dt)) + elsewhere + MMRNew(:ncol) = state%q(:ncol,pver,mm) & + + totalProd(:ncol)*dt & + - state%q(:ncol,pver,mm)*lossRate(:ncol)*dt + end where + + !C0 + Pdt -massLostDD = CNew ==> + massLostDD(:ncol) = state%q(:ncol,pver,mm) - MMRNew(:ncol) + totalProd(:ncol)*dt + !Overwrite tendency in lowest layer to include emissions + !They are then not included in vertical diffusion!! + ptend%q(:ncol,pver,mm) = (MMRNew(:ncol)-state%q(:ncol,pver,mm))/dt + sflx(:ncol) = massLostDD(:ncol)*state%pdel(:ncol,pver) / gravit / dt + !write(iulog,*)"done ddep" + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! apportion dry deposition into turb and gravitational settling for tapes + dep_trb = 0._r8 + dep_grv = 0._r8 + do i=1,ncol + if (vlc_dry(i,pver,jvlc) /= 0._r8) then + dep_trb(i)=sflx(i)*vlc_trb(i,jvlc)/vlc_dry(i,pver,jvlc) + dep_grv(i)=sflx(i)*vlc_grv(i,pver,jvlc)/vlc_dry(i,pver,jvlc) + endif + enddo - !Pick up the cloud tracers (oslo) - fldcw => qqcw_get_field(pbuf, mm) - if( .not. associated(fldcw))then - cycle - end if + call outfld( trim(cnst_name(mm))//'DDF', sflx, pcols, lchnk) + call outfld( trim(cnst_name(mm))//'TBF', dep_trb, pcols, lchnk ) + call outfld( trim(cnst_name(mm))//'GVF', dep_grv, pcols, lchnk ) + call outfld( trim(cnst_name(mm))//'DTQ', ptend%q(:,:,mm), pcols, lchnk) + aerdepdryis(:ncol,mm) = sflx(:ncol) - ! use pvprogseasalts instead (means making the top level 0) - pvmzaer(:ncol,1)=0._r8 - pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) + else ! lphase == 2 + !Pick up the cloud tracers (oslo) + fldcw => qqcw_get_field(pbuf, mm) + if( .not. associated(fldcw))then + cycle + end if - if(.true.) then ! use phil's method - ! convert from meters/sec to pascals/sec - ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion - pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit + ! use pvprogseasalts instead (means making the top level 0) + pvmzaer(:ncol,1)=0._r8 + pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) - ! calculate the tendencies and sfc fluxes from the above velocities - call dust_sediment_tend( & - ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - fldcw(:,:), pvmzaer, dqdt_tmp(:,:), sflx ) - else !use charlie's method - call d3ddflux( ncol, vlc_dry(:,:,jvlc), fldcw(:,:), state%pmid, & - state%pdel, tvs, sflx, dqdt_tmp(:,:), dt ) - endif - ! apportion dry deposition into turb and gravitational settling for tapes - dep_trb = 0._r8 - dep_grv = 0._r8 - do i=1,ncol - if (vlc_dry(i,pver,jvlc) /= 0._r8) then - dep_trb(i)=sflx(i)*vlc_trb(i,jvlc)/vlc_dry(i,pver,jvlc) - dep_grv(i)=sflx(i)*vlc_grv(i,pver,jvlc)/vlc_dry(i,pver,jvlc) - end if - enddo + if(.true.) then ! use phil's method + ! convert from meters/sec to pascals/sec + ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion + pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit - fldcw(1:ncol,:) = fldcw(1:ncol,:) + dqdt_tmp(1:ncol,:) * dt + ! calculate the tendencies and sfc fluxes from the above velocities + call dust_sediment_tend( & + ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & + fldcw(:,:), pvmzaer, dqdt_tmp(:,:), sflx ) + else !use charlie's method + call d3ddflux( ncol, vlc_dry(:,:,jvlc), fldcw(:,:), state%pmid, & + state%pdel, tvs, sflx, dqdt_tmp(:,:), dt ) + endif - call outfld( trim(getCloudTracerName(mm))//'DDF', sflx, pcols, lchnk) - call outfld( trim(getCloudTracerName(mm))//'TBF', dep_trb, pcols, lchnk ) - call outfld( trim(getCloudTracerName(mm))//'GVF', dep_grv, pcols, lchnk ) - aerdepdrycw(:ncol,mm) = sflx(:ncol) + ! apportion dry deposition into turb and gravitational settling for tapes + dep_trb = 0._r8 + dep_grv = 0._r8 + do i=1,ncol + if (vlc_dry(i,pver,jvlc) /= 0._r8) then + dep_trb(i)=sflx(i)*vlc_trb(i,jvlc)/vlc_dry(i,pver,jvlc) + dep_grv(i)=sflx(i)*vlc_grv(i,pver,jvlc)/vlc_dry(i,pver,jvlc) + end if + enddo - endif + fldcw(1:ncol,:) = fldcw(1:ncol,:) + dqdt_tmp(1:ncol,:) * dt + + call outfld( trim(getCloudTracerName(mm))//'DDF', sflx, pcols, lchnk) + call outfld( trim(getCloudTracerName(mm))//'TBF', dep_trb, pcols, lchnk ) + call outfld( trim(getCloudTracerName(mm))//'GVF', dep_grv, pcols, lchnk ) + aerdepdrycw(:ncol,mm) = sflx(:ncol) + + endif enddo ! lspec = 0, nspec_amode(m)+1 enddo ! lphase = 1, 2 @@ -561,105 +528,81 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out ! if the user has specified prescribed aerosol dep fluxes then ! do not set cam_out dep fluxes according to the prognostic aerosols if (.not.aerodep_flx_prescribed()) then - call set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) + call oslo_set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) endif - return end subroutine oslo_aero_dry_intr + !=============================================================================== subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) - - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - use cam_history, only: outfld - use physics_types, only: physics_state, physics_ptend - use camsrfexch, only: cam_out_t - use wetdep, only: wetdepa_v2, wetdep_inputs_set, wetdep_inputs_t - use physconst, only: gravit - use constituents, only: cnst_mw - use physconst, only: mwdry ! molecular weight dry air ~ kg/kmole - use physconst, only: boltz ! J/K/molecule - use tracer_cnst, only: get_cnst_data - use modal_aero_deposition, only: set_srf_wetdep - use physics_buffer, only : physics_buffer_desc - - type(physics_state), intent(in) :: state ! Physics state variables - real(r8), intent(in) :: dt ! time step - real(r8), intent(in) :: dlf(:,:) ! shallow+deep convective detrainment [kg/kg/s] - type(cam_out_t), intent(inout) :: cam_out ! export state - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + use cam_history, only: outfld + use wetdep, only: wetdepa_v2, wetdep_inputs_set, wetdep_inputs_t + use physconst, only: gravit + use constituents, only: cnst_mw + use physconst, only: mwdry ! molecular weight dry air ~ kg/kmole + use physconst, only: boltz ! J/K/molecule + + type(physics_state), intent(in) :: state ! Physics state variables + real(r8), intent(in) :: dt ! time step + real(r8), intent(in) :: dlf(:,:) ! shallow+deep convective detrainment [kg/kg/s] + type(cam_out_t), intent(inout) :: cam_out ! export state + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies type(physics_buffer_desc), pointer :: pbuf(:) - - ! ! Local variables - ! - integer :: m ! tracer index - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns + integer :: m ! tracer index + integer :: lchnk ! chunk identifier + integer :: ncol ! number of atmospheric columns real(r8) :: iscavt(pcols, pver) integer :: mm - real(r8) :: icscavt(pcols, pver) real(r8) :: isscavt(pcols, pver) real(r8) :: bcscavt(pcols, pver) real(r8) :: bsscavt(pcols, pver) real(r8) :: sol_factb, sol_facti real(r8) :: sol_factic(pcols,pver) - real(r8) :: sflx(pcols) ! deposition flux - integer :: i,k - real(r8) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1) - integer :: jnv ! index for scavcoefnv 3rd dimension - integer :: lphase ! index for interstitial / cloudborne aerosol - integer :: lspec ! index for aerosol number / chem-mass / water-mass - integer :: lcoardust, lcoarnacl ! indices for coarse mode dust and seasalt masses - real(r8) :: dqdt_tmp(pcols,pver) ! temporary array to hold tendency for 1 species - real(r8) :: f_act_conv(pcols,pver) ! prescribed aerosol activation fraction for convective cloud ! rce 2010/05/01 - real(r8) :: f_act_conv_coarse(pcols,pver) ! similar but for coarse mode ! rce 2010/05/02 - real(r8) :: f_act_conv_coarse_dust, f_act_conv_coarse_nacl ! rce 2010/05/02 + real(r8) :: sflx(pcols) ! deposition flux + integer :: i,k + real(r8) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1) + integer :: jnv ! index for scavcoefnv 3rd dimension + integer :: lphase ! index for interstitial / cloudborne aerosol + integer :: lspec ! index for aerosol number / chem-mass / water-mass + integer :: lcoardust, lcoarnacl ! indices for coarse mode dust and seasalt masses + real(r8) :: dqdt_tmp(pcols,pver) ! temporary array to hold tendency for 1 species + real(r8) :: f_act_conv(pcols,pver) ! prescribed aerosol activation fraction for convective cloud ! rce 2010/05/01 + real(r8) :: f_act_conv_coarse(pcols,pver) ! similar but for coarse mode ! rce 2010/05/02 + real(r8) :: f_act_conv_coarse_dust, f_act_conv_coarse_nacl ! rce 2010/05/02 real(r8) :: fracis_cw(pcols,pver) - !real(r8) :: hygro_sum_old(pcols,pver) ! before removal [sum of (mass*hydro/dens)] - !real(r8) :: hygro_sum_del(pcols,pver) ! removal change to [sum of (mass*hydro/dens)] - !real(r8) :: hygro_sum_old_ik, hygro_sum_new_ik - real(r8) :: prec(pcols) ! precipitation rate - real(r8) :: q_tmp(pcols,pver) ! temporary array to hold "most current" mixing ratio for 1 species - real(r8) :: qqcw_tmp(pcols,pver) ! temporary array to hold qqcw ! rce 2010/05/01 - real(r8) :: scavcoefnv(pcols,pver,0:2) ! Dana and Hales coefficient (/mm) for - ! cloud-borne num & vol (0), - ! interstitial num (1), interstitial vol (2) + real(r8) :: prec(pcols) ! precipitation rate + real(r8) :: q_tmp(pcols,pver) ! temporary array to hold "most current" mixing ratio for 1 species + real(r8) :: qqcw_tmp(pcols,pver) ! temporary array to hold qqcw ! rce 2010/05/01 + real(r8) :: scavcoefnv(pcols,pver,0:2) ! Dana and Hales coefficient (/mm) for real(r8) :: tmpa, tmpb real(r8) :: tmpdust, tmpnacl - real(r8) :: water_old, water_new ! temporary old/new aerosol water mix-rat - logical :: isprx(pcols,pver) ! true if precipation - real(r8) :: aerdepwetis(pcols,pcnst) ! aerosol wet deposition (interstitial) - real(r8) :: aerdepwetcw(pcols,pcnst) ! aerosol wet deposition (cloud water) - - real(r8), pointer :: rprddp(:,:) ! rain production, deep convection - real(r8), pointer :: rprdsh(:,:) ! rain production, shallow convection - real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. - real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. - + real(r8) :: water_old, water_new ! temporary old/new aerosol water mix-rat + logical :: isprx(pcols,pver) ! true if precipation + real(r8) :: aerdepwetis(pcols,pcnst) ! aerosol wet deposition (interstitial) + real(r8) :: aerdepwetcw(pcols,pcnst) ! aerosol wet deposition (cloud water) + real(r8), pointer :: rprddp(:,:) ! rain production, deep convection + real(r8), pointer :: rprdsh(:,:) ! rain production, shallow convection + real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. + real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. real(r8) :: rprddpsum(pcols) real(r8) :: rprdshsum(pcols) real(r8) :: evapcdpsum(pcols) real(r8) :: evapcshsum(pcols) - real(r8) :: tmp_resudp, tmp_resush - - real(r8) :: sflxec(pcols), sflxecdp(pcols) ! deposition flux - real(r8) :: sflxic(pcols), sflxicdp(pcols) ! deposition flux - real(r8) :: sflxbc(pcols), sflxbcdp(pcols) ! deposition flux + real(r8) :: sflxec(pcols), sflxecdp(pcols) ! deposition flux + real(r8) :: sflxic(pcols), sflxicdp(pcols) ! deposition flux + real(r8) :: sflxbc(pcols), sflxbcdp(pcols) ! deposition flux real(r8) :: rcscavt(pcols, pver) real(r8) :: rsscavt(pcols, pver) real(r8) :: qqcw_in(pcols,pver), qqcw_sav(pcols,pver,pcnst) ! temporary array to hold qqcw for the current mode + logical :: is_done(pcnst,2) real(r8), pointer :: fldcw(:,:) - - logical :: is_done(pcnst,2) - real(r8),target :: zeroAerosolConcentration(pcols,pver) - + real(r8), target :: zeroAerosolConcentration(pcols,pver) real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble - type(wetdep_inputs_t) :: dep_inputs lchnk = state%lchnk @@ -669,7 +612,6 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) is_done(:,:) = .false. - zeroAerosolConcentration(:,:)=0.0_r8 ! Wet deposition of mozart aerosol species. @@ -695,9 +637,7 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) f_act_conv_coarse(:,:) = 0.60_r8 ! rce 2010/05/02 f_act_conv_coarse_dust = 0.40_r8 ! rce 2010/05/02 f_act_conv_coarse_nacl = 0.80_r8 ! rce 2010/05/02 - !++ag f_act_conv_coarse(:,:) = 0.5_r8 - !--ag scavcoefnv(:,:,0) = 0.0_r8 ! below-cloud scavcoef = 0.0 for cloud-borne species @@ -747,10 +687,8 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) else ! cloud-borne aerosol (borne by stratiform cloud drops) - !++ag !default 100 % is scavenged by cloud -borne sol_facti_cloud_borne = 1.0_r8 - !--ag sol_factb = 0.0_r8 ! all below-cloud scav OFF (anything cloud-borne is located "in-cloud") sol_facti = sol_facti_cloud_borne ! strat in-cloud scav cloud-borne tuning factor @@ -955,36 +893,25 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) ! if the user has specified prescribed aerosol dep fluxes then ! do not set cam_out dep fluxes according to the prognostic aerosols if (.not. aerodep_flx_prescribed()) then - call set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) + call oslo_set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) endif return end subroutine oslo_aero_wet_intr - - !=============================================================================== subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & - radius_part, density_part, sig_part, moment, lchnk ) + radius_part, density_part, sig_part, moment, lchnk ) -! calculates surface deposition velocity of particles -! L. Zhang, S. Gong, J. Padro, and L. Barrie -! A size-seggregated particle dry deposition scheme for an atmospheric aerosol module -! Atmospheric Environment, 35, 549-560, 2001. -! -! Authors: X. Liu - - ! - ! !USES + ! calculates surface deposition velocity of particles + ! L. Zhang, S. Gong, J. Padro, and L. Barrie + ! A size-seggregated particle dry deposition scheme for an atmospheric aerosol module + ! Atmospheric Environment, 35, 549-560, 2001. ! - use physconst, only: pi,boltz, gravit, rair - use mo_drydep, only: n_land_type, fraction_landuse + ! Authors: X. Liu ! !ARGUMENTS: - ! - implicit none - ! real(r8), intent(in) :: t(pcols,pver) !atm temperature (K) real(r8), intent(in) :: pmid(pcols,pver) !atm pressure (Pa) real(r8), intent(in) :: fv(pcols) !friction velocity (m/s) @@ -1021,7 +948,7 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl real(r8) :: radius_moment(pcols,pver) ! median radius (m) for moment real(r8) :: lnsig ! ln(sig_part) real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity - ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) + ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) integer :: lt real(r8) :: lnd_frc @@ -1029,56 +956,56 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl ! constants real(r8) gamma(11) ! exponent of schmidt number -! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & -! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & -! 0.50d+00/ + ! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & + ! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & + ! 0.50d+00/ data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & - 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & - 0.54e+00_r8/ + 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & + 0.54e+00_r8/ save gamma real(r8) alpha(11) ! parameter for impaction -! data alpha/50.00d+00, 0.95d+00, 0.80d+00, 1.20d+00, 1.30d+00, & -! 0.80d+00, 50.00d+00, 50.00d+00, 2.00d+00, 1.50d+00, & -! 100.00d+00/ + ! data alpha/50.00d+00, 0.95d+00, 0.80d+00, 1.20d+00, 1.30d+00, & + ! 0.80d+00, 50.00d+00, 50.00d+00, 2.00d+00, 1.50d+00, & + ! 100.00d+00/ data alpha/1.50e+00_r8, 1.20e+00_r8, 1.20e+00_r8, 0.80e+00_r8, 1.00e+00_r8, & - 0.80e+00_r8, 100.00e+00_r8, 50.00e+00_r8, 2.00e+00_r8, 1.20e+00_r8, & - 50.00e+00_r8/ + 0.80e+00_r8, 100.00e+00_r8, 50.00e+00_r8, 2.00e+00_r8, 1.20e+00_r8, & + 50.00e+00_r8/ save alpha real(r8) radius_collector(11) ! radius (m) of surface collectors -! data radius_collector/-1.00d+00, 5.10d-03, 3.50d-03, 3.20d-03, 10.00d-03, & -! 5.00d-03, -1.00d+00, -1.00d+00, 10.00d-03, 10.00d-03, & -! -1.00d+00/ + ! data radius_collector/-1.00d+00, 5.10d-03, 3.50d-03, 3.20d-03, 10.00d-03, & + ! 5.00d-03, -1.00d+00, -1.00d+00, 10.00d-03, 10.00d-03, & + ! -1.00d+00/ data radius_collector/10.00e-03_r8, 3.50e-03_r8, 3.50e-03_r8, 5.10e-03_r8, 2.00e-03_r8, & - 5.00e-03_r8, -1.00e+00_r8, -1.00e+00_r8, 10.00e-03_r8, 3.50e-03_r8, & - -1.00e+00_r8/ + 5.00e-03_r8, -1.00e+00_r8, -1.00e+00_r8, 10.00e-03_r8, 3.50e-03_r8, & + -1.00e+00_r8/ save radius_collector integer :: iwet(11) ! flag for wet surface = 1, otherwise = -1 -! data iwet/1, -1, -1, -1, -1, & -! -1, -1, -1, 1, -1, & -! 1/ + ! data iwet/1, -1, -1, -1, -1, & + ! -1, -1, -1, 1, -1, & + ! 1/ data iwet/-1, -1, -1, -1, -1, & - -1, 1, -1, 1, -1, & - -1/ + -1, 1, -1, 1, -1, & + -1/ save iwet !------------------------------------------------------------------------ if(top_lev.gt.1) then - vlc_grv(:ncol,:top_lev-1) = 0._r8 - vlc_dry(:ncol,:top_lev-1) = 0._r8 + vlc_grv(:ncol,:top_lev-1) = 0._r8 + vlc_dry(:ncol,:top_lev-1) = 0._r8 endif do k=top_lev,pver do i=1,ncol lnsig = log(sig_part(i,k)) -! use a maximum radius of 50 microns when calculating deposition velocity + ! use a maximum radius of 50 microns when calculating deposition velocity radius_moment(i,k) = min(50.0e-6_r8,radius_part(i,k))* & - exp((float(moment)-1.5_r8)*lnsig*lnsig) + exp((float(moment)-1.5_r8)*lnsig*lnsig) dispersion = exp(2._r8*lnsig*lnsig) rho=pmid(i,k)/rair/t(i,k) @@ -1092,10 +1019,10 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl vsc_knm_atm(i,k) = vsc_dyn_atm(i,k) / rho ![m2 s-1] Kinematic viscosity of air slp_crc(i,k) = 1.0_r8 + mfp_atm(i,k) * & - (1.257_r8+0.4_r8*exp(-1.1_r8*radius_moment(i,k)/(mfp_atm(i,k)))) / & - radius_moment(i,k) ![frc] Slip correction factor SeP97 p. 464 + (1.257_r8+0.4_r8*exp(-1.1_r8*radius_moment(i,k)/(mfp_atm(i,k)))) / & + radius_moment(i,k) ![frc] Slip correction factor SeP97 p. 464 vlc_grv(i,k) = (4.0_r8/18.0_r8) * radius_moment(i,k)*radius_moment(i,k)*density_part(i,k)* & - gravit*slp_crc(i,k) / vsc_dyn_atm(i,k) ![m s-1] Stokes' settling velocity SeP97 p. 466 + gravit*slp_crc(i,k) / vsc_dyn_atm(i,k) ![m s-1] Stokes' settling velocity SeP97 p. 466 vlc_grv(i,k) = vlc_grv(i,k) * dispersion vlc_dry(i,k)=vlc_grv(i,k) @@ -1104,7 +1031,7 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl k=pver ! only look at bottom level for next part do i=1,ncol dff_aer = boltz * t(i,k) * slp_crc(i,k) / & ![m2 s-1] - (6.0_r8*pi*vsc_dyn_atm(i,k)*radius_moment(i,k)) !SeP97 p.474 + (6.0_r8*pi*vsc_dyn_atm(i,k)*radius_moment(i,k)) !SeP97 p.474 shm_nbr = vsc_knm_atm(i,k) / dff_aer ![frc] SeP97 p.972 wrk2 = 0._r8 @@ -1114,11 +1041,11 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl if ( lnd_frc /= 0._r8 ) then brownian = shm_nbr**(-gamma(lt)) if (radius_collector(lt) > 0.0_r8) then -! vegetated surface + ! vegetated surface stk_nbr = vlc_grv(i,k) * fv(i) / (gravit*radius_collector(lt)) interception = 2.0_r8*(radius_moment(i,k)/radius_collector(lt))**2.0_r8 else -! non-vegetated surface + ! non-vegetated surface stk_nbr = vlc_grv(i,k) * fv(i) * fv(i) / (gravit*vsc_knm_atm(i,k)) ![frc] SeP97 p.965 interception = 0.0_r8 endif @@ -1142,11 +1069,115 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl vlc_dry(i,k) = wrk3 enddo !ncol - return end subroutine modal_aero_depvel_part !=============================================================================== + subroutine oslo_set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) + + ! Set surface wet deposition fluxes passed to coupler. + + ! Arguments: + real(r8), intent(in) :: aerdepwetis(:,:) ! aerosol wet deposition (interstitial) + real(r8), intent(in) :: aerdepwetcw(:,:) ! aerosol wet deposition (cloud water) + type(cam_out_t), intent(inout) :: cam_out ! cam export state + + ! Local variables: + integer :: i + integer :: ncol ! number of columns + !---------------------------------------------------------------------------- + + cam_out%bcphiwet(:) = 0._r8 + cam_out%ocphiwet(:) = 0._r8 + + ! derive cam_out variables from deposition fluxes + ! note: wet deposition fluxes are negative into surface, + ! dry deposition fluxes are positive into surface. + ! srf models want positive definite fluxes. + ncol = cam_out%ncol + do i = 1,ncol + + ! black carbon fluxes + ! djlo : added bc_n and bc_ax contribution + ! djlo : bc_ax is assumed not to exist in cloud water + cam_out%bcphiwet(i) = -(aerdepwetis(i,l_bc_ni)+aerdepwetcw(i,l_bc_ni)+ & + aerdepwetis(i,l_bc_ai)+aerdepwetcw(i,l_bc_ai)+ & + aerdepwetis(i,l_bc_a )+aerdepwetcw(i,l_bc_a )+ & + aerdepwetis(i,l_bc_ac)+aerdepwetcw(i,l_bc_ac)+ & + aerdepwetis(i,l_bc_n )+aerdepwetcw(i,l_bc_n )+ & + aerdepwetis(i,l_bc_ax)) + + ! organic carbon fluxes + cam_out%ocphiwet(i) = -(aerdepwetis(i,l_om_ni)+aerdepwetcw(i,l_om_ni)+ & + aerdepwetis(i,l_om_ai)+aerdepwetcw(i,l_om_ai)+ & + aerdepwetis(i,l_om_ac)+aerdepwetcw(i,l_om_ac)) + + ! dust fluxes + ! + ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: + cam_out%dstwet1(i) = -(aerdepwetis(i,l_dst_a2)+aerdepwetcw(i,l_dst_a2)) + + ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: + cam_out%dstwet2(i) = 0._r8 + cam_out%dstwet3(i) = -(aerdepwetis(i,l_dst_a3)+aerdepwetcw(i,l_dst_a3)) + cam_out%dstwet4(i) = 0._r8 + + enddo + + end subroutine oslo_set_srf_wetdep + + !=============================================================================== + subroutine oslo_set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) + ! Set surface dry deposition fluxes passed to coupler. + + ! Arguments: + real(r8), intent(in) :: aerdepdryis(:,:) ! aerosol dry deposition (interstitial) + real(r8), intent(in) :: aerdepdrycw(:,:) ! aerosol dry deposition (cloud water) + type(cam_out_t), intent(inout) :: cam_out ! cam export state + + ! Local variables: + integer :: i, idx + integer :: ncol ! number of columns + !---------------------------------------------------------------------------- + + cam_out%bcphidry(:) = 0._r8 + cam_out%bcphodry(:) = 0._r8 + cam_out%ocphidry(:) = 0._r8 + cam_out%ocphodry(:) = 0._r8 + + ! derive cam_out variables from deposition fluxes + ! note: wet deposition fluxes are negative into surface, + ! dry deposition fluxes are positive into surface. + ! srf models want positive definite fluxes. + ncol = cam_out%ncol + do i = 1, ncol + ! black carbon fluxes + cam_out%bcphidry(i) = aerdepdryis(i,l_bc_ni)+aerdepdrycw(i,l_bc_ni)+ & + aerdepdryis(i,l_bc_ai)+aerdepdrycw(i,l_bc_ai)+ & + aerdepdryis(i,l_bc_a )+aerdepdrycw(i,l_bc_a )+ & + aerdepdryis(i,l_bc_ac)+aerdepdrycw(i,l_bc_ac) + cam_out%bcphodry(i) = aerdepdryis(i,l_bc_n )+aerdepdrycw(i,l_bc_n )+ & + aerdepdryis(i,l_bc_ax)+aerdepdrycw(i,l_bc_ax) + + ! organic carbon fluxes + ! djlo : skipped the bc_a contribution (was about om !) + cam_out%ocphidry(i) = aerdepdryis(i,l_om_ni)+aerdepdrycw(i,l_om_ni)+ & + aerdepdryis(i,l_om_ai)+aerdepdrycw(i,l_om_ai)+ & + aerdepdryis(i,l_om_ac)+aerdepdrycw(i,l_om_ac) + cam_out%ocphidry(i) = 0._r8 + cam_out%ocphodry(i) = 0._r8 + + ! dust fluxes + ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: + cam_out%dstdry1(i) = aerdepdryis(i,l_dst_a2)+aerdepdrycw(i,l_dst_a2) + + ! Two options for partitioning deposition into bins 2-4: + ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: + cam_out%dstdry2(i) = 0._r8 + cam_out%dstdry3(i) = aerdepdryis(i,l_dst_a3)+aerdepdrycw(i,l_dst_a3) + cam_out%dstdry4(i) = 0._r8 + enddo + end subroutine oslo_set_srf_drydep end module oslo_aerosols_intr diff --git a/src/chemistry/oslo_aero/oslo_utils.F90 b/src/chemistry/oslo_aero/oslo_utils.F90 index 592f0eb6e5..af2fffae1d 100644 --- a/src/chemistry/oslo_aero/oslo_utils.F90 +++ b/src/chemistry/oslo_aero/oslo_utils.F90 @@ -1,179 +1,167 @@ module oslo_utils - use ppgrid, only : pcols, pver - use shr_kind_mod, only: r8 => shr_kind_r8 -! use commondefinitions, only: nmodes, nbmodes - use commondefinitions -! use aerosoldef, only: nmodes, getDryDensity, & -! getNumberOfBackgroundTracersInMode & -! ,getTracerIndex, originalNumberMedianRadius - use aerosoldef, only: getDryDensity, & - getNumberOfBackgroundTracersInMode & - ,getTracerIndex - use const, only : volumeToNumber, rbinMidPoint, rbinEdge, nBinsTab - use physconst, only : pi - use constituents, only: pcnst - + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols, pver + use constituents, only: pcnst + use aerosoldef, only: getDryDensity, getNumberOfBackgroundTracersInMode, getTracerIndex + use const, only: volumeToNumber, rbinMidPoint, rbinEdge, nBinsTab, nmodes + use commondefinitions, only: originalNumberMedianRadius + use physconst, only: pi + + implicit none + private + + public :: calculateNumberConcentration + public :: calculateNumberMedianRadius + public :: calculateEquivalentDensityOfFractalMode + public :: calculatedNdLogR + public :: calculateLognormalCDF + +!=================================================== contains - - subroutine calculateNumberConcentration(ncol, q, rho_air, numberConcentration) - implicit none - integer, intent(in) :: ncol !number of columns used - real(r8), intent(in) :: q(pcols,pver,pcnst) ![kg/kg] mass mixing ratios - real(r8), intent(in) :: rho_air(pcols,pver) ![kg/m3] air density - real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration - - integer :: m, l, mm, k - - numberConcentration(:,:,:) = 0.0_r8 - - do m = 0, nmodes - - do l=1,getNumberOfBackgroundTracersInMode(m) - mm = getTracerIndex(m,l,.false.) - - do k=1,pver - numberConcentration(:ncol,k,m) = numberConcentration(:ncol,k,m) & - + ( q(:ncol,k,mm) / getDryDensity(m,l)) !Volume of this tracer - end do - - end do - end do - - !until now, the variable "numberConcentration" actually contained "volume mixing ratio" - !the next couple of lines fixes this! - do m= 0, nmodes - do k=1,pver - numberConcentration(:ncol,k,m) = numberConcentration(:ncol,k,m) * rho_air(:ncol,k) * volumeToNumber(m) - end do - end do - - return - - end subroutine calculateNumberConcentration - - - !Note the "nmodes" here - subroutine calculateNumberMedianRadius(numberConcentration & - , volumeConcentration & - , lnSigma & - , numberMedianRadius & - , ncol ) - - implicit none - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![kg/kg] mass mixing ratios - real(r8), intent(in) :: lnSigma(pcols,pver,nmodes) ![kg/m3] air density - integer, intent(in) :: ncol !number of columns used - - real(r8), intent(out) :: numberMedianRadius(pcols,pver,nmodes) ![m] - - real(r8), parameter :: aThird = 1.0_r8/3.0_r8 - - integer :: n,k - - do n=1,nmodes - do k=1,pver - where(volumeConcentration(:ncol,k,n) .gt. 1.e-20_r8) - numberMedianRadius(:ncol, k, n) = 0.5_r8 & !diameter ==> radius - * (volumeConcentration(:ncol,k,n) & !conversion formula - * 6.0_r8/pi/numberConcentration(:ncol,k,n) & - *DEXP(-4.5_r8*lnsigma(:ncol,k,n)*lnsigma(:ncol,k,n)))**aThird - elsewhere - numberMedianRadius(:ncol,k,n) = originalNumberMedianRadius(n) - end where - end do - end do - - end subroutine calculateNumberMedianRadius - - - function calculateEquivalentDensityOfFractalMode( emissionDensity & ![kg/m3] density at point of emission - , emissionRadius & ![kg/m3] radius at point of emission - , fractalDimension & ![kg/m3] fractal dimension of mode - , modeNumberMedianRadius & ![m] number median radius of mode - , modeStandardDeviation & ![m] standard deviation of mode - ) result (equivalentDensityOfFractal) - - !Purpose: output equivalent density of a fractal mode - implicit none - real(r8), intent(in) :: emissionDensity - real(r8), intent(in) :: emissionRadius - real(r8), intent(in) :: fractalDimension - real(r8), intent(in) :: modeNumberMedianRadius - real(r8), intent(in) :: modeStandardDeviation - - real(r8) :: sumVolume - real(r8) :: sumMass - real(r8) :: dN, dNdLogR, dLogR - real(r8) :: densityBin - integer :: i - - !output - real(r8) :: equivalentDensityOfFractal - - sumVolume = 0.0_r8 - sumMass = 0.0_r8 - do i=1, nbinsTab - dLogR = log(rBinEdge(i+1)/rBinEdge(i)) - dNdLogR = calculatedNdLogR(rBinMidPoint(i), modeNumberMedianRadius, modeStandardDeviation) - - !Equivalent density (decreases with size since larger particles are long - !"hair like" threads..) - if(rBinMidPoint(i) < emissionRadius)then - densityBin = emissionDensity - else - densityBin = emissionDensity*(emissionRadius/rBinMidPoint(i))**(3.0 - fractalDimension) - endif - - !number concentration in this bin - dN = dNdLogR * dLogR - - !sum up volume and mass (factor of 4*pi/3 omitted since in both numerator and nominator) - sumVolume = sumVolume + dN * (rBinMidPoint(i)**3) - sumMass = sumMass + dN * densityBin * (rBinMidPoint(i)**3) - - end do - - !Equivalent density is mass by volume - equivalentDensityOfFractal = sumMass / sumVolume - - end function calculateEquivalentDensityOfFractalMode - - - - function calculatedNdLogR(actualRadius, numberMedianRadius, sigma) result (dNdLogR) - implicit none - real(r8), intent(in) :: actualRadius - real(r8), intent(in) :: numberMedianRadius - real(r8), intent(in) :: sigma - - real(r8) :: logSigma - real(r8) :: dNdLogR - - logSigma = log(sigma) - - !This is the formula for the lognormal distribution - dNdLogR = 1.0_r8/(sqrt(2.0_r8*pi)*log(sigma)) & +!=================================================== + + subroutine calculateNumberConcentration(ncol, q, rho_air, numberConcentration) + + integer, intent(in) :: ncol !number of columns used + real(r8), intent(in) :: q(pcols,pver,pcnst) ![kg/kg] mass mixing ratios + real(r8), intent(in) :: rho_air(pcols,pver) ![kg/m3] air density + real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration + + integer :: m, l, mm, k + + numberConcentration(:,:,:) = 0.0_r8 + do m = 0, nmodes + do l=1,getNumberOfBackgroundTracersInMode(m) + mm = getTracerIndex(m,l,.false.) + do k=1,pver + numberConcentration(:ncol,k,m) = numberConcentration(:ncol,k,m) & + + ( q(:ncol,k,mm) / getDryDensity(m,l)) !Volume of this tracer + end do + end do + end do + + ! until now, the variable "numberConcentration" actually contained "volume mixing ratio" + ! the next couple of lines fixes this! + do m= 0, nmodes + do k=1,pver + numberConcentration(:ncol,k,m) = numberConcentration(:ncol,k,m) * rho_air(:ncol,k) * volumeToNumber(m) + end do + end do + + end subroutine calculateNumberConcentration + + !=================================================== + subroutine calculateNumberMedianRadius(& + numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) + + !Note the "nmodes" here + real(r8) , intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration + real(r8) , intent(in) :: volumeConcentration(pcols,pver,nmodes) ![kg/kg] mass mixing ratios + real(r8) , intent(in) :: lnSigma(pcols,pver,nmodes) ![kg/m3] air density + integer , intent(in) :: ncol !number of columns used + real(r8) , intent(out) :: numberMedianRadius(pcols,pver,nmodes) ![m] + + real(r8), parameter :: aThird = 1.0_r8/3.0_r8 + integer :: n,k + + do n=1,nmodes + do k=1,pver + where(volumeConcentration(:ncol,k,n) .gt. 1.e-20_r8) + numberMedianRadius(:ncol, k, n) = 0.5_r8 & !diameter ==> radius + * (volumeConcentration(:ncol,k,n) & !conversion formula + * 6.0_r8/pi/numberConcentration(:ncol,k,n) & + *DEXP(-4.5_r8*lnsigma(:ncol,k,n)*lnsigma(:ncol,k,n)))**aThird + elsewhere + numberMedianRadius(:ncol,k,n) = originalNumberMedianRadius(n) + end where + end do + end do + + end subroutine calculateNumberMedianRadius + + !=================================================== + function calculateEquivalentDensityOfFractalMode( & + emissionDensity, emissionRadius, fractalDimension, modeNumberMedianRadius, modeStandardDeviation) & + result (equivalentDensityOfFractal) + + ! Purpose: output equivalent density of a fractal mode + + ! arguments + real(r8), intent(in) :: emissionDensity ![kg/m3] density at point of emission + real(r8), intent(in) :: emissionRadius ![kg/m3] radius at point of emission + real(r8), intent(in) :: fractalDimension ![kg/m3] fractal dimension of mode + real(r8), intent(in) :: modeNumberMedianRadius ![m] number median radius of mode + real(r8), intent(in) :: modeStandardDeviation ![m] standard deviation of mode + real(r8) :: equivalentDensityOfFractal ! Output + + ! local variables + real(r8) :: sumVolume + real(r8) :: sumMass + real(r8) :: dN, dNdLogR, dLogR + real(r8) :: densityBin + integer :: i + + sumVolume = 0.0_r8 + sumMass = 0.0_r8 + do i=1, nbinsTab + dLogR = log(rBinEdge(i+1)/rBinEdge(i)) + dNdLogR = calculatedNdLogR(rBinMidPoint(i), modeNumberMedianRadius, modeStandardDeviation) + + !Equivalent density (decreases with size since larger particles are long + !"hair like" threads..) + if(rBinMidPoint(i) < emissionRadius)then + densityBin = emissionDensity + else + densityBin = emissionDensity*(emissionRadius/rBinMidPoint(i))**(3.0 - fractalDimension) + endif + + !number concentration in this bin + dN = dNdLogR * dLogR + + !sum up volume and mass (factor of 4*pi/3 omitted since in both numerator and nominator) + sumVolume = sumVolume + dN * (rBinMidPoint(i)**3) + sumMass = sumMass + dN * densityBin * (rBinMidPoint(i)**3) + + end do + + !Equivalent density is mass by volume + equivalentDensityOfFractal = sumMass / sumVolume + + end function calculateEquivalentDensityOfFractalMode + + !=================================================== + function calculatedNdLogR(actualRadius, numberMedianRadius, sigma) result (dNdLogR) + + real(r8), intent(in) :: actualRadius + real(r8), intent(in) :: numberMedianRadius + real(r8), intent(in) :: sigma + + real(r8) :: logSigma + real(r8) :: dNdLogR + + logSigma = log(sigma) + + !This is the formula for the lognormal distribution + dNdLogR = 1.0_r8/(sqrt(2.0_r8*pi)*log(sigma)) & * DEXP(-0.5_r8*(log(actualRadius/numberMedianRadius))**2/(logSigma**2)) - - return + end function calculatedNdLogR - !http://en.wikipedia.org/wiki/Log-normal_distribution#Cumulative_distribution_function - function calculateLognormalCDF(actualRadius, numberMedianRadius, sigma) result(CDF) - implicit none - real(r8), intent(in) :: actualRadius - real(r8), intent(in) :: numberMedianRadius - real(r8), intent(in) :: sigma + !=================================================== + function calculateLognormalCDF(actualRadius, numberMedianRadius, sigma) result(CDF) + + !http://en.wikipedia.org/wiki/Log-normal_distribution#Cumulative_distribution_function + real(r8), intent(in) :: actualRadius + real(r8), intent(in) :: numberMedianRadius + real(r8), intent(in) :: sigma + real(r8) :: CDF ! output - real(r8) :: argument - real(r8) :: CDF + real(r8) :: argument - argument = -1.0_r8*(log(actualRadius/numberMedianRadius) / log(sigma) / sqrt(2.0_r8)) - CDF = 0.5_r8 * erfc(argument) - return - end function calculateLognormalCDF + argument = -1.0_r8*(log(actualRadius/numberMedianRadius) / log(sigma) / sqrt(2.0_r8)) + CDF = 0.5_r8 * erfc(argument) + end function calculateLognormalCDF end module oslo_utils diff --git a/src/physics/cam_oslo/seasalt_model.F90 b/src/chemistry/oslo_aero/seasalt_model.F90 similarity index 100% rename from src/physics/cam_oslo/seasalt_model.F90 rename to src/chemistry/oslo_aero/seasalt_model.F90 diff --git a/src/physics/cam_oslo/sox_cldaero_mod.F90 b/src/chemistry/oslo_aero/sox_cldaero_mod.F90 similarity index 100% rename from src/physics/cam_oslo/sox_cldaero_mod.F90 rename to src/chemistry/oslo_aero/sox_cldaero_mod.F90 diff --git a/src/physics/cam_oslo/modal_aero_deposition.F90 b/src/physics/cam_oslo/modal_aero_deposition.F90 deleted file mode 100644 index 75b0263cf4..0000000000 --- a/src/physics/cam_oslo/modal_aero_deposition.F90 +++ /dev/null @@ -1,215 +0,0 @@ -module modal_aero_deposition - -!------------------------------------------------------------------------------------------------ -! Purpose: -! -! Partition the contributions from modal components of wet and dry -! deposition at the surface into the fields passed to the coupler. -! -! *** N.B. *** Currently only a simple scheme for the 3-mode version -! of MAM has been implemented. -! -! Revision history: -! Feb 2009 M. Flanner, B. Eaton Original version for trop_mam3. -! Jul 2011 F Vitt -- made avaliable to be used in a prescribed modal aerosol mode (no prognostic MAM) -! Mar 2012 F Vitt -- made changes for to prevent abort when 7-mode aeroslol model is used -! some of the needed consituents do not exist in 7-mode so bin_fluxes will be false -! May 2014 F Vitt -- included contributions from MAM4 aerosols and added soa_a2 to the ocphiwet fluxes -!------------------------------------------------------------------------------------------------ - -use shr_kind_mod, only: r8 => shr_kind_r8 -use camsrfexch, only: cam_out_t -use constituents, only: cnst_get_ind, pcnst -use cam_abortutils, only: endrun -use rad_constituents, only: rad_cnst_get_info -use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac -use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 - -implicit none -private -save - -public :: & - modal_aero_deposition_init, & - set_srf_drydep, & - set_srf_wetdep - -! Private module data - -logical :: initialized = .false. -integer :: bcphi_ndx( pcnst ) = -1 -integer :: bcpho_ndx( pcnst ) = -1 -integer :: ocphi_ndx( pcnst ) = -1 -integer :: ocpho_ndx( pcnst ) = -1 -integer :: crse_dust_ndx( pcnst ) = -1 -integer :: fine_dust_ndx( pcnst ) = -1 -integer :: bcphi_cnt = 0 -integer :: ocphi_cnt = 0 -integer :: bcpho_cnt = 0 -integer :: ocpho_cnt = 0 -integer :: crse_dust_cnt = 0 -integer :: fine_dust_cnt = 0 - -!============================================================================== -contains -!============================================================================== - -subroutine modal_aero_deposition_init( bcphi_indices, bcpho_indices, ocphi_indices, & - ocpho_indices, fine_dust_indices, crse_dust_indices ) - - ! set aerosol indices for re-mapping surface deposition fluxes: - ! *_a1 = accumulation mode - ! *_a2 = aitken mode - ! *_a3 = coarse mode - - ! can be initialized with user specified indices - ! if called from aerodep_flx module (for prescribed modal aerosol fluxes) then these indices are specified - integer, optional, intent(in) :: bcphi_indices(:) ! hydrophilic black carbon - integer, optional, intent(in) :: bcpho_indices(:) ! hydrophobic black carbon - integer, optional, intent(in) :: ocphi_indices(:) ! hydrophilic organic carbon - integer, optional, intent(in) :: ocpho_indices(:) ! hydrophobic organic carbon - integer, optional, intent(in) :: fine_dust_indices(:) ! fine dust - integer, optional, intent(in) :: crse_dust_indices(:) ! coarse dust - - ! local vars - integer :: i, pcnt, scnt - - character(len=16), parameter :: fine_dust_modes(2) = (/ 'accum ', 'fine_dust '/) - character(len=16), parameter :: crse_dust_modes(2) = (/ 'coarse ', 'coarse_dust '/) - character(len=16), parameter :: hydrophilic_carbon_modes(1) = (/'accum '/) - character(len=16), parameter :: hydrophobic_carbon_modes(3) = (/'aitken ', 'coarse ', 'primary_carbon '/) - - ! if already initialized abort the run - if (initialized) then - call endrun('modal_aero_deposition is already initialized') - endif - - - initialized = .true. - -end subroutine modal_aero_deposition_init - -!============================================================================== -subroutine set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) - -! Set surface wet deposition fluxes passed to coupler. - - ! Arguments: - real(r8), intent(in) :: aerdepwetis(:,:) ! aerosol wet deposition (interstitial) - real(r8), intent(in) :: aerdepwetcw(:,:) ! aerosol wet deposition (cloud water) - type(cam_out_t), intent(inout) :: cam_out ! cam export state - - ! Local variables: - integer :: i, ispec, idx - integer :: ncol ! number of columns - - real(r8) :: bcphiwet_sum, ocphiwet_sum - !---------------------------------------------------------------------------- - - if (.not.initialized) call endrun('set_srf_wetdep: modal_aero_deposition has not been initialized') - - ncol = cam_out%ncol - - cam_out%bcphiwet(:) = 0._r8 - cam_out%ocphiwet(:) = 0._r8 - - ! derive cam_out variables from deposition fluxes - ! note: wet deposition fluxes are negative into surface, - ! dry deposition fluxes are positive into surface. - ! srf models want positive definite fluxes. - do i = 1, ncol - - ! black carbon fluxes - ! djlo : added bc_n and bc_ax contribution - ! djlo : bc_ax is assumed not to exist in cloud water - cam_out%bcphiwet(i) = -(aerdepwetis(i,l_bc_ni)+aerdepwetcw(i,l_bc_ni)+ & - aerdepwetis(i,l_bc_ai)+aerdepwetcw(i,l_bc_ai)+ & - aerdepwetis(i,l_bc_a )+aerdepwetcw(i,l_bc_a )+ & - aerdepwetis(i,l_bc_ac)+aerdepwetcw(i,l_bc_ac)+ & - aerdepwetis(i,l_bc_n )+aerdepwetcw(i,l_bc_n )+ & - aerdepwetis(i,l_bc_ax)) - - ! organic carbon fluxes - cam_out%ocphiwet(i) = -(aerdepwetis(i,l_om_ni)+aerdepwetcw(i,l_om_ni)+ & - aerdepwetis(i,l_om_ai)+aerdepwetcw(i,l_om_ai)+ & - aerdepwetis(i,l_om_ac)+aerdepwetcw(i,l_om_ac)) - - ! dust fluxes - ! - ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: - cam_out%dstwet1(i) = -(aerdepwetis(i,l_dst_a2)+aerdepwetcw(i,l_dst_a2)) - - ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: - cam_out%dstwet2(i) = 0._r8 - cam_out%dstwet3(i) = -(aerdepwetis(i,l_dst_a3)+aerdepwetcw(i,l_dst_a3)) - cam_out%dstwet4(i) = 0._r8 - - enddo - -end subroutine set_srf_wetdep - -!============================================================================== - -subroutine set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) - -! Set surface dry deposition fluxes passed to coupler. - - ! Arguments: - real(r8), intent(in) :: aerdepdryis(:,:) ! aerosol dry deposition (interstitial) - real(r8), intent(in) :: aerdepdrycw(:,:) ! aerosol dry deposition (cloud water) - type(cam_out_t), intent(inout) :: cam_out ! cam export state - - ! Local variables: - integer :: i, ispec, idx - integer :: ncol ! number of columns - real(r8):: bcphidry_sum, ocphidry_sum, ocphodry_sum - !---------------------------------------------------------------------------- - - if (.not.initialized) call endrun('set_srf_drydep: modal_aero_deposition has not been initialized') - - ncol = cam_out%ncol - - cam_out%bcphidry(:) = 0._r8 - cam_out%bcphodry(:) = 0._r8 - cam_out%ocphidry(:) = 0._r8 - cam_out%ocphodry(:) = 0._r8 - - ! derive cam_out variables from deposition fluxes - ! note: wet deposition fluxes are negative into surface, - ! dry deposition fluxes are positive into surface. - ! srf models want positive definite fluxes. - do i = 1, ncol - ! black carbon fluxes - cam_out%bcphidry(i) = aerdepdryis(i,l_bc_ni)+aerdepdrycw(i,l_bc_ni)+ & - aerdepdryis(i,l_bc_ai)+aerdepdrycw(i,l_bc_ai)+ & - aerdepdryis(i,l_bc_a )+aerdepdrycw(i,l_bc_a )+ & - aerdepdryis(i,l_bc_ac)+aerdepdrycw(i,l_bc_ac) - cam_out%bcphodry(i) = aerdepdryis(i,l_bc_n )+aerdepdrycw(i,l_bc_n )+ & - aerdepdryis(i,l_bc_ax)+aerdepdrycw(i,l_bc_ax) - - ! organic carbon fluxes - ! djlo : skipped the bc_a contribution (was about om !) - cam_out%ocphidry(i) = aerdepdryis(i,l_om_ni)+aerdepdrycw(i,l_om_ni)+ & - aerdepdryis(i,l_om_ai)+aerdepdrycw(i,l_om_ai)+ & - aerdepdryis(i,l_om_ac)+aerdepdrycw(i,l_om_ac) - cam_out%ocphidry(i) = 0._r8 !aerdepdryis(i,idx_pom1)+aerdepdryis(i,idx_soa1)+aerdepdrycw(i,idx_pom1)+aerdepdrycw(i,idx_soa1) - cam_out%ocphodry(i) = 0._r8 !aerdepdryis(i,idx_soa2)+aerdepdrycw(i,idx_soa2) - - ! dust fluxes - ! - ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: - cam_out%dstdry1(i) = aerdepdryis(i,l_dst_a2)+aerdepdrycw(i,l_dst_a2) - - ! Two options for partitioning deposition into bins 2-4: - ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: - cam_out%dstdry2(i) = 0._r8 - cam_out%dstdry3(i) = aerdepdryis(i,l_dst_a3)+aerdepdrycw(i,l_dst_a3) - cam_out%dstdry4(i) = 0._r8 - enddo - -end subroutine set_srf_drydep - - -!============================================================================== - -end module modal_aero_deposition From 539d02b3ae89d2e5f7e7979c01098c088a9712da Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 30 Aug 2023 10:07:53 +0200 Subject: [PATCH 25/71] refactored aerosol deposition --- src/chemistry/oslo_aero/aero_model.F90 | 144 +++++------- ..._aerosols_intr.F90 => oslo_aero_depos.F90} | 217 +++++++----------- .../oslo_aero/oslo_aero_deposition.F90 | 3 - 3 files changed, 147 insertions(+), 217 deletions(-) rename src/chemistry/oslo_aero/{oslo_aerosols_intr.F90 => oslo_aero_depos.F90} (88%) delete mode 100644 src/chemistry/oslo_aero/oslo_aero_deposition.F90 diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 90480302c0..4334b0d784 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -28,7 +28,8 @@ module aero_model use drydep_mod, only: inidrydep use wetdep, only: wetdep_init ! - use oslo_aerosols_intr, only: oslo_aero_initialize, oslo_aero_dry_intr, oslo_aero_wet_intr + use oslo_aero_depos, only: oslo_aero_depos_init, oslo_aero_depos_dry, oslo_aero_depos_wet + use oslo_aero_coag, only: coagtend, clcoag use oslo_utils, only: calculateNumberConcentration use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers @@ -37,7 +38,6 @@ module aero_model use aerosoldef, only: aero_register use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub use condtend, only: registerCondensation, initializeCondensation, condtend_sub - use oslo_aero_coag, only: coagtend, clcoag use sox_cldaero_mod, only: sox_cldaero_init use intlog, only: initlogn use seasalt_model, only: seasalt_init, seasalt_emis, seasalt_active @@ -46,6 +46,7 @@ module aero_model use opttab, only: initopt, initopt_lw use commondefinitions, only: originalSigma, originalNumberMedianRadius use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes + use const, only: numberToSurface use calcaersize #ifdef AEROCOM use aerocom_opt_mod, only: initaeropt @@ -166,7 +167,7 @@ subroutine aero_model_init( pbuf2d ) #endif call initializeCondensation() call oslo_ocean_init() - call oslo_aero_initialize(pbuf2d) + call oslo_aero_depos_init(pbuf2d) call dust_init() call seasalt_init() !seasalt_emis_scale) call wetdep_init() @@ -259,13 +260,13 @@ end subroutine aero_model_init subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend ) ! args - type(physics_state), intent(in) :: state ! Physics state variables + type(physics_state), intent(in) :: state ! Physics state variables real(r8), intent(in) :: obklen(:) - real(r8), intent(in) :: ustar(:) ! sfc fric vel - type(cam_in_t), target, intent(in) :: cam_in ! import state - real(r8), intent(in) :: dt ! time step - type(cam_out_t), intent(inout) :: cam_out ! export state - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies + real(r8), intent(in) :: ustar(:) ! sfc fric vel + type(cam_in_t), target, intent(in) :: cam_in ! import state + real(r8), intent(in) :: dt ! time step + type(cam_out_t), intent(inout) :: cam_out ! export state + type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies type(physics_buffer_desc), pointer :: pbuf(:) ! local vars @@ -280,7 +281,7 @@ subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, call calcaersize_sub( ncol, state%t, state%q(1,1,1), state%pmid, state%pdel, & oslo_dgnumwet, oslo_wetdens, oslo_dgnumwet_processmodes, oslo_wetdens_processmodes) - call oslo_aero_dry_intr(state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend, & + call oslo_aero_depos_dry(state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend, & oslo_dgnumwet, oslo_wetdens, oslo_dgnumwet_processmodes, oslo_wetdens_processmodes, & cam_in%cflx ) @@ -296,13 +297,12 @@ subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies type(physics_buffer_desc), pointer :: pbuf(:) - call oslo_aero_wet_intr( state, dt, dlf, cam_out, ptend, pbuf) + call oslo_aero_depos_wet( state, dt, dlf, cam_out, ptend, pbuf) endsubroutine aero_model_wetdep !============================================================================= - subroutine aero_model_surfarea( & - mmr, radmean, relhum, pmid, temp, strato_sad, sulfate, rho, ltrop, & + subroutine aero_model_surfarea(mmr, radmean, relhum, pmid, temp, strato_sad, sulfate, rho, ltrop, & dlat, het1_ndx, pbuf, ncol, sfc, dm_aer, sad_trop, reff_trop ) !------------------------------------------------------------------------- @@ -310,9 +310,7 @@ subroutine aero_model_surfarea( & ! called from mo_usrrxt !------------------------------------------------------------------------- - use const, only: numberToSurface - - ! dummy args + ! arguments real(r8), intent(in) :: pmid(:,:) real(r8), intent(in) :: temp(:,:) real(r8), intent(in) :: mmr(:,:,:) @@ -326,31 +324,29 @@ subroutine aero_model_surfarea( & real(r8), intent(in) :: rho(:,:) ! total atm density (/cm^3) real(r8), intent(in) :: sulfate(:,:) type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(inout) :: sfc(:,:,:) real(r8), intent(inout) :: dm_aer(:,:,:) real(r8), intent(inout) :: sad_trop(:,:) real(r8), intent(out) :: reff_trop(:,:) ! local vars - !HAVE TO GET RID OF THIS MODE 0!! MESSES UP EVERYTHING!! + ! HAVE TO GET RID OF THIS MODE 0!! MESSES UP EVERYTHING!! real(r8) :: numberConcentration(pcols,pver,0:nmodes_oslo) - real(r8), target :: sad_mode(pcols,pver, nmodes_oslo) - real(r8) :: rho_air(pcols,pver) - integer :: l,m - integer :: i,k + real(r8), target :: sad_mode(pcols,pver,nmodes_oslo) + real(r8) :: rho_air(pcols,pver) + integer :: l,m,i,k - !Get air density + ! Get air density do k=1,pver do i=1,ncol rho_air(i,k) = pmid(i,k)/(temp(i,k)*287.04_r8) end do end do - ! - !Get number concentrations + + ! Get number concentrations call calculateNumberConcentration(ncol, mmr, rho_air, numberConcentration) - !Convert to area using lifecycle-radius + ! Convert to area using lifecycle-radius sad_mode = 0._r8 sad_trop = 0._r8 do m=1,nmodes_oslo @@ -367,8 +363,8 @@ subroutine aero_model_surfarea( & end do end do - !++ need to implement reff_trop here - reff_trop(:,:)=1.0e-6_r8 + ! Need to implement reff_trop here + reff_trop(:,:) = 1.0e-6_r8 end subroutine aero_model_surfarea @@ -380,7 +376,7 @@ subroutine aero_model_strat_surfarea( ncol, mmr, pmid, temp, ltrop, pbuf, strato ! if modal_strat_sulfate = TRUE -- called from mo_gas_phase_chemdr !------------------------------------------------------------------------- - ! dummy args + ! arguments integer, intent(in) :: ncol real(r8), intent(in) :: mmr(:,:,:) real(r8), intent(in) :: pmid(:,:) @@ -390,15 +386,8 @@ subroutine aero_model_strat_surfarea( ncol, mmr, pmid, temp, ltrop, pbuf, strato real(r8), intent(out) :: strato_sad(:,:) real(r8), intent(out) :: reff_strat(:,:) - ! local vars - real(r8), pointer, dimension(:,:,:) :: dgnumwet - integer :: beglev(ncol) - integer :: endlev(ncol) - reff_strat = 0.1e-6_r8 strato_sad = 0._r8 - !do nothing - return end subroutine aero_model_strat_surfarea @@ -409,47 +398,38 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ airdens, invariants, del_h2so4_gasprod, & vmr0, vmr, pbuf ) - !----------------------------------------------------------------------- - ! ... dummy arguments - !----------------------------------------------------------------------- - integer, intent(in) :: loffset ! offset applied to modal aero "pointers" - integer, intent(in) :: ncol ! number columns in chunk - integer, intent(in) :: lchnk ! chunk index - integer, intent(in) :: troplev(pcols) - real(r8), intent(in) :: delt ! time step size (sec) - real(r8), intent(in) :: reaction_rates(:,:,:) ! reaction rates - real(r8), intent(in) :: tfld(:,:) ! temperature (K) - real(r8), intent(in) :: pmid(:,:) ! pressure at model levels (Pa) - real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) - real(r8), intent(in) :: relhum(:,:) ! relative humidity - real(r8), intent(in) :: airdens(:,:) ! total atms density (molec/cm**3) - real(r8), intent(in) :: invariants(:,:,:) - real(r8), intent(inout) :: del_h2so4_gasprod(:,:) ![molec/molec/sec] - real(r8), intent(in) :: zm(:,:) - real(r8), intent(in) :: qh2o(:,:) - real(r8), intent(in) :: cwat(:,:) ! cloud liquid water content (kg/kg) - real(r8), intent(in) :: cldfr(:,:) - real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) - real(r8), intent(in) :: vmr0(:,:,:) ! initial mixing ratios (before gas-phase chem changes) - real(r8), intent(inout) :: vmr(:,:,:) ! mixing ratios ( vmr ) - + ! arguments + integer, intent(in) :: loffset ! offset applied to modal aero "pointers" + integer, intent(in) :: ncol ! number columns in chunk + integer, intent(in) :: lchnk ! chunk index + integer, intent(in) :: troplev(pcols) + real(r8), intent(in) :: delt ! time step size (sec) + real(r8), intent(in) :: reaction_rates(:,:,:) ! reaction rates + real(r8), intent(in) :: tfld(:,:) ! temperature (K) + real(r8), intent(in) :: pmid(:,:) ! pressure at model levels (Pa) + real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) + real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) + real(r8), intent(in) :: relhum(:,:) ! relative humidity + real(r8), intent(in) :: airdens(:,:) ! total atms density (molec/cm**3) + real(r8), intent(in) :: invariants(:,:,:) + real(r8), intent(in) :: zm(:,:) + real(r8), intent(in) :: qh2o(:,:) + real(r8), intent(in) :: cwat(:,:) ! cloud liquid water content (kg/kg) + real(r8), intent(in) :: cldfr(:,:) + real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) + real(r8), intent(inout) :: del_h2so4_gasprod(:,:) ! [molec/molec/sec] + real(r8), intent(in) :: vmr0(:,:,:) ! initial mixing ratios (before gas-phase chem changes) + real(r8), intent(inout) :: vmr(:,:,:) ! mixing ratios ( vmr ) type(physics_buffer_desc), pointer :: pbuf(:) ! local vars - - integer :: n, m - integer :: i,k,l - integer :: nstep - integer, parameter :: nmodes_aq_chem = 1 - - real(r8), dimension(ncol) :: wrk - character(len=32) :: name + integer :: n,m,i,k,l + integer :: nstep + real(r8) :: wrk(ncol) real(r8) :: dvmrcwdt(ncol,pver,gas_pcnst) real(r8) :: dvmrdt(ncol,pver,gas_pcnst) - real(r8) :: vmrcw(ncol,pver,gas_pcnst) ! cloud-borne aerosol (vmr) - + real(r8) :: vmrcw(ncol,pver,gas_pcnst) ! cloud-borne aerosol (vmr) real(r8) :: del_h2so4_aeruptk(ncol,pver) real(r8) :: del_h2so4_aqchem(ncol,pver) real(r8) :: mmr_cond_vap_start_of_timestep(pcols,pver,N_COND_VAP) @@ -460,22 +440,19 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ real(r8) :: dvmrcwdt_sv1(ncol,pver,gas_pcnst) real(r8) :: mmr_tend_ncols(ncol, pver, gas_pcnst) real(r8) :: mmr_tend_pcols(pcols, pver, gas_pcnst) - integer :: cond_vap_idx - real(r8) :: aqso4(ncol,nmodes_aq_chem) ! aqueous phase chemistry - real(r8) :: aqh2so4(ncol,nmodes_aq_chem) ! aqueous phase chemistry - real(r8) :: aqso4_h2o2(ncol) ! SO4 aqueous phase chemistry due to H2O2 - real(r8) :: aqso4_o3(ncol) ! SO4 aqueous phase chemistry due to O3 - real(r8) :: xphlwc(ncol,pver) ! pH value multiplied by lwc - real(r8) :: delt_inverse ! 1 / timestep - + real(r8) :: aqso4(ncol,nmodes_aq_chem) ! aqueous phase chemistry + real(r8) :: aqh2so4(ncol,nmodes_aq_chem) ! aqueous phase chemistry + real(r8) :: aqso4_h2o2(ncol) ! SO4 aqueous phase chemistry due to H2O2 + real(r8) :: aqso4_o3(ncol) ! SO4 aqueous phase chemistry due to O3 + real(r8) :: xphlwc(ncol,pver) ! pH value multiplied by lwc + real(r8) :: delt_inverse ! 1 / timestep real(r8), pointer :: pblh(:) - + character(len=32) :: name logical :: is_spcam_m2005 nstep = get_nstep() - is_spcam_m2005 = cam_physpkg_is('spcam_m2005') delt_inverse = 1.0_r8 / delt @@ -603,8 +580,7 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ * del_soa_sv_gasprod(:ncol,k) / mbar(:ncol,k)/delt end do - ! This should not happen since there are only - ! production terms for these gases! ! + ! This should not happen since there are only production terms for these gases! ! do cond_vap_idx=1,N_COND_VAP where(mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx).lt. 0.0_r8) mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx) = 0.0_r8 @@ -616,13 +592,13 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ ! Rest of microphysics have pcols dimension mmr_tend_pcols(:ncol,:,:) = mmr_tend_ncols(:ncol,:,:) + ! Note use of "zm" here. In CAM5.3-implementation "zi" was used.. ! zm is passed through the generic interface, and it should not change much ! to check if "zm" is below boundary layer height instead of zi call condtend_sub( lchnk, mmr_tend_pcols, mmr_cond_vap_gasprod,tfld, pmid, & pdel, delt, ncol, pblh, zm, qh2o) ! cka - ! coagulation ! OS 280415 Concentratiions in cloud water is in vmr space and as a ! temporary variable (vmrcw) Coagulation between aerosol and cloud diff --git a/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 b/src/chemistry/oslo_aero/oslo_aero_depos.F90 similarity index 88% rename from src/chemistry/oslo_aero/oslo_aerosols_intr.F90 rename to src/chemistry/oslo_aero/oslo_aero_depos.F90 index 4f8ff72c7b..8987c1551c 100644 --- a/src/chemistry/oslo_aero/oslo_aerosols_intr.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_depos.F90 @@ -1,28 +1,28 @@ -module oslo_aerosols_intr +module oslo_aero_depos !------------------------------------------------------------------------------------------------ - ! Partition the contributions from modal components of wet and dry + ! Compute the contributions from oslo aero modal components of wet and dry ! deposition at the surface into the fields passed to the coupler. !------------------------------------------------------------------------------------------------ use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst, cnst_name, cnst_get_ind use ppgrid, only: pcols, pver, pverp, begchunk, endchunk + use constituents, only: pcnst, cnst_name use phys_control, only: phys_getopts use cam_abortutils, only: endrun - use cam_logfile, only: iulog use camsrfexch, only: cam_in_t, cam_out_t use time_manager, only: is_first_step use aerodep_flx, only: aerodep_flx_prescribed use mo_drydep, only: n_land_type, fraction_landuse use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk - use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_get_field, pbuf_get_index use physconst, only: gravit, rair, rhoh2o, boltz, pi use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only use ref_pres, only: top_lev => clim_modal_aero_top_lev use drydep_mod, only: d3ddflux, calcram + use wetdep, only: wetdepa_v2, wetdep_inputs_set, wetdep_inputs_t use dust_sediment_mod, only: dust_sediment_tend, dust_sediment_vel + ! ! use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac ! use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 use aerosoldef @@ -32,23 +32,21 @@ module oslo_aerosols_intr private ! Make default type private to the module ! Public interfaces - public :: oslo_aero_wet_intr ! interface to wet deposition - public :: sol_facti_cloud_borne - public :: oslo_aero_dry_intr ! interface to dry deposition - public :: oslo_aero_initialize + public :: oslo_aero_depos_init + public :: oslo_aero_depos_dry ! dry deposition + public :: oslo_aero_depos_wet ! wet deposition - private :: modal_aero_depvel_part + ! Private interfaces + private :: oslo_aero_depvel_part private :: oslo_set_srf_drydep private :: oslo_set_srf_wetdep + real(r8), public :: sol_facti_cloud_borne + integer :: fracis_idx = 0 integer :: prain_idx = 0 - integer :: rprddp_idx = 0 - integer :: rprdsh_idx = 0 integer :: nevapr_shcu_idx = 0 - integer :: nevapr_dpcu_idx = 0 logical :: convproc_do_aer = .FALSE. - real(r8) :: sol_facti_cloud_borne logical :: drydep_lq(pcnst) logical :: wetdep_lq(pcnst) @@ -56,16 +54,20 @@ module oslo_aerosols_intr contains !=============================================================================== - subroutine oslo_aero_initialize(pbuf2d ) + subroutine oslo_aero_depos_init( pbuf2d ) + + ! Set oslo aeroslo deposition history output + ! arguments type(physics_buffer_desc), pointer :: pbuf2d(:,:) + ! local variables integer :: m, l, i integer :: lchnk integer :: tracerIndex integer :: astat, id real(r8), pointer :: qqcw(:,:) - logical :: history_aerosol ! Output the MAM aerosol tendencies + logical :: history_aerosol ! Output the aerosol tendencies character(len=2) :: unit_basename='kg' ! Units 'kg' or '1' character(len=100) :: aName ! tracer name logical :: is_in_output(pcnst) @@ -73,17 +75,15 @@ subroutine oslo_aero_initialize(pbuf2d ) fracis_idx = pbuf_get_index('FRACIS') prain_idx = pbuf_get_index('PRAIN') - rprddp_idx = pbuf_get_index('RPRDDP') - rprdsh_idx = pbuf_get_index('RPRDSH') nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') - call phys_getopts( history_aerosol_out = history_aerosol ) + call phys_getopts( history_aerosol_out = history_aerosol ) - is_in_output(:)=.false. - drydep_lq(:)=.false. - wetdep_lq(:)=.false. + is_in_output(:) =.false. + drydep_lq(:) =.false. + wetdep_lq(:) =.false. - !Mode 0 is not subject to wet deposition? (check noresm1 code..) + ! Mode 0 is not subject to wet deposition? (check noresm1 code..) do m=0,nmodes do l=1,getNumberOfTracersInMode(m) @@ -97,8 +97,6 @@ subroutine oslo_aero_initialize(pbuf2d ) aName = cnst_name(tracerIndex) - !print*, m,l,tracerIndex, trim(aName) - call addfld (trim(aName)//'SFWET',horiz_only, 'A', unit_basename//'/m2/s', & 'Wet deposition flux at surface') call addfld (trim(aName)//'SFSIC',horiz_only, 'A', unit_basename//'/m2/s ', & @@ -119,7 +117,7 @@ subroutine oslo_aero_initialize(pbuf2d ) call addfld (trim(aName)//'SBS',(/'lev'/), 'A', unit_basename//'/kg/s ', & trim(aName)//' bs wet deposition') - !Extra wd ouptut + ! Extra wd ouptut if ( history_aerosol ) then call add_default (trim(aName)//'SFWET', 1, ' ') call add_default (trim(aName)//'SFSIC', 1, ' ') @@ -128,7 +126,7 @@ subroutine oslo_aero_initialize(pbuf2d ) call add_default (trim(aName)//'SFSBS', 1, ' ') endif - !ddep output + ! Dry deposition fluxes and velocity call addfld (trim(aName)//'DDF',horiz_only, 'A', unit_basename//'/m2/s ', & trim(aName)//' dry deposition flux at bottom (grav + turb)') call addfld (trim(aName)//'TBF',horiz_only, 'A' ,unit_basename//'/m2/s', & @@ -140,21 +138,22 @@ subroutine oslo_aero_initialize(pbuf2d ) call addfld (trim(aName)//'DDV',(/'lev'/), 'A', 'm/s', & trim(aName)//' deposition velocity') - !extra drydep output + ! extra drydep output if ( history_aerosol ) then call add_default (trim(aName)//'DDF', 1, ' ') call add_default (trim(aName)//'TBF', 1, ' ') call add_default (trim(aName)//'GVF', 1, ' ') - !call add_default (trim(aName)//'DDV', 1, ' ') + !call add_default (trim(aName)//'DDV', 1, ' ') endif - !some tracers are not in cloud water + ! some tracers are not in cloud water if(getCloudTracerIndexDirect(tracerIndex) .lt. 0)then cycle endif aName = trim(getCloudTracerName(tracerIndex)) - !Cloud water fields (from mo_chm_diags.F90) + + ! Cloud water fields (from mo_chm_diags.F90) call addfld (trim(aName)//'SFWET', horiz_only, 'A', unit_basename//'/m2/s', & trim(aName)//' wet deposition flux at surface') call addfld (trim(aName)//'SFSIC', horiz_only, 'A',unit_basename//'/m2/s ', & @@ -165,7 +164,8 @@ subroutine oslo_aero_initialize(pbuf2d ) trim(aName)//' wet deposition flux (belowcloud, convective) at surface') call addfld (trim(aName)//'SFSBS', horiz_only, 'A', unit_basename//'/m2/s ' , & trim(aName)//' wet deposition flux (belowcloud, stratiform) at surface') - !dry deposition + + ! dry deposition call addfld (trim(aName)//'DDF', horiz_only, 'A', unit_basename//'/m2/s ', & trim(aName)//' dry deposition flux at bottom (grav + turb)') call addfld (trim(aName)//'TBF', horiz_only, 'A', unit_basename//'/m2/s ', & @@ -178,9 +178,8 @@ subroutine oslo_aero_initialize(pbuf2d ) end do !tracers enddo !modes - !initialize cloud concentrations + !initialize cloud concentrations (initialize cloud bourne constituents in physics buffer) if (is_first_step()) then - ! initialize cloud bourne constituents in physics buffer do i = 1, pcnst do lchnk = begchunk, endchunk qqcw => qqcw_get_field(pbuf_get_chunk(pbuf2d,lchnk), i) @@ -191,10 +190,10 @@ subroutine oslo_aero_initialize(pbuf2d ) end do end if - end subroutine oslo_aero_initialize + end subroutine oslo_aero_depos_init !=============================================================================== - subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend, & + subroutine oslo_aero_depos_dry ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend, & dgncur_awet, wetdens, dgncur_awet_processmode, wetdens_processmode, cflx) ! Arguments: @@ -253,7 +252,7 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out real(r8) :: aerdepdrycw(pcols,pcnst) ! aerosol dry deposition (cloud water) real(r8), pointer :: fldcw(:,:) - !oslo aerosols + ! oslo aerosols real(r8) :: interfaceTendToLowestLayer(pcols) real(r8) :: deltaH(pcols) real(r8) :: massLostDD(pcols) @@ -291,29 +290,25 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out tvs(:ncol,:) = state%t(:ncol,:)!*(1+state%q(:ncol,k) rho(:ncol,:)= state%pmid(:ncol,:)/(rair*state%t(:ncol,:)) - is_done(:,:) = .false. ! ! calc settling/deposition velocities for cloud droplets (and cloud-borne aerosols) - ! ! *** mean drop radius should eventually be computed from ndrop and qcldwtr rad_drop(:,:) = 5.0e-6_r8 dens_drop(:,:) = rhoh2o sg_drop(:,:) = 1.46_r8 !jvlc = 3 - !call modal_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & + !call oslo_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & ! vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & ! rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 0, lchnk) jvlc = 4 - call modal_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & + call oslo_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 3, lchnk) - - !At this point we really need to distribute the lifecycle-tracers over !the actual modes (maybe according to surface available of background tracers?) @@ -328,7 +323,6 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out do lphase = 1, 2 ! loop over interstitial / cloud-borne forms if (lphase == 1) then ! interstial aerosol - calc settling/dep velocities of mode - logSigma = log(lifeCycleSigma(m)) ! rad_aer = volume mean wet radius (m) @@ -347,21 +341,15 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out sg_aer(1:ncol,:) = lifecycleSigma(m) jvlc = 2 - call modal_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & + call oslo_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) - - ! if(m .eq. MODE_IDX_SS_A3)then - ! do i=1,ncol - ! print*, "rad_aer", rad_aer(i,pver)*1.e6, ' um ', vlc_dry(i,pver,jvlc)*1.e2, " cm/s" - ! end do - ! end if end if do lspec = 1, getNumberOfTracersInMode(m) ! loop over number + constituents mm = getTracerIndex(m,lspec,.false.) - if(is_done(mm,lphase) .eqv. .true. )then + if(is_done(mm,lphase)) then cycle endif is_done(mm,lphase)=.true. @@ -380,7 +368,7 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out rad_aer(1:ncol,top_lev:) = 0.5_r8*dgncur_awet_processmode(1:ncol,top_lev:,processModeMap(mm)) & *exp(1.5_r8*(logSigma)) - call modal_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & + call oslo_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) endif @@ -391,7 +379,6 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out if (mm <= 0) cycle - ! if (lphase == 1) then if ((lphase == 1) .and. (lspec <= getNumberOfTracersInMode(m))) then ptend%lq(mm) = .TRUE. @@ -402,20 +389,19 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out call outfld( trim(cnst_name(mm))//'DDV', pvmzaer(:,2:pverp), pcols, lchnk ) if(.true.) then ! use phil's method - ! convert from meters/sec to pascals/sec - ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion + ! convert from meters/sec to pascals/sec, use density from layer above in conversion pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit - ! calculate the tendencies and sfc fluxes from the above velocities + ! calculate the tendencies and sfc fluxes from the above velocities call dust_sediment_tend( & ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, interfaceTendToLowestLayer ) - else !use charlie's method + else + ! use charlie's method call d3ddflux( ncol, vlc_dry(:,:,jvlc), state%q(:,:,mm), state%pmid, & state%pdel, tvs, sflx, ptend%q(:,:,mm), dt ) endif - !write(iulog,*)"starting ddep proc", mm, pcnst !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%%%%% FIX FOR SHORT DRYDEP LIFE-TIMES !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% @@ -423,6 +409,7 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out !Solve implicitly for eqn for emission and dry dep in lowest layer deltaH(:ncol)=state%pdel(:ncol,pver)/rho(:ncol,pver)/gravit ![m] height of layer !print*, "deltaH", deltaH(:ncol) + lossRate(:ncol) = vlc_dry(:ncol,pver,jvlc)/deltaH(:ncol) ![1/s] loss rate out of layer !print*, "lossRate", lossRate(:ncol) !print*, "interfaceFluxesToLowestLayer", interfaceFluxToLowestLayer(:ncol) @@ -452,11 +439,11 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out !C0 + Pdt -massLostDD = CNew ==> massLostDD(:ncol) = state%q(:ncol,pver,mm) - MMRNew(:ncol) + totalProd(:ncol)*dt + !Overwrite tendency in lowest layer to include emissions !They are then not included in vertical diffusion!! ptend%q(:ncol,pver,mm) = (MMRNew(:ncol)-state%q(:ncol,pver,mm))/dt sflx(:ncol) = massLostDD(:ncol)*state%pdel(:ncol,pver) / gravit / dt - !write(iulog,*)"done ddep" !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% ! apportion dry deposition into turb and gravitational settling for tapes @@ -487,13 +474,12 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out pvmzaer(:ncol,1)=0._r8 pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) - if(.true.) then ! use phil's method - ! convert from meters/sec to pascals/sec - ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion + ! convert from meters/sec to pascals/sec + ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit - ! calculate the tendencies and sfc fluxes from the above velocities + ! calculate the tendencies and sfc fluxes from the above velocities call dust_sediment_tend( & ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & fldcw(:,:), pvmzaer, dqdt_tmp(:,:), sflx ) @@ -531,17 +517,10 @@ subroutine oslo_aero_dry_intr ( state, pbuf, obklen, ustar, cam_in, dt, cam_out call oslo_set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) endif - end subroutine oslo_aero_dry_intr + end subroutine oslo_aero_depos_dry !=============================================================================== - subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) - - use cam_history, only: outfld - use wetdep, only: wetdepa_v2, wetdep_inputs_set, wetdep_inputs_t - use physconst, only: gravit - use constituents, only: cnst_mw - use physconst, only: mwdry ! molecular weight dry air ~ kg/kmole - use physconst, only: boltz ! J/K/molecule + subroutine oslo_aero_depos_wet ( state, dt, dlf, cam_out, ptend, pbuf) type(physics_state), intent(in) :: state ! Physics state variables real(r8), intent(in) :: dt ! time step @@ -554,8 +533,8 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) integer :: m ! tracer index integer :: lchnk ! chunk identifier integer :: ncol ! number of atmospheric columns + integer :: i,k,mm real(r8) :: iscavt(pcols, pver) - integer :: mm real(r8) :: icscavt(pcols, pver) real(r8) :: isscavt(pcols, pver) real(r8) :: bcscavt(pcols, pver) @@ -563,12 +542,10 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) real(r8) :: sol_factb, sol_facti real(r8) :: sol_factic(pcols,pver) real(r8) :: sflx(pcols) ! deposition flux - integer :: i,k real(r8) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1) integer :: jnv ! index for scavcoefnv 3rd dimension integer :: lphase ! index for interstitial / cloudborne aerosol integer :: lspec ! index for aerosol number / chem-mass / water-mass - integer :: lcoardust, lcoarnacl ! indices for coarse mode dust and seasalt masses real(r8) :: dqdt_tmp(pcols,pver) ! temporary array to hold tendency for 1 species real(r8) :: f_act_conv(pcols,pver) ! prescribed aerosol activation fraction for convective cloud ! rce 2010/05/01 real(r8) :: f_act_conv_coarse(pcols,pver) ! similar but for coarse mode ! rce 2010/05/02 @@ -578,30 +555,18 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) real(r8) :: q_tmp(pcols,pver) ! temporary array to hold "most current" mixing ratio for 1 species real(r8) :: qqcw_tmp(pcols,pver) ! temporary array to hold qqcw ! rce 2010/05/01 real(r8) :: scavcoefnv(pcols,pver,0:2) ! Dana and Hales coefficient (/mm) for - real(r8) :: tmpa, tmpb - real(r8) :: tmpdust, tmpnacl real(r8) :: water_old, water_new ! temporary old/new aerosol water mix-rat logical :: isprx(pcols,pver) ! true if precipation real(r8) :: aerdepwetis(pcols,pcnst) ! aerosol wet deposition (interstitial) real(r8) :: aerdepwetcw(pcols,pcnst) ! aerosol wet deposition (cloud water) - real(r8), pointer :: rprddp(:,:) ! rain production, deep convection - real(r8), pointer :: rprdsh(:,:) ! rain production, shallow convection - real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. - real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. - real(r8) :: rprddpsum(pcols) - real(r8) :: rprdshsum(pcols) - real(r8) :: evapcdpsum(pcols) - real(r8) :: evapcshsum(pcols) - real(r8) :: tmp_resudp, tmp_resush - real(r8) :: sflxec(pcols), sflxecdp(pcols) ! deposition flux - real(r8) :: sflxic(pcols), sflxicdp(pcols) ! deposition flux - real(r8) :: sflxbc(pcols), sflxbcdp(pcols) ! deposition flux + real(r8) :: sflxic(pcols) ! deposition flux + real(r8) :: sflxbc(pcols) ! deposition flux real(r8) :: rcscavt(pcols, pver) real(r8) :: rsscavt(pcols, pver) real(r8) :: qqcw_in(pcols,pver), qqcw_sav(pcols,pver,pcnst) ! temporary array to hold qqcw for the current mode logical :: is_done(pcnst,2) - real(r8), pointer :: fldcw(:,:) real(r8), target :: zeroAerosolConcentration(pcols,pver) + real(r8), pointer :: fldcw(:,:) real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble type(wetdep_inputs_t) :: dep_inputs @@ -627,8 +592,8 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) elsewhere isprx(:ncol,k) = .false. endwhere - prec(:ncol) = prec(:ncol) + (dep_inputs%prain(:ncol,k) + dep_inputs%cmfdqr(:ncol,k) - dep_inputs%evapr(:ncol,k)) & - *state%pdel(:ncol,k)/gravit + prec(:ncol) = prec(:ncol) + & + (dep_inputs%prain(:ncol,k) + dep_inputs%cmfdqr(:ncol,k) - dep_inputs%evapr(:ncol,k)) *state%pdel(:ncol,k)/gravit end do @@ -669,13 +634,12 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) if (lphase == 1) then ! interstial aerosol !hygro_sum_old(:,:) = 0.0_r8 !hygro_sum_del(:,:) = 0.0_r8 - !call modal_aero_bcscavcoef_get( m, ncol, isprx, dgncur_awet, & - ! scavcoefnv(:,:,1), scavcoefnv(:,:,2) ) + !call modal_aero_bcscavcoef_get( m, ncol, isprx, dgncur_awet, scavcoefnv(:,:,1), scavcoefnv(:,:,2) ) scavcoefnv(:,:,1) = 0.1_r8 !Used by MAM for number concentration sol_factb = 0.1_r8 ! all below-cloud scav ON (0.1 "tuning factor") - ! sol_factb = 0.03_r8 ! all below-cloud scav ON (0.1 "tuning factor") ! tuned 1/6 + ! sol_factb = 0.03_r8 ! all below-cloud scav ON (0.1 "tuning factor") ! tuned 1/6 sol_facti = 0.0_r8 ! strat in-cloud scav totally OFF for institial @@ -683,20 +647,17 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) !fxm: simplified relative to MAM f_act_conv = 0.8 !ag: Introduce tuning per component later - - else ! cloud-borne aerosol (borne by stratiform cloud drops) - !default 100 % is scavenged by cloud -borne sol_facti_cloud_borne = 1.0_r8 - sol_factb = 0.0_r8 ! all below-cloud scav OFF (anything cloud-borne is located "in-cloud") - sol_facti = sol_facti_cloud_borne ! strat in-cloud scav cloud-borne tuning factor - sol_factic = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean - ! that conv precip collects strat droplets) - f_act_conv = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean - + sol_factb = 0.0_r8 ! all below-cloud scav OFF (anything cloud-borne is located "in-cloud") + sol_facti = sol_facti_cloud_borne ! strat in-cloud scav cloud-borne tuning factor + sol_factic = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean + ! that conv precip collects strat droplets) + f_act_conv = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean end if + if (convproc_do_aer .and. lphase == 1) then ! if modal aero convproc is turned on for aerosols, then ! turn off the convective in-cloud removal for interstitial aerosols @@ -707,12 +668,9 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) sol_factic = 0.0_r8 endif - do lspec = 1,getNumberOfTracersInMode(m) ! loop over number + chem constituents + water - - mm = getTracerIndex(m,lspec,.false.) - if(is_done(mm,lphase) .eqv. .true. )then + if(is_done(mm,lphase)) then cycle endif is_done(mm,lphase)=.true. @@ -898,10 +856,10 @@ subroutine oslo_aero_wet_intr ( state, dt, dlf, cam_out, ptend, pbuf) return - end subroutine oslo_aero_wet_intr + end subroutine oslo_aero_depos_wet !=============================================================================== - subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & + subroutine oslo_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & radius_part, density_part, sig_part, moment, lchnk ) ! calculates surface deposition velocity of particles @@ -930,26 +888,25 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl !------------------------------------------------------------------------ ! Local Variables - integer :: m,i,k,ix !indices - real(r8) :: rho !atm density (kg/m**3) + integer :: m,i,k,ix !indices + real(r8) :: rho !atm density (kg/m**3) real(r8) :: vsc_dyn_atm(pcols,pver) ![kg m-1 s-1] Dynamic viscosity of air real(r8) :: vsc_knm_atm(pcols,pver) ![m2 s-1] Kinematic viscosity of atmosphere - real(r8) :: shm_nbr ![frc] Schmidt number - real(r8) :: stk_nbr ![frc] Stokes number + real(r8) :: shm_nbr ![frc] Schmidt number + real(r8) :: stk_nbr ![frc] Stokes number real(r8) :: mfp_atm(pcols,pver) ![m] Mean free path of air - real(r8) :: dff_aer ![m2 s-1] Brownian diffusivity of particle - real(r8) :: slp_crc(pcols,pver) ![frc] Slip correction factor - real(r8) :: rss_trb ![s m-1] Resistance to turbulent deposition - real(r8) :: rss_lmn ![s m-1] Quasi-laminar layer resistance - real(r8) :: brownian ! collection efficiency for Browning diffusion - real(r8) :: impaction ! collection efficiency for impaction - real(r8) :: interception ! collection efficiency for interception - real(r8) :: stickfrac ! fraction of particles sticking to surface + real(r8) :: dff_aer ![m2 s-1] Brownian diffusivity of particle + real(r8) :: slp_crc(pcols,pver) ![frc] Slip correction factor + real(r8) :: rss_trb ![s m-1] Resistance to turbulent deposition + real(r8) :: rss_lmn ![s m-1] Quasi-laminar layer resistance + real(r8) :: brownian ! collection efficiency for Browning diffusion + real(r8) :: impaction ! collection efficiency for impaction + real(r8) :: interception ! collection efficiency for interception + real(r8) :: stickfrac ! fraction of particles sticking to surface real(r8) :: radius_moment(pcols,pver) ! median radius (m) for moment - real(r8) :: lnsig ! ln(sig_part) - real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity - ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) - + real(r8) :: lnsig ! ln(sig_part) + real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity + ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) integer :: lt real(r8) :: lnd_frc real(r8) :: wrk1, wrk2, wrk3 @@ -1069,7 +1026,7 @@ subroutine modal_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vl vlc_dry(i,k) = wrk3 enddo !ncol - end subroutine modal_aero_depvel_part + end subroutine oslo_aero_depvel_part !=============================================================================== subroutine oslo_set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) @@ -1180,4 +1137,4 @@ subroutine oslo_set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) end subroutine oslo_set_srf_drydep -end module oslo_aerosols_intr +end module oslo_aero_depos diff --git a/src/chemistry/oslo_aero/oslo_aero_deposition.F90 b/src/chemistry/oslo_aero/oslo_aero_deposition.F90 deleted file mode 100644 index 28e16369a2..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_deposition.F90 +++ /dev/null @@ -1,3 +0,0 @@ -module oslo_aero_deposition - -end module oslo_aero_deposition From 01efbf12f51116c48b3d25e0ec3164742bf4b329 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 30 Aug 2023 12:57:11 +0200 Subject: [PATCH 26/71] more refactoring --- .../oslo_aero/{hetfrz_classnuc_oslo.F90 => oslo_aero_hetfrz.F90} | 0 .../{nucleate_ice_oslo.F90 => oslo_aero_nucleate_ice.F90} | 0 2 files changed, 0 insertions(+), 0 deletions(-) rename src/chemistry/oslo_aero/{hetfrz_classnuc_oslo.F90 => oslo_aero_hetfrz.F90} (100%) rename src/chemistry/oslo_aero/{nucleate_ice_oslo.F90 => oslo_aero_nucleate_ice.F90} (100%) diff --git a/src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 similarity index 100% rename from src/chemistry/oslo_aero/hetfrz_classnuc_oslo.F90 rename to src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 diff --git a/src/chemistry/oslo_aero/nucleate_ice_oslo.F90 b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 similarity index 100% rename from src/chemistry/oslo_aero/nucleate_ice_oslo.F90 rename to src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 From b323d44713e2405d5bb2f863e8b179bd127e8c87 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 30 Aug 2023 12:57:33 +0200 Subject: [PATCH 27/71] more refactoring --- src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 | 93 +- .../oslo_aero/oslo_aero_nucleate_ice.F90 | 1707 +++++++++++------ src/physics/cam_oslo/microp_aero.F90 | 7 +- 3 files changed, 1143 insertions(+), 664 deletions(-) diff --git a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 index 529d30eb79..88f3beb3b3 100644 --- a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 @@ -1,28 +1,42 @@ -module hetfrz_classnuc_oslo +module oslo_aero_hetfrz - !--------------------------------------------------------------------------------- - ! - ! CAM Interfaces for hetfrz_classnuc module. + !----------------------------------------------------------------------- + ! Calculate heterogeneous freezing rates from classical nucleation theory ! + ! Author: + ! Corinna Hoose, UiO, May 2009 + ! Yong Wang and Xiaohong Liu, UWyo, 12/2012, + ! implement in CAM5 and constrain uncertain parameters using natural dust and + ! BC(soot) datasets. + ! Yong Wang and Xiaohong Liu, UWyo, 05/2013, implement the PDF-contact angle + ! approach: Y. Wang et al., Atmos. Chem. Phys., 2014. + ! Jack Chen, NCAR, 09/2015, modify calculation of dust activation fraction. !--------------------------------------------------------------------------------- - use shr_kind_mod, only: r8=>shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, begchunk, endchunk - use physconst, only: rair, cpair, rh2o, rhoh2o, mwh2o, tmelt, pi - use constituents, only: cnst_get_ind, pcnst - use physics_types, only: physics_state - use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field - use physics_buffer, only: pbuf_add_field, dtype_r8 - use phys_control, only: phys_getopts, use_hetfrz_classnuc - use cam_history, only: addfld, add_default, outfld - use ref_pres, only: top_lev => trop_cloud_top_lev - use wv_saturation, only: svp_water, svp_ice - use cam_logfile, only: iulog - use error_messages, only: handle_errmsg, alloc_err - use cam_abortutils, only: endrun - use oslo_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius - use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT + use shr_kind_mod, only: r8=>shr_kind_r8 + use shr_spfn_mod, only: erf => shr_spfn_erf + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, begchunk, endchunk + use physconst, only: rair, cpair, rh2o, rhoh2o, mwh2o, tmelt, pi + use constituents, only: cnst_get_ind, pcnst + use physics_types, only: physics_state + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field + use physics_buffer, only: pbuf_add_field, dtype_r8 + use phys_control, only: phys_getopts, use_hetfrz_classnuc + use cam_history, only: addfld, add_default, outfld + use ref_pres, only: top_lev => trop_cloud_top_lev + use wv_saturation, only: svp_water, svp_ice + use cam_logfile, only: iulog + use error_messages, only: handle_errmsg, alloc_err + use cam_abortutils, only: endrun + ! + use commondefinitions, only: nmodes_oslo => nmodes + use oslo_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius + use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT + use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex + use aerosoldef, only: qqcw_get_field + use aerosoldef, only: l_dst_a2, l_dst_a3, l_bc_ai, l_bc_ac + use aerosoldef, only: lifeCycleNumberMedianRadius, lifeCycleSigma implicit none private @@ -34,6 +48,11 @@ module hetfrz_classnuc_oslo public :: hetfrz_classnuc_oslo_calc public :: hetfrz_classnuc_oslo_save_cbaero + private :: get_aer_num + private :: hetfrz_classnuc_calc + private :: collkernel + private :: hetfrz_classnuc_init_pdftheta + ! Namelist variables logical :: hist_hetfrz_classnuc = .false. @@ -58,7 +77,18 @@ module hetfrz_classnuc_oslo ! The basis is converted from mass to volume. real(r8), allocatable :: aer_cb(:,:,:,:) - logical :: pdf_imm_in = .true. + ! PDF theta model + ! some variables for PDF theta model + ! immersion freezing + ! + ! With the original value of pdf_n_theta set to 101 the dust activation + ! fraction between -15 and 0 C could be overestimated. This problem was + ! eliminated by increasing pdf_n_theta to 301. To reduce the expense of + ! computing the dust activation fraction the integral is only evaluated + ! where dim_theta is non-zero. This was determined to be between + ! dim_theta index values of 53 through 113. These loop bounds are + ! hardcoded in the variables i1 and i2. + integer, parameter :: pdf_n_theta = 301 integer, parameter :: i1 = 53 integer, parameter :: i2 = 113 @@ -67,6 +97,7 @@ module hetfrz_classnuc_oslo real(r8) :: pdf_d_theta real(r8) :: dim_f_imm_dust_a1(pdf_n_theta) = 0.0_r8 real(r8) :: dim_f_imm_dust_a3(pdf_n_theta) = 0.0_r8 + logical :: pdf_imm_in = .true. !=============================================================================== contains @@ -74,7 +105,7 @@ module hetfrz_classnuc_oslo subroutine hetfrz_classnuc_oslo_readnl(nlfile) - use namelist_utils, only: find_group_name + use namelist_utils, only: find_group_name use mpishorthand character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input @@ -304,9 +335,6 @@ subroutine hetfrz_classnuc_oslo_calc( & f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only : getNumberOfTracersInMode, getTracerIndex - ! arguments type(physics_state), target, intent(in) :: state real(r8), intent(in) :: deltatin ! time step (s) @@ -597,10 +625,6 @@ end subroutine hetfrz_classnuc_oslo_calc subroutine hetfrz_classnuc_oslo_save_cbaero(state, pbuf) - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only: getTracerIndex, getNumberOfTracersInMode - use aerosoldef, only: qqcw_get_field - ! Save the required cloud borne aerosol constituents. type(physics_state), intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) @@ -643,11 +667,6 @@ subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input hetraer, awcam, awfacm, dstcoat, & na500, tot_na500) - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT - use aerosoldef, only: l_dst_a2, l_dst_a3, l_bc_ai, l_bc_ac - use aerosoldef, only: lifeCycleNumberMedianRadius, lifeCycleSigma - ! input real(r8), intent(in) :: qaerpt(0:nmodes_oslo) ! aerosol number and mass mixing ratios(instertitial) real(r8), intent(in) :: qaercwpt(0:nmodes_oslo) ! cloud borne aerosol number and mass mixing ratios @@ -1406,8 +1425,6 @@ end subroutine collkernel subroutine hetfrz_classnuc_init_pdftheta() - use shr_spfn_mod, only: erf => shr_spfn_erf - ! Local variables: real(r8) :: theta_min, theta_max real(r8) :: x1_imm, x2_imm @@ -1447,4 +1464,4 @@ subroutine hetfrz_classnuc_init_pdftheta() end subroutine hetfrz_classnuc_init_pdftheta -end module hetfrz_classnuc_oslo +end module oslo_aero_hetfrz diff --git a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 index d4d2eb929b..e90f536e67 100644 --- a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 @@ -1,628 +1,1089 @@ -module nucleate_ice_oslo - -!--------------------------------------------------------------------------------- -! -! CAM Interfaces for nucleate_ice module. -! -! B. Eaton - Sept 2014 -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver -use physconst, only: pi, rair, tmelt -use constituents, only: pcnst, cnst_get_ind -use physics_types, only: physics_state, physics_ptend, physics_ptend_init -use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field -use phys_control, only: use_hetfrz_classnuc -use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, & - pbuf_get_index, pbuf_get_field -use cam_history, only: addfld, add_default, outfld - -use ref_pres, only: top_lev => trop_cloud_top_lev -use wv_saturation, only: qsat_water, svp_water, svp_ice -use shr_spfn_mod, only: erf => shr_spfn_erf - -use cam_logfile, only: iulog -use cam_abortutils, only: endrun - -use nucleate_ice, only: nucleati_init, nucleati - -use aerosoldef, only: l_dst_a2, l_dst_a3, & - MODE_IDX_DST_A2, MODE_IDX_DST_A3, & - rhopart, qqcw_get_field -use const , only: volumeToNumber - -implicit none -private -save - -public :: & - nucleate_ice_oslo_readnl, & - nucleate_ice_oslo_register, & - nucleate_ice_oslo_init, & - nucleate_ice_oslo_calc - - -! Namelist variables -logical, public, protected :: use_preexisting_ice = .false. -logical :: hist_preexisting_ice = .false. -logical :: nucleate_ice_incloud = .false. -logical :: nucleate_ice_use_troplev = .false. -real(r8) :: nucleate_ice_subgrid = -1._r8 -real(r8) :: nucleate_ice_subgrid_strat = -1._r8 -real(r8) :: nucleate_ice_strat = 0.0_r8 - -! Vars set via init method. -real(r8) :: mincld ! minimum allowed cloud fraction -real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor - -! constituent indices -integer :: & - cldliq_idx = -1, & - cldice_idx = -1, & - numice_idx = -1 - -integer :: & - naai_idx, & - naai_hom_idx - -integer :: & - ast_idx = -1, & - dgnum_idx = -1 - -integer :: & - qsatfac_idx -! modal aerosols -logical :: clim_modal_aero = .TRUE. -logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies +module oslo_aero_nucleate_ice + + !--------------------------------------------------------------------------------- + ! A parameterization of ice nucleation. + ! + ! Method: + ! The current method is based on Liu & Penner (2005) & Liu et al. (2007) + ! It related the ice nucleation with the aerosol number, temperature and the + ! updraft velocity. It includes homogeneous freezing of sulfate & immersion + ! freezing on mineral dust (soot disabled) in cirrus clouds, and + ! Meyers et al. (1992) deposition nucleation in mixed-phase clouds + ! + ! The effect of preexisting ice crystals on ice nucleation in cirrus clouds is included, + ! and also consider the sub-grid variability of temperature in cirrus clouds, + ! following X. Shi et al. ACP (2014). + ! + ! Ice nucleation in mixed-phase clouds now uses classical nucleation theory (CNT), + ! follows Y. Wang et al. ACP (2014), Hoose et al. (2010). + ! + ! Authors: + ! Xiaohong Liu, 01/2005, modifications by A. Gettelman 2009-2010 + ! Xiangjun Shi & Xiaohong Liu, 01/2014. + ! + ! With help from C. C. Chen and B. Eaton (2014) + !--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver + use constituents, only: pcnst, cnst_get_ind + use physconst, only: pi, rair, tmelt + use phys_control, only: phys_getopts, use_hetfrz_classnuc + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field + use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, pbuf_get_index, pbuf_get_field + use cam_history, only: addfld, add_default, outfld + use ref_pres, only: top_lev => trop_cloud_top_lev + use wv_saturation, only: qsat_water, svp_water, svp_ice + use tropopause, only: tropopause_findChemTrop + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + ! + use aerosoldef, only: l_dst_a2, l_dst_a3, MODE_IDX_DST_A2, MODE_IDX_DST_A3, rhopart, qqcw_get_field + use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC,MODE_IDX_OMBC_INTMIX_COAT_AIT + use const, only: volumeToNumber + use commondefinitions, only: nmodes + + implicit none + private + + public :: nucleate_ice_oslo_readnl + public :: nucleate_ice_oslo_register + public :: nucleate_ice_oslo_init + public :: nucleate_ice_oslo_calc + + private :: nucleati + + ! Namelist variables + logical, public, protected :: use_preexisting_ice = .false. + logical :: hist_preexisting_ice = .false. + logical :: nucleate_ice_incloud = .false. + logical :: nucleate_ice_use_troplev = .false. + real(r8) :: nucleate_ice_subgrid = -1._r8 + real(r8) :: nucleate_ice_subgrid_strat = -1._r8 + real(r8) :: nucleate_ice_strat = 0.0_r8 + + ! Vars set via init method. + real(r8) :: mincld ! minimum allowed cloud fraction + real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor + + logical :: clim_modal_aero = .true. + logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies + logical :: use_incloud_nuc + real(r8) :: ci + + ! constituent indices + integer :: & + cldliq_idx = -1, & + cldice_idx = -1, & + numice_idx = -1 + + integer :: & + naai_idx, & + naai_hom_idx + + integer :: & + ast_idx = -1 + + integer :: & + qsatfac_idx + + real(r8), parameter :: Shet = 1.3_r8 ! het freezing threshold + real(r8), parameter :: rhoice = 0.5e3_r8 ! kg/m3, Wpice is not sensitive to rhoice + real(r8), parameter :: minweff= 0.001_r8 ! m/s + real(r8), parameter :: gamma4=6.0_r8 !=============================================================================== contains !=============================================================================== -subroutine nucleate_ice_oslo_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: mpicom, masterprocid, mpi_logical, mpi_real8 - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'nucleate_ice_cam_readnl' - - namelist /nucleate_ice_nl/ use_preexisting_ice, hist_preexisting_ice, & - nucleate_ice_subgrid, nucleate_ice_subgrid_strat, nucleate_ice_strat, & - nucleate_ice_incloud, nucleate_ice_use_troplev - - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'nucleate_ice_nl', status=ierr) - if (ierr == 0) then - read(unitn, nucleate_ice_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - - end if - - ! Broadcast namelist variables - call mpi_bcast(use_preexisting_ice, 1, mpi_logical,masterprocid, mpicom, ierr) - call mpi_bcast(hist_preexisting_ice, 1, mpi_logical,masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_subgrid, 1, mpi_real8, masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_subgrid_strat, 1, mpi_real8, masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_strat, 1, mpi_real8, masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_incloud, 1, mpi_logical,masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_use_troplev, 1, mpi_logical,masterprocid, mpicom, ierr) - -end subroutine nucleate_ice_oslo_readnl - -!================================================================================================ - -subroutine nucleate_ice_oslo_register() - - call pbuf_add_field('NAAI', 'physpkg', dtype_r8, (/pcols,pver/), naai_idx) - call pbuf_add_field('NAAI_HOM', 'physpkg', dtype_r8, (/pcols,pver/), naai_hom_idx) - -end subroutine nucleate_ice_oslo_register - -!================================================================================================ - -subroutine nucleate_ice_oslo_init(mincld_in, bulk_scale_in) - use phys_control, only: phys_getopts - - real(r8), intent(in) :: mincld_in - real(r8), intent(in) :: bulk_scale_in - - ! local variables - integer :: iaer - integer :: ierr - integer :: m, n, nspec - - character(len=32) :: str32 - character(len=*), parameter :: routine = 'nucleate_ice_cam_init' - logical :: history_cesm_forcing - !-------------------------------------------------------------------------------------------- - call phys_getopts(history_cesm_forcing_out = history_cesm_forcing) - - mincld = mincld_in - bulk_scale = bulk_scale_in - - if( masterproc ) then - write(iulog,*) 'nucleate_ice parameters:' - write(iulog,*) ' mincld = ', mincld_in - write(iulog,*) ' bulk_scale = ', bulk_scale_in - write(iulog,*) ' use_preexisiting_ice = ', use_preexisting_ice - write(iulog,*) ' hist_preexisiting_ice = ', hist_preexisting_ice - write(iulog,*) ' nucleate_ice_subgrid = ', nucleate_ice_subgrid - write(iulog,*) ' nucleate_ice_subgrid_strat = ', nucleate_ice_subgrid_strat - write(iulog,*) ' nucleate_ice_strat = ', nucleate_ice_strat - write(iulog,*) ' nucleate_ice_incloud = ', nucleate_ice_incloud - write(iulog,*) ' nucleate_ice_use_troplev = ', nucleate_ice_use_troplev - end if - - call cnst_get_ind('CLDLIQ', cldliq_idx) - call cnst_get_ind('CLDICE', cldice_idx) - call cnst_get_ind('NUMICE', numice_idx) - qsatfac_idx = pbuf_get_index('QSATFAC', ierr) - - if (((nucleate_ice_subgrid .eq. -1._r8) .or. (nucleate_ice_subgrid_strat .eq. -1._r8)) .and. (qsatfac_idx .eq. -1)) then - call endrun(routine//': ERROR qsatfac is required when subgrid = -1 or subgrid_strat = -1') - end if - - call addfld('NIHF', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to homogenous freezing') - call addfld('NIDEP', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to deposition nucleation') - call addfld('NIIMM', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to immersion freezing') - call addfld('NIMEY', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to meyers deposition') - - call addfld('NIREGM',(/ 'lev' /), 'A', 'C', 'Ice Nucleation Temperature Threshold for Regime') - call addfld('NISUBGRID',(/ 'lev' /), 'A', '', 'Ice Nucleation subgrid saturation factor') - call addfld('NITROP_PD',(/ 'lev' /), 'A', '', 'Chemical Tropopause probability') - if ( history_cesm_forcing ) then - call add_default('NITROP_PD',8,' ') - endif - - if (use_preexisting_ice) then - call addfld('fhom', (/ 'lev' /), 'A','fraction', 'Fraction of cirrus where homogeneous freezing occur' ) - call addfld ('WICE', (/ 'lev' /), 'A','m/s','Vertical velocity Reduction caused by preexisting ice' ) - call addfld ('WEFF', (/ 'lev' /), 'A','m/s','Effective Vertical velocity for ice nucleation' ) - call addfld ('INnso4', (/ 'lev' /), 'A','1/m3','Number Concentation so4 (in) to ice_nucleation') - call addfld ('INnbc', (/ 'lev' /), 'A','1/m3','Number Concentation bc (in) to ice_nucleation') - call addfld ('INndust', (/ 'lev' /), 'A','1/m3','Number Concentation dust (in) ice_nucleation') - call addfld ('INondust', (/ 'lev' /), 'A','1/m3','Number Concentation dust (out) from ice_nucleation') - call addfld ('INhet', (/ 'lev' /), 'A','1/m3', & - 'contribution for in-cloud ice number density increase by het nucleation in ice cloud') - call addfld ('INhom', (/ 'lev' /), 'A','1/m3', & - 'contribution for in-cloud ice number density increase by hom nucleation in ice cloud') - call addfld ('INFrehom', (/ 'lev' /), 'A','frequency','hom IN frequency ice cloud') - call addfld ('INFreIN', (/ 'lev' /), 'A','frequency','frequency of ice nucleation occur') - - if (hist_preexisting_ice) then - call add_default ('WSUBI ', 1, ' ') ! addfld/outfld calls are in microp_aero - - call add_default ('fhom ', 1, ' ') - call add_default ('WICE ', 1, ' ') - call add_default ('WEFF ', 1, ' ') - call add_default ('INnso4 ', 1, ' ') - call add_default ('INnbc ', 1, ' ') - call add_default ('INndust ', 1, ' ') - call add_default ('INhet ', 1, ' ') - call add_default ('INhom ', 1, ' ') - call add_default ('INFrehom', 1, ' ') - call add_default ('INFreIN ', 1, ' ') - end if - end if - - - lq(l_dst_a2) = .TRUE. - lq(l_dst_a3) = .TRUE. - - call nucleati_init(use_preexisting_ice, use_hetfrz_classnuc, nucleate_ice_incloud, iulog, pi, & - mincld) - - ! get indices for fields in the physics buffer - ast_idx = pbuf_get_index('AST') - -end subroutine nucleate_ice_oslo_init - -!================================================================================================ - -subroutine nucleate_ice_oslo_calc( & - state, wsubi, pbuf, dtime, ptend & - , numberConcentration) - - use aerosoldef, only : MODE_IDX_DST_A2, MODE_IDX_DST_A3 & - , MODE_IDX_SO4_AC,MODE_IDX_OMBC_INTMIX_COAT_AIT - use commondefinitions, only: nmodes - - use tropopause, only: tropopause_findChemTrop - - ! arguments - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) - type(physics_state), target, intent(in) :: state - real(r8), intent(in) :: wsubi(:,:) - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: dtime - type(physics_ptend), intent(out) :: ptend - - ! local workspace - - ! naai and naai_hom are the outputs shared with the microphysics - real(r8), pointer :: naai(:,:) ! number of activated aerosol for ice nucleation - real(r8), pointer :: naai_hom(:,:) ! number of activated aerosol for ice nucleation (homogeneous freezing only) - - integer :: lchnk, ncol - integer :: itim_old - integer :: i, k, m - - real(r8), pointer :: t(:,:) ! input temperature (K) - real(r8), pointer :: qn(:,:) ! input water vapor mixing ratio (kg/kg) - real(r8), pointer :: qc(:,:) ! cloud water mixing ratio (kg/kg) - real(r8), pointer :: qi(:,:) ! cloud ice mixing ratio (kg/kg) - real(r8), pointer :: ni(:,:) ! cloud ice number conc (1/kg) - real(r8), pointer :: pmid(:,:) ! pressure at layer midpoints (pa) - - real(r8), pointer :: cld_dst_a2(:,:) ! mmr cld dst a2 - real(r8), pointer :: cld_dst_a3(:,:) ! mass m.r. of coarse dust - - real(r8), pointer :: ast(:,:) - real(r8) :: icecldf(pcols,pver) ! ice cloud fraction - real(r8), pointer :: qsatfac(:,:) ! Subgrid cloud water saturation scaling factor. - - real(r8) :: rho(pcols,pver) ! air density (kg m-3) - - real(r8), allocatable :: naer2(:,:,:) ! bulk aerosol number concentration (1/m3) - real(r8), allocatable :: maerosol(:,:,:) ! bulk aerosol mass conc (kg/m3) - - real(r8) :: qs(pcols) ! liquid-ice weighted sat mixing rat (kg/kg) - real(r8) :: es(pcols) ! liquid-ice weighted sat vapor press (pa) - real(r8) :: gammas(pcols) ! parameter for cond/evap of cloud water - integer :: troplev(pcols) ! tropopause level - - real(r8) :: relhum(pcols,pver) ! relative humidity - real(r8) :: icldm(pcols,pver) ! ice cloud fraction - - real(r8) :: so4_num ! so4 aerosol number (#/cm^3) - real(r8) :: soot_num ! soot (hydrophilic) aerosol number (#/cm^3) - real(r8) :: dst1_num,dst2_num,dst3_num,dst4_num ! dust aerosol number (#/cm^3) - real(r8) :: dst_num ! total dust aerosol number (#/cm^3) - real(r8) :: wght - real(r8) :: dmc - real(r8) :: ssmc - real(r8) :: oso4_num - real(r8) :: odst_num - real(r8) :: osoot_num - real(r8) :: dso4_num ! tuning factor for increased so4 - real(r8) :: ramp ! ---------- " ---------------- - real(r8) :: dust_coarse_fraction ! fraction of dust in coarse (a3) mode - real(r8) :: masslost ! [kg/kg] tmp variable for mass lost - real(r8) :: numberFromSmallDustMode ! [#/cm3] number of dust activated from small mode - - real(r8) :: subgrid(pcols,pver) - real(r8) :: trop_pd(pcols,pver) - - ! For pre-existing ice - real(r8) :: fhom(pcols,pver) ! how much fraction of cloud can reach Shom - real(r8) :: wice(pcols,pver) ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at Shom - real(r8) :: weff(pcols,pver) ! effective Vertical velocity for ice nucleation (m/s); weff=wsubi-wice - real(r8) :: INnso4(pcols,pver) ! #/m3, so4 aerosol number used for ice nucleation - real(r8) :: INnbc(pcols,pver) ! #/m3, bc aerosol number used for ice nucleation - real(r8) :: INndust(pcols,pver) ! #/m3, dust aerosol number used for ice nucleation - real(r8) :: INondust(pcols,pver) ! #/m3, dust aerosol number used for ice nucleation - real(r8) :: INhet(pcols,pver) ! #/m3, ice number from het freezing - real(r8) :: INhom(pcols,pver) ! #/m3, ice number from hom freezing - real(r8) :: INFrehom(pcols,pver) ! hom freezing occurence frequency. 1 occur, 0 not occur. - real(r8) :: INFreIN(pcols,pver) ! ice nucleation occerence frequency. 1 occur, 0 not occur. - - ! history output for ice nucleation - real(r8) :: nihf(pcols,pver) !output number conc of ice nuclei due to heterogenous freezing (1/m3) - real(r8) :: niimm(pcols,pver) !output number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3) - real(r8) :: nidep(pcols,pver) !output number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3) - real(r8) :: nimey(pcols,pver) !output number conc of ice nuclei due to meyers deposition (1/m3) - real(r8) :: regm(pcols,pver) !output temperature thershold for nucleation regime - - real(r8) :: so4_num_ac - real(r8) :: so4_num_cr - - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - t => state%t - qn => state%q(:,:,1) - qc => state%q(:,:,cldliq_idx) - qi => state%q(:,:,cldice_idx) - ni => state%q(:,:,numice_idx) - pmid => state%pmid - - do k = top_lev, pver - do i = 1, ncol - rho(i,k) = pmid(i,k)/(rair*t(i,k)) - end do - end do - - call physics_ptend_init(ptend, state%psetcols, 'nucleatei', lq=lq) - - cld_dst_a2 => qqcw_get_field(pbuf, l_dst_a2) - cld_dst_a3 => qqcw_get_field(pbuf, l_dst_a2) - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - icecldf(:ncol,:pver) = ast(:ncol,:pver) - - ! naai and naai_hom are the outputs from this parameterization - call pbuf_get_field(pbuf, naai_idx, naai) - call pbuf_get_field(pbuf, naai_hom_idx, naai_hom) - naai(1:ncol,1:pver) = 0._r8 - naai_hom(1:ncol,1:pver) = 0._r8 - - ! Use the same criteria that is used in chemistry and in CLUBB (for cloud fraction) - ! to determine whether to use tropospheric or stratospheric settings. Include the - ! tropopause level so that the cold point tropopause will use the stratospheric values. - call tropopause_findChemTrop(state, troplev) - - if ((nucleate_ice_subgrid .eq. -1._r8) .or. (nucleate_ice_subgrid_strat .eq. -1._r8)) then - call pbuf_get_field(pbuf, qsatfac_idx, qsatfac) - end if - - trop_pd(:,:) = 0._r8 - - do k = top_lev, pver - do i = 1, ncol - trop_pd(i, troplev(i)) = 1._r8 - - if (k <= troplev(i)) then - if (nucleate_ice_subgrid_strat .eq. -1._r8) then - subgrid(i, k) = 1._r8 / qsatfac(i, k) - else - subgrid(i, k) = nucleate_ice_subgrid_strat - end if - else - if (nucleate_ice_subgrid .eq. -1._r8) then - subgrid(i, k) = 1._r8 / qsatfac(i, k) - else - subgrid(i, k) = nucleate_ice_subgrid - end if - end if - end do - end do - - - ! initialize history output fields for ice nucleation - nihf(1:ncol,1:pver) = 0._r8 - niimm(1:ncol,1:pver) = 0._r8 - nidep(1:ncol,1:pver) = 0._r8 - nimey(1:ncol,1:pver) = 0._r8 - - if (use_preexisting_ice) then - fhom(:,:) = 0.0_r8 - wice(:,:) = 0.0_r8 - weff(:,:) = 0.0_r8 - INnso4(:,:) = 0.0_r8 - INnbc(:,:) = 0.0_r8 - INndust(:,:) = 0.0_r8 - INondust(:,:) = 0.0_r8 - INhet(:,:) = 0.0_r8 - INhom(:,:) = 0.0_r8 - INFrehom(:,:) = 0.0_r8 - INFreIN(:,:) = 0.0_r8 - endif - - do k = top_lev, pver - - ! Get humidity and saturation vapor pressures - call qsat_water(t(:ncol,k), pmid(:ncol,k), & - es(:ncol), qs(:ncol), gam=gammas(:ncol)) - - do i = 1, ncol - - relhum(i,k) = qn(i,k)/qs(i) - - ! get cloud fraction, check for minimum - icldm(i,k) = max(icecldf(i,k), mincld) - - end do - end do - - - do k = top_lev, pver - do i = 1, ncol - - if (t(i,k) < tmelt - 5._r8) then - - ! compute aerosol number for so4, soot, and dust with units #/cm^3 - so4_num = 0._r8 - soot_num = 0._r8 - dst1_num = 0._r8 - dst2_num = 0._r8 - dst3_num = 0._r8 - dst4_num = 0._r8 - dst_num = 0._r8 - - if (clim_modal_aero) then - !For modal aerosols, assume for the upper troposphere: - ! soot = accumulation mode - ! sulfate = aiken mode - ! dust = coarse mode - ! since modal has internal mixtures. - soot_num = numberConcentration(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT)*1.0e-6_r8 - - dst_num = (numberConcentration(i,k,MODE_IDX_DST_A2) & - + numberConcentration(i,k,MODE_IDX_DST_A3))*1.0e-6_r8 - !Oslo aerosols have two modes.. Need mode-fractions - dust_coarse_fraction = numberConcentration(i,k,MODE_IDX_DST_A3)*1.e-6_r8 / (dst_num+1.e-100_r8) - - - so4_num = (numberConcentration(i,k,MODE_IDX_SO4_AC))*1.0e-6_r8 - - end if !clim modal aero - ! *** Turn off soot nucleation *** - soot_num = 0.0_r8 - - call nucleati( & - wsubi(i,k), t(i,k), pmid(i,k), relhum(i,k), icldm(i,k), & - qc(i,k), qi(i,k), ni(i,k), rho(i,k), & - so4_num, dst_num, soot_num, subgrid(i,k), & - naai(i,k), nihf(i,k), niimm(i,k), nidep(i,k), nimey(i,k), & - wice(i,k), weff(i,k), fhom(i,k), regm(i,k), & - oso4_num, odst_num, osoot_num) - - ! Move aerosol used for nucleation from interstial to cloudborne, - ! otherwise the same coarse mode aerosols will be available again - ! in the next timestep and will supress homogeneous freezing. - if (use_preexisting_ice) then - - numberFromSmallDustMode = 0.0_r8 - - !Assume the coarse aerosols were activated first - !so only remove small ones if more than large ones are activated - if(odst_num .gt. dst_num*dust_coarse_fraction)then - - !A2-mode - numberFromSmallDustMode = odst_num - dst_num*dust_coarse_fraction - - masslost = (odst_num & !all removed - - dst_num*dust_coarse_fraction) & !fraction to coarse mode - / volumeToNumber(MODE_IDX_DST_A2) & - * rhopart(l_dst_a2) & - /rho(i,k)*1e6_r8 - - ptend%q(i,k,l_dst_a2) = -masslost*icldm(i,k)/ dtime - cld_dst_a2(i,k) = cld_dst_a2(i,k) + masslost*icldm(i,k) - - end if - - ! Coarse mode (is always lost) - masslost = (odst_num - numberFromSmallDustMode) & - / volumeToNumber(MODE_IDX_DST_A3) & - * rhopart(l_dst_a3) & - / rho(i,k)*1e6_r8 - - ptend%q(i,k,l_dst_a3) = -masslost * icldm(i,k) / dtime - cld_dst_a3(i,k) = cld_dst_a3(i,k) + masslost*icldm(i,k) - - end if - - !Oslo aerosols do not have explicit treatment of coarse sulfate - so4_num_cr = 0.0_r8 - - ! Liu&Penner does not generate enough nucleation in the polar winter - ! stratosphere, which affects surface area density, dehydration and - ! ozone chemistry. Part of this is that there are a larger number of - ! particles in the accumulation mode than in the Aitken mode. In volcanic - ! periods, the coarse mode may also be important. As a short - ! term work around, include the accumulation and coarse mode particles - ! and assume a larger fraction of the sulfates nucleate in the polar - ! stratosphere. - ! - ! Do not include the tropopause level, as stratospheric aerosols - ! only exist above the tropopause level. - ! - ! NOTE: This may still not represent the proper particles that - ! participate in nucleation, because it doesn't include STS and NAT - ! particles. It may not represent the proper saturation threshold for - ! nucleation, and wsubi from CLUBB is probably not representative of - ! wave driven varaibility in the polar stratosphere. - if (nucleate_ice_use_troplev) then - if ((k < troplev(i)) .and. (nucleate_ice_strat > 0._r8)) then - if (oso4_num > 0._r8) then - so4_num_ac = so4_num*rho(i,k)*1.0e-6_r8 !This is maximum sulfate which can activate - !! NCAR/MAM4-version - !!!so4_num_ac = num_accum(i,k)*rho(i,k)*1.0e-6_r8 - !! NCAR/MAM4-version - dso4_num = max(0._r8, (nucleate_ice_strat * (so4_num_cr + so4_num_ac)) - oso4_num) * 1e6_r8 / rho(i,k) - naai(i,k) = naai(i,k) + dso4_num - nihf(i,k) = nihf(i,k) + dso4_num - end if - end if - else - - ! This maintains backwards compatibility with the previous version. - if (pmid(i,k) <= 12500._r8 .and. pmid(i,k) > 100._r8 .and. abs(state%lat(i)) >= 60._r8 * pi / 180._r8) then - ramp = 1._r8 - min(1._r8, max(0._r8, (pmid(i,k) - 10000._r8) / 2500._r8)) - - if (oso4_num > 0._r8) then - dso4_num = (max(oso4_num, ramp * nucleate_ice_strat * so4_num) - oso4_num) * 1e6_r8 / rho(i,k) - naai(i,k) = naai(i,k) + dso4_num - nihf(i,k) = nihf(i,k) + dso4_num - end if - end if - end if - - naai_hom(i,k) = nihf(i,k) - - ! output activated ice (convert from #/kg -> #/m3) - nihf(i,k) = nihf(i,k) *rho(i,k) - niimm(i,k) = niimm(i,k)*rho(i,k) - nidep(i,k) = nidep(i,k)*rho(i,k) - nimey(i,k) = nimey(i,k)*rho(i,k) - - if (use_preexisting_ice) then - INnso4(i,k) =so4_num*1e6_r8 ! (convert from #/cm3 -> #/m3) - INnbc(i,k) =soot_num*1e6_r8 - INndust(i,k)=dst_num*1e6_r8 - INondust(i,k)=odst_num*1e6_r8 - INFreIN(i,k)=1.0_r8 ! 1,ice nucleation occur - INhet(i,k) = (niimm(i,k) + nidep(i,k)) ! #/m3, nimey not in cirrus - INhom(i,k) = nihf(i,k) ! #/m3 - if (INhom(i,k).gt.1e3_r8) then ! > 1/L - INFrehom(i,k)=1.0_r8 ! 1, hom freezing occur - endif - - ! exclude no ice nucleaton - if ((INFrehom(i,k) < 0.5_r8) .and. (INhet(i,k) < 1.0_r8)) then - INnso4(i,k) =0.0_r8 - INnbc(i,k) =0.0_r8 - INndust(i,k)=0.0_r8 - INondust(i,k)=0.0_r8 - INFreIN(i,k)=0.0_r8 - INhet(i,k) = 0.0_r8 - INhom(i,k) = 0.0_r8 - INFrehom(i,k)=0.0_r8 - wice(i,k) = 0.0_r8 - weff(i,k) = 0.0_r8 - fhom(i,k) = 0.0_r8 - endif - end if - - end if - end do - end do - - - call outfld('NIHF', nihf, pcols, lchnk) - call outfld('NIIMM', niimm, pcols, lchnk) - call outfld('NIDEP', nidep, pcols, lchnk) - call outfld('NIMEY', nimey, pcols, lchnk) - call outfld('NIREGM', regm, pcols, lchnk) - call outfld('NISUBGRID', subgrid, pcols, lchnk) - call outfld('NITROP_PD', trop_pd, pcols, lchnk) - - if (use_preexisting_ice) then - call outfld( 'fhom' , fhom, pcols, lchnk) - call outfld( 'WICE' , wice, pcols, lchnk) - call outfld( 'WEFF' , weff, pcols, lchnk) - call outfld('INnso4 ',INnso4 , pcols,lchnk) - call outfld('INnbc ',INnbc , pcols,lchnk) - call outfld('INndust ',INndust, pcols,lchnk) - call outfld('INondust ',INondust, pcols,lchnk) - call outfld('INhet ',INhet , pcols,lchnk) - call outfld('INhom ',INhom , pcols,lchnk) - call outfld('INFrehom',INFrehom,pcols,lchnk) - call outfld('INFreIN ',INFreIN, pcols,lchnk) - end if - -end subroutine nucleate_ice_oslo_calc - -!================================================================================================ - -end module nucleate_ice_oslo + subroutine nucleate_ice_oslo_readnl(nlfile) + + use namelist_utils, only: find_group_name + use spmd_utils, only: mpicom, masterprocid, mpi_logical, mpi_real8 + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'nucleate_ice_cam_readnl' + + namelist /nucleate_ice_nl/ use_preexisting_ice, hist_preexisting_ice, & + nucleate_ice_subgrid, nucleate_ice_subgrid_strat, nucleate_ice_strat, & + nucleate_ice_incloud, nucleate_ice_use_troplev + + !----------------------------------------------------------------------------- + + if (masterproc) then + open( newunit=unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'nucleate_ice_nl', status=ierr) + if (ierr == 0) then + read(unitn, nucleate_ice_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + end if + + ! Broadcast namelist variables + call mpi_bcast(use_preexisting_ice, 1, mpi_logical,masterprocid, mpicom, ierr) + call mpi_bcast(hist_preexisting_ice, 1, mpi_logical,masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_subgrid, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_subgrid_strat, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_strat, 1, mpi_real8, masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_incloud, 1, mpi_logical,masterprocid, mpicom, ierr) + call mpi_bcast(nucleate_ice_use_troplev, 1, mpi_logical,masterprocid, mpicom, ierr) + + ! Set module variable + use_incloud_nuc = nucleate_ice_incloud + + end subroutine nucleate_ice_oslo_readnl + + !================================================================================================ + + subroutine nucleate_ice_oslo_register() + + call pbuf_add_field('NAAI', 'physpkg', dtype_r8, (/pcols,pver/), naai_idx) + call pbuf_add_field('NAAI_HOM', 'physpkg', dtype_r8, (/pcols,pver/), naai_hom_idx) + + end subroutine nucleate_ice_oslo_register + + !================================================================================================ + + subroutine nucleate_ice_oslo_init(mincld_in, bulk_scale_in) + + ! arguments + real(r8), intent(in) :: mincld_in + real(r8), intent(in) :: bulk_scale_in + + ! local variables + integer :: ierr + integer :: m, n + logical :: history_cesm_forcing + character(len=*), parameter :: routine = 'nucleate_ice_cam_init' + !-------------------------------------------------------------------------------------------- + + call phys_getopts(history_cesm_forcing_out = history_cesm_forcing) + + mincld = mincld_in + bulk_scale = bulk_scale_in + + if( masterproc ) then + write(iulog,*) 'nucleate_ice parameters:' + write(iulog,*) ' mincld = ', mincld_in + write(iulog,*) ' bulk_scale = ', bulk_scale_in + write(iulog,*) ' use_preexisiting_ice = ', use_preexisting_ice + write(iulog,*) ' hist_preexisiting_ice = ', hist_preexisting_ice + write(iulog,*) ' nucleate_ice_subgrid = ', nucleate_ice_subgrid + write(iulog,*) ' nucleate_ice_subgrid_strat = ', nucleate_ice_subgrid_strat + write(iulog,*) ' nucleate_ice_strat = ', nucleate_ice_strat + write(iulog,*) ' nucleate_ice_incloud = ', nucleate_ice_incloud + write(iulog,*) ' nucleate_ice_use_troplev = ', nucleate_ice_use_troplev + end if + + call cnst_get_ind('CLDLIQ', cldliq_idx) + call cnst_get_ind('CLDICE', cldice_idx) + call cnst_get_ind('NUMICE', numice_idx) + qsatfac_idx = pbuf_get_index('QSATFAC', ierr) + + if (((nucleate_ice_subgrid .eq. -1._r8) .or. (nucleate_ice_subgrid_strat .eq. -1._r8)) .and. (qsatfac_idx .eq. -1)) then + call endrun(routine//': ERROR qsatfac is required when subgrid = -1 or subgrid_strat = -1') + end if + + call addfld('NIHF', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to homogenous freezing') + call addfld('NIDEP', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to deposition nucleation') + call addfld('NIIMM', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to immersion freezing') + call addfld('NIMEY', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to meyers deposition') + + call addfld('NIREGM',(/ 'lev' /), 'A', 'C', 'Ice Nucleation Temperature Threshold for Regime') + call addfld('NISUBGRID',(/ 'lev' /), 'A', '', 'Ice Nucleation subgrid saturation factor') + call addfld('NITROP_PD',(/ 'lev' /), 'A', '', 'Chemical Tropopause probability') + if ( history_cesm_forcing ) then + call add_default('NITROP_PD',8,' ') + endif + + if (use_preexisting_ice) then + call addfld('fhom', (/ 'lev' /), 'A','fraction', 'Fraction of cirrus where homogeneous freezing occur' ) + call addfld ('WICE', (/ 'lev' /), 'A','m/s','Vertical velocity Reduction caused by preexisting ice' ) + call addfld ('WEFF', (/ 'lev' /), 'A','m/s','Effective Vertical velocity for ice nucleation' ) + call addfld ('INnso4', (/ 'lev' /), 'A','1/m3','Number Concentation so4 (in) to ice_nucleation') + call addfld ('INnbc', (/ 'lev' /), 'A','1/m3','Number Concentation bc (in) to ice_nucleation') + call addfld ('INndust', (/ 'lev' /), 'A','1/m3','Number Concentation dust (in) ice_nucleation') + call addfld ('INondust', (/ 'lev' /), 'A','1/m3','Number Concentation dust (out) from ice_nucleation') + call addfld ('INhet', (/ 'lev' /), 'A','1/m3', & + 'contribution for in-cloud ice number density increase by het nucleation in ice cloud') + call addfld ('INhom', (/ 'lev' /), 'A','1/m3', & + 'contribution for in-cloud ice number density increase by hom nucleation in ice cloud') + call addfld ('INFrehom', (/ 'lev' /), 'A','frequency','hom IN frequency ice cloud') + call addfld ('INFreIN', (/ 'lev' /), 'A','frequency','frequency of ice nucleation occur') + + if (hist_preexisting_ice) then + call add_default ('WSUBI ', 1, ' ') ! addfld/outfld calls are in microp_aero + + call add_default ('fhom ', 1, ' ') + call add_default ('WICE ', 1, ' ') + call add_default ('WEFF ', 1, ' ') + call add_default ('INnso4 ', 1, ' ') + call add_default ('INnbc ', 1, ' ') + call add_default ('INndust ', 1, ' ') + call add_default ('INhet ', 1, ' ') + call add_default ('INhom ', 1, ' ') + call add_default ('INFrehom', 1, ' ') + call add_default ('INFreIN ', 1, ' ') + end if + end if + + lq(l_dst_a2) = .TRUE. + lq(l_dst_a3) = .TRUE. + + ! get indices for fields in the physics buffer + ast_idx = pbuf_get_index('AST') + + ci = rhoice*pi/6._r8 + + end subroutine nucleate_ice_oslo_init + + !================================================================================================ + + subroutine nucleate_ice_oslo_calc( state, wsubi, pbuf, dtime, ptend, numberConcentration) + + ! arguments + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) + type(physics_state), target, intent(in) :: state + real(r8), intent(in) :: wsubi(:,:) + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: dtime + type(physics_ptend), intent(out) :: ptend + + ! local workspace + + ! naai and naai_hom are the outputs shared with the microphysics + real(r8), pointer :: naai(:,:) ! number of activated aerosol for ice nucleation + real(r8), pointer :: naai_hom(:,:) ! number of activated aerosol for ice nucleation (homogeneous freezing only) + + integer :: lchnk, ncol + integer :: itim_old + integer :: i, k, m + + real(r8), pointer :: t(:,:) ! input temperature (K) + real(r8), pointer :: qn(:,:) ! input water vapor mixing ratio (kg/kg) + real(r8), pointer :: qc(:,:) ! cloud water mixing ratio (kg/kg) + real(r8), pointer :: qi(:,:) ! cloud ice mixing ratio (kg/kg) + real(r8), pointer :: ni(:,:) ! cloud ice number conc (1/kg) + real(r8), pointer :: pmid(:,:) ! pressure at layer midpoints (pa) + real(r8), pointer :: cld_dst_a2(:,:) ! mmr cld dst a2 + real(r8), pointer :: cld_dst_a3(:,:) ! mass m.r. of coarse dust + real(r8), pointer :: ast(:,:) + real(r8), pointer :: qsatfac(:,:) ! Subgrid cloud water saturation scaling factor. + + real(r8) :: icecldf(pcols,pver) ! ice cloud fraction + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + real(r8) :: qs(pcols) ! liquid-ice weighted sat mixing rat (kg/kg) + real(r8) :: es(pcols) ! liquid-ice weighted sat vapor press (pa) + real(r8) :: gammas(pcols) ! parameter for cond/evap of cloud water + integer :: troplev(pcols) ! tropopause level + + real(r8) :: relhum(pcols,pver) ! relative humidity + real(r8) :: icldm(pcols,pver) ! ice cloud fraction + + real(r8) :: so4_num ! so4 aerosol number (#/cm^3) + real(r8) :: soot_num ! soot (hydrophilic) aerosol number (#/cm^3) + real(r8) :: dst1_num,dst2_num,dst3_num,dst4_num ! dust aerosol number (#/cm^3) + real(r8) :: dst_num ! total dust aerosol number (#/cm^3) + real(r8) :: wght + real(r8) :: dmc + real(r8) :: ssmc + real(r8) :: oso4_num + real(r8) :: odst_num + real(r8) :: osoot_num + real(r8) :: dso4_num ! tuning factor for increased so4 + real(r8) :: ramp ! ---------- " ---------------- + real(r8) :: dust_coarse_fraction ! fraction of dust in coarse (a3) mode + real(r8) :: masslost ! [kg/kg] tmp variable for mass lost + real(r8) :: numberFromSmallDustMode ! [#/cm3] number of dust activated from small mode + + real(r8) :: subgrid(pcols,pver) + real(r8) :: trop_pd(pcols,pver) + + ! For pre-existing ice + real(r8) :: fhom(pcols,pver) ! how much fraction of cloud can reach Shom + real(r8) :: wice(pcols,pver) ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at Shom + real(r8) :: weff(pcols,pver) ! effective Vertical velocity for ice nucleation (m/s); weff=wsubi-wice + real(r8) :: INnso4(pcols,pver) ! #/m3, so4 aerosol number used for ice nucleation + real(r8) :: INnbc(pcols,pver) ! #/m3, bc aerosol number used for ice nucleation + real(r8) :: INndust(pcols,pver) ! #/m3, dust aerosol number used for ice nucleation + real(r8) :: INondust(pcols,pver) ! #/m3, dust aerosol number used for ice nucleation + real(r8) :: INhet(pcols,pver) ! #/m3, ice number from het freezing + real(r8) :: INhom(pcols,pver) ! #/m3, ice number from hom freezing + real(r8) :: INFrehom(pcols,pver) ! hom freezing occurence frequency. 1 occur, 0 not occur. + real(r8) :: INFreIN(pcols,pver) ! ice nucleation occerence frequency. 1 occur, 0 not occur. + + ! history output for ice nucleation + real(r8) :: nihf(pcols,pver) !output number conc of ice nuclei due to heterogenous freezing (1/m3) + real(r8) :: niimm(pcols,pver) !output number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3) + real(r8) :: nidep(pcols,pver) !output number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3) + real(r8) :: nimey(pcols,pver) !output number conc of ice nuclei due to meyers deposition (1/m3) + real(r8) :: regm(pcols,pver) !output temperature thershold for nucleation regime + + real(r8) :: so4_num_ac + real(r8) :: so4_num_cr + !------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + t => state%t + qn => state%q(:,:,1) + qc => state%q(:,:,cldliq_idx) + qi => state%q(:,:,cldice_idx) + ni => state%q(:,:,numice_idx) + pmid => state%pmid + + do k = top_lev, pver + do i = 1, ncol + rho(i,k) = pmid(i,k)/(rair*t(i,k)) + end do + end do + + call physics_ptend_init(ptend, state%psetcols, 'nucleatei', lq=lq) + + cld_dst_a2 => qqcw_get_field(pbuf, l_dst_a2) + cld_dst_a3 => qqcw_get_field(pbuf, l_dst_a2) + + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) + + icecldf(:ncol,:pver) = ast(:ncol,:pver) + + ! naai and naai_hom are the outputs from this parameterization + call pbuf_get_field(pbuf, naai_idx, naai) + call pbuf_get_field(pbuf, naai_hom_idx, naai_hom) + naai(1:ncol,1:pver) = 0._r8 + naai_hom(1:ncol,1:pver) = 0._r8 + + ! Use the same criteria that is used in chemistry and in CLUBB (for cloud fraction) + ! to determine whether to use tropospheric or stratospheric settings. Include the + ! tropopause level so that the cold point tropopause will use the stratospheric values. + call tropopause_findChemTrop(state, troplev) + + if ((nucleate_ice_subgrid .eq. -1._r8) .or. (nucleate_ice_subgrid_strat .eq. -1._r8)) then + call pbuf_get_field(pbuf, qsatfac_idx, qsatfac) + end if + + trop_pd(:,:) = 0._r8 + + do k = top_lev, pver + do i = 1, ncol + trop_pd(i, troplev(i)) = 1._r8 + + if (k <= troplev(i)) then + if (nucleate_ice_subgrid_strat .eq. -1._r8) then + subgrid(i, k) = 1._r8 / qsatfac(i, k) + else + subgrid(i, k) = nucleate_ice_subgrid_strat + end if + else + if (nucleate_ice_subgrid .eq. -1._r8) then + subgrid(i, k) = 1._r8 / qsatfac(i, k) + else + subgrid(i, k) = nucleate_ice_subgrid + end if + end if + end do + end do + + + ! initialize history output fields for ice nucleation + nihf(1:ncol,1:pver) = 0._r8 + niimm(1:ncol,1:pver) = 0._r8 + nidep(1:ncol,1:pver) = 0._r8 + nimey(1:ncol,1:pver) = 0._r8 + + if (use_preexisting_ice) then + fhom(:,:) = 0.0_r8 + wice(:,:) = 0.0_r8 + weff(:,:) = 0.0_r8 + INnso4(:,:) = 0.0_r8 + INnbc(:,:) = 0.0_r8 + INndust(:,:) = 0.0_r8 + INondust(:,:) = 0.0_r8 + INhet(:,:) = 0.0_r8 + INhom(:,:) = 0.0_r8 + INFrehom(:,:) = 0.0_r8 + INFreIN(:,:) = 0.0_r8 + endif + + do k = top_lev, pver + ! Get humidity and saturation vapor pressures + call qsat_water(t(:ncol,k), pmid(:ncol,k), es(:ncol), qs(:ncol), gam=gammas(:ncol)) + + do i = 1, ncol + relhum(i,k) = qn(i,k)/qs(i) + icldm(i,k) = max(icecldf(i,k), mincld) ! get cloud fraction, check for minimum + end do + end do + + do k = top_lev, pver + do i = 1, ncol + + if (t(i,k) < tmelt - 5._r8) then + + ! compute aerosol number for so4, soot, and dust with units #/cm^3 + so4_num = 0._r8 + soot_num = 0._r8 + dst1_num = 0._r8 + dst2_num = 0._r8 + dst3_num = 0._r8 + dst4_num = 0._r8 + dst_num = 0._r8 + + if (clim_modal_aero) then + !For modal aerosols, assume for the upper troposphere: + ! soot = accumulation mode + ! sulfate = aiken mode + ! dust = coarse mode + ! since modal has internal mixtures. + soot_num = numberConcentration(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT)*1.0e-6_r8 + + dst_num = (numberConcentration(i,k,MODE_IDX_DST_A2) & + + numberConcentration(i,k,MODE_IDX_DST_A3))*1.0e-6_r8 + !Oslo aerosols have two modes.. Need mode-fractions + dust_coarse_fraction = numberConcentration(i,k,MODE_IDX_DST_A3)*1.e-6_r8 / (dst_num+1.e-100_r8) + + + so4_num = (numberConcentration(i,k,MODE_IDX_SO4_AC))*1.0e-6_r8 + + end if !clim modal aero + ! *** Turn off soot nucleation *** + soot_num = 0.0_r8 + + call nucleati( & + wsubi(i,k), t(i,k), pmid(i,k), relhum(i,k), icldm(i,k), & + qc(i,k), qi(i,k), ni(i,k), rho(i,k), & + so4_num, dst_num, soot_num, subgrid(i,k), & + naai(i,k), nihf(i,k), niimm(i,k), nidep(i,k), nimey(i,k), & + wice(i,k), weff(i,k), fhom(i,k), regm(i,k), & + oso4_num, odst_num, osoot_num) + + ! Move aerosol used for nucleation from interstial to cloudborne, + ! otherwise the same coarse mode aerosols will be available again + ! in the next timestep and will supress homogeneous freezing. + if (use_preexisting_ice) then + + numberFromSmallDustMode = 0.0_r8 + + !Assume the coarse aerosols were activated first + !so only remove small ones if more than large ones are activated + if(odst_num .gt. dst_num*dust_coarse_fraction)then + + !A2-mode + numberFromSmallDustMode = odst_num - dst_num*dust_coarse_fraction + + masslost = (odst_num & !all removed + - dst_num*dust_coarse_fraction) & !fraction to coarse mode + / volumeToNumber(MODE_IDX_DST_A2) & + * rhopart(l_dst_a2) & + /rho(i,k)*1e6_r8 + + ptend%q(i,k,l_dst_a2) = -masslost*icldm(i,k)/ dtime + cld_dst_a2(i,k) = cld_dst_a2(i,k) + masslost*icldm(i,k) + + end if + + ! Coarse mode (is always lost) + masslost = (odst_num - numberFromSmallDustMode) & + / volumeToNumber(MODE_IDX_DST_A3) & + * rhopart(l_dst_a3) & + / rho(i,k)*1e6_r8 + + ptend%q(i,k,l_dst_a3) = -masslost * icldm(i,k) / dtime + cld_dst_a3(i,k) = cld_dst_a3(i,k) + masslost*icldm(i,k) + + end if + + !Oslo aerosols do not have explicit treatment of coarse sulfate + so4_num_cr = 0.0_r8 + + ! Liu&Penner does not generate enough nucleation in the polar winter + ! stratosphere, which affects surface area density, dehydration and + ! ozone chemistry. Part of this is that there are a larger number of + ! particles in the accumulation mode than in the Aitken mode. In volcanic + ! periods, the coarse mode may also be important. As a short + ! term work around, include the accumulation and coarse mode particles + ! and assume a larger fraction of the sulfates nucleate in the polar + ! stratosphere. + ! + ! Do not include the tropopause level, as stratospheric aerosols + ! only exist above the tropopause level. + ! + ! NOTE: This may still not represent the proper particles that + ! participate in nucleation, because it doesn't include STS and NAT + ! particles. It may not represent the proper saturation threshold for + ! nucleation, and wsubi from CLUBB is probably not representative of + ! wave driven varaibility in the polar stratosphere. + if (nucleate_ice_use_troplev) then + if ((k < troplev(i)) .and. (nucleate_ice_strat > 0._r8)) then + if (oso4_num > 0._r8) then + so4_num_ac = so4_num*rho(i,k)*1.0e-6_r8 !This is maximum sulfate which can activate + ! NCAR/MAM4-version + ! so4_num_ac = num_accum(i,k)*rho(i,k)*1.0e-6_r8 + ! NCAR/MAM4-version + dso4_num = max(0._r8, (nucleate_ice_strat * (so4_num_cr + so4_num_ac)) - oso4_num) * 1e6_r8 / rho(i,k) + naai(i,k) = naai(i,k) + dso4_num + nihf(i,k) = nihf(i,k) + dso4_num + end if + end if + else + + ! This maintains backwards compatibility with the previous version. + if (pmid(i,k) <= 12500._r8 .and. pmid(i,k) > 100._r8 .and. abs(state%lat(i)) >= 60._r8 * pi / 180._r8) then + ramp = 1._r8 - min(1._r8, max(0._r8, (pmid(i,k) - 10000._r8) / 2500._r8)) + + if (oso4_num > 0._r8) then + dso4_num = (max(oso4_num, ramp * nucleate_ice_strat * so4_num) - oso4_num) * 1e6_r8 / rho(i,k) + naai(i,k) = naai(i,k) + dso4_num + nihf(i,k) = nihf(i,k) + dso4_num + end if + end if + end if + + naai_hom(i,k) = nihf(i,k) + + ! output activated ice (convert from #/kg -> #/m3) + nihf(i,k) = nihf(i,k) *rho(i,k) + niimm(i,k) = niimm(i,k)*rho(i,k) + nidep(i,k) = nidep(i,k)*rho(i,k) + nimey(i,k) = nimey(i,k)*rho(i,k) + + if (use_preexisting_ice) then + INnso4(i,k) =so4_num*1e6_r8 ! (convert from #/cm3 -> #/m3) + INnbc(i,k) =soot_num*1e6_r8 + INndust(i,k)=dst_num*1e6_r8 + INondust(i,k)=odst_num*1e6_r8 + INFreIN(i,k)=1.0_r8 ! 1,ice nucleation occur + INhet(i,k) = (niimm(i,k) + nidep(i,k)) ! #/m3, nimey not in cirrus + INhom(i,k) = nihf(i,k) ! #/m3 + if (INhom(i,k).gt.1e3_r8) then ! > 1/L + INFrehom(i,k)=1.0_r8 ! 1, hom freezing occur + endif + + ! exclude no ice nucleaton + if ((INFrehom(i,k) < 0.5_r8) .and. (INhet(i,k) < 1.0_r8)) then + INnso4(i,k) =0.0_r8 + INnbc(i,k) =0.0_r8 + INndust(i,k)=0.0_r8 + INondust(i,k)=0.0_r8 + INFreIN(i,k)=0.0_r8 + INhet(i,k) = 0.0_r8 + INhom(i,k) = 0.0_r8 + INFrehom(i,k)=0.0_r8 + wice(i,k) = 0.0_r8 + weff(i,k) = 0.0_r8 + fhom(i,k) = 0.0_r8 + endif + end if + + end if + end do + end do + + + call outfld('NIHF', nihf, pcols, lchnk) + call outfld('NIIMM', niimm, pcols, lchnk) + call outfld('NIDEP', nidep, pcols, lchnk) + call outfld('NIMEY', nimey, pcols, lchnk) + call outfld('NIREGM', regm, pcols, lchnk) + call outfld('NISUBGRID', subgrid, pcols, lchnk) + call outfld('NITROP_PD', trop_pd, pcols, lchnk) + + if (use_preexisting_ice) then + call outfld( 'fhom' , fhom, pcols, lchnk) + call outfld( 'WICE' , wice, pcols, lchnk) + call outfld( 'WEFF' , weff, pcols, lchnk) + call outfld('INnso4 ',INnso4 , pcols,lchnk) + call outfld('INnbc ',INnbc , pcols,lchnk) + call outfld('INndust ',INndust, pcols,lchnk) + call outfld('INondust ',INondust, pcols,lchnk) + call outfld('INhet ',INhet , pcols,lchnk) + call outfld('INhom ',INhom , pcols,lchnk) + call outfld('INFrehom',INFrehom,pcols,lchnk) + call outfld('INFreIN ',INFreIN, pcols,lchnk) + end if + + end subroutine nucleate_ice_oslo_calc + + !=============================================================================== + + subroutine nucleati( & + wbar, tair, pmid, relhum, cldn, & + qc, qi, ni_in, rhoair, & + so4_num, dst_num, soot_num, subgrid, & + nuci, onihf, oniimm, onidep, onimey, & + wpice, weff, fhom, regm, & + oso4_num, odst_num, osoot_num) + + ! Input Arguments + real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) + real(r8), intent(in) :: tair ! temperature (K) + real(r8), intent(in) :: pmid ! pressure at layer midpoints (pa) + real(r8), intent(in) :: relhum ! relative humidity with respective to liquid + real(r8), intent(in) :: cldn ! new value of cloud fraction (fraction) + real(r8), intent(in) :: qc ! liquid water mixing ratio (kg/kg) + real(r8), intent(in) :: qi ! grid-mean preexisting cloud ice mass mixing ratio (kg/kg) + real(r8), intent(in) :: ni_in ! grid-mean preexisting cloud ice number conc (#/kg) + real(r8), intent(in) :: rhoair ! air density (kg/m3) + real(r8), intent(in) :: so4_num ! so4 aerosol number (#/cm^3) + real(r8), intent(in) :: dst_num ! total dust aerosol number (#/cm^3) + real(r8), intent(in) :: soot_num ! soot (hydrophilic) aerosol number (#/cm^3) + real(r8), intent(in) :: subgrid ! subgrid saturation scaling factor + + ! Output Arguments + real(r8), intent(out) :: nuci ! ice number nucleated (#/kg) + real(r8), intent(out) :: onihf ! nucleated number from homogeneous freezing of so4 + real(r8), intent(out) :: oniimm ! nucleated number from immersion freezing + real(r8), intent(out) :: onidep ! nucleated number from deposition nucleation + real(r8), intent(out) :: onimey ! nucleated number from deposition nucleation (meyers: mixed phase) + real(r8), intent(out) :: wpice ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at Shom + real(r8), intent(out) :: weff ! effective Vertical velocity for ice nucleation (m/s); weff=wbar-wpice + real(r8), intent(out) :: fhom ! how much fraction of cloud can reach Shom + real(r8), intent(out) :: regm ! nucleation regime indiator + real(r8), intent(out) :: oso4_num ! so4 aerosol number (#/cm^3) + real(r8), intent(out) :: odst_num ! total dust aerosol number (#/cm^3) + real(r8), intent(out) :: osoot_num ! soot (hydrophilic) aerosol number (#/cm^3) + + ! Local workspace + real(r8) :: nihf ! nucleated number from homogeneous freezing of so4 + real(r8) :: niimm ! nucleated number from immersion freezing + real(r8) :: nidep ! nucleated number from deposition nucleation + real(r8) :: nimey ! nucleated number from deposition nucleation (meyers) + real(r8) :: n1, ni ! nucleated number + real(r8) :: tc, A, B ! work variable + real(r8) :: esl, esi, deles ! work variable + real(r8) :: wbar1, wbar2 + + ! used in SUBROUTINE Vpreice + real(r8) :: Ni_preice ! cloud ice number conc (1/m3) + real(r8) :: lami,Ri_preice ! mean cloud ice radius (m) + real(r8) :: Shom ! initial ice saturation ratio; if <1, use hom threshold Si + real(r8) :: detaT,RHimean ! temperature standard deviation, mean cloudy RHi + real(r8) :: wpicehet ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at shet + real(r8) :: weffhet ! effective Vertical velocity for ice nucleation (m/s) weff=wbar-wpicehet + !------------------------------------------------------------------------------- + + RHimean = relhum*svp_water(tair)/svp_ice(tair)*subgrid + + ! temp variables that depend on use_preexisting_ice + wbar1 = wbar + wbar2 = wbar + + ! If not using prexisting ice, the homogeneous freezing happens in the + ! entire gridbox. + fhom = 1._r8 + + if (use_preexisting_ice) then + + Ni_preice = ni_in*rhoair ! (convert from #/kg -> #/m3) + Ni_preice = Ni_preice / max(mincld,cldn) ! in-cloud ice number density + + if (Ni_preice > 10.0_r8 .and. qi > 1.e-10_r8) then ! > 0.01/L = 10/m3 + Shom = -1.5_r8 ! if Shom<1 , Shom will be recalculated in SUBROUTINE Vpreice, according to Ren & McKenzie, 2005 + lami = (gamma4*ci*ni_in/qi)**(1._r8/3._r8) + Ri_preice = 0.5_r8/lami ! radius + Ri_preice = max(Ri_preice, 1e-8_r8) ! >0.01micron + call Vpreice(pmid, tair, Ri_preice, Ni_preice, Shom, wpice) + call Vpreice(pmid, tair, Ri_preice, Ni_preice, Shet, wpicehet) + else + wpice = 0.0_r8 + wpicehet = 0.0_r8 + endif + + weff = max(wbar-wpice, minweff) + wpice = min(wpice, wbar) + weffhet = max(wbar-wpicehet,minweff) + wpicehet = min(wpicehet, wbar) + + wbar1 = weff + wbar2 = weffhet + + detaT = wbar/0.23_r8 + if (use_incloud_nuc) then + call frachom(tair, 1._r8, detaT, fhom) + else + call frachom(tair, RHimean, detaT, fhom) + end if + end if + + ni = 0._r8 + tc = tair - 273.15_r8 + + ! initialize + niimm = 0._r8 + nidep = 0._r8 + nihf = 0._r8 + deles = 0._r8 + esi = 0._r8 + regm = 0._r8 + + oso4_num = 0._r8 + odst_num = 0._r8 + osoot_num = 0._r8 + + if ((so4_num >= 1.0e-10_r8 .or. (soot_num+dst_num) >= 1.0e-10_r8) .and. cldn > 0._r8) then + + if (RHimean.ge.1.2_r8) then + + if ( ((tc.le.0.0_r8).and.(tc.ge.-37.0_r8).and.(qc.lt.1.e-12_r8)).or.(tc.le.-37.0_r8)) then + + A = -1.4938_r8 * log(soot_num+dst_num) + 12.884_r8 + B = -10.41_r8 * log(soot_num+dst_num) - 67.69_r8 + regm = A * log(wbar1) + B + + ! heterogeneous nucleation only + if (tc .gt. regm .or. so4_num < 1.0e-10_r8) then + + if(tc.lt.-40._r8 .and. wbar1.gt.1._r8 .and. so4_num >= 1.0e-10_r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation + + call hf(tc,wbar1,relhum*subgrid,so4_num,nihf) + niimm=0._r8 + nidep=0._r8 + + ! If some homogeneous nucleation happened, assume all of the that heterogeneous + ! and coarse mode sulfate particles nucleated. + if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice + niimm = dst_num + soot_num ! assuming dst_num freeze firstly + odst_num = dst_num + osoot_num = soot_num + + oso4_num = nihf + endif + + nihf = nihf * fhom + oso4_num = oso4_num * fhom + + n1 = nihf + niimm + else + + call hetero(tc,wbar2,soot_num+dst_num,niimm,nidep) + + nihf = 0._r8 + n1 = niimm + nidep + + osoot_num = soot_num * (niimm + nidep) / (soot_num + dst_num) + odst_num = dst_num * (niimm + nidep) / (soot_num + dst_num) + endif + + ! homogeneous nucleation only + else if (tc.lt.regm-5._r8 .or. (soot_num+dst_num) < 1.0e-10_r8) then + + call hf(tc,wbar1,relhum*subgrid,so4_num,nihf) + niimm=0._r8 + nidep=0._r8 + + ! If some homogeneous nucleation happened, assume all of the that + ! heterogeneous and coarse mode sulfate particles nucleated. + if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice + niimm = dst_num + soot_num ! assuming dst_num freeze firstly + odst_num = dst_num + osoot_num = soot_num + + oso4_num = nihf + endif + + nihf = nihf * fhom + oso4_num = oso4_num * fhom + + n1 = nihf + niimm + + ! transition between homogeneous and heterogeneous: interpolate in-between + else + + if (tc.lt.-40._r8 .and. wbar1.gt.1._r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation + + call hf(tc, wbar1, relhum*subgrid, so4_num, nihf) + niimm = 0._r8 + nidep = 0._r8 + + ! If some homogeneous nucleation happened, assume all of the + ! that heterogeneous and coarse mode sulfate particles nucleated. + if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice + niimm = dst_num + soot_num ! assuming dst_num freeze firstly + odst_num = dst_num + osoot_num = soot_num + + oso4_num = nihf + endif + + nihf = nihf * fhom + oso4_num = oso4_num * fhom + + n1 = nihf + niimm + + else + + call hf(regm-5._r8,wbar1,relhum*subgrid,so4_num,nihf) + call hetero(regm,wbar2,soot_num+dst_num,niimm,nidep) + + ! If some homogeneous nucleation happened, assume all of the + ! heterogeneous particles nucleated and add in a fraction of + ! the homogeneous freezing. + if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice + oso4_num = nihf + endif + + osoot_num = soot_num * (niimm + nidep) / (soot_num + dst_num) + odst_num = dst_num * (niimm + nidep) / (soot_num + dst_num) + + nihf = nihf * fhom * ((regm - tc) / 5._r8)**2 + oso4_num = oso4_num * fhom * ((regm - tc) / 5._r8)**2 + + n1 = niimm + nidep + nihf + + end if + end if + + ! Scale the rates for in-cloud number, since this is what + ! MG is expecting to find. + ni = n1 + + ! If using prexsiting ice, then add it to the total. + if (use_preexisting_ice) then + ni = ni + Ni_preice * 1e-6_r8 + end if + end if + end if + end if + + ! deposition/condensation nucleation in mixed clouds (-37-64 deg) + A22_fast =-6.045_r8 !(T<=-64 deg) + B1_fast =-0.008_r8 + B21_fast =-0.042_r8 !(T>-64 deg) + B22_fast =-0.112_r8 !(T<=-64 deg) + C1_fast =0.0739_r8 + C2_fast =1.2372_r8 + + A1_slow =-0.3949_r8 + A2_slow =1.282_r8 + B1_slow =-0.0156_r8 + B2_slow =0.0111_r8 + B3_slow =0.0217_r8 + C1_slow =0.120_r8 + C2_slow =2.312_r8 + + Ni = 0.0_r8 + + !RHw parameters + A = 6.0e-4_r8*log(ww)+6.6e-3_r8 + B = 6.0e-2_r8*log(ww)+1.052_r8 + C = 1.68_r8 *log(ww)+129.35_r8 + RHw=(A*T*T+B*T+C)*0.01_r8 + + if((T.le.-37.0_r8) .and. ((RH).ge.RHw)) then + + regm = 6.07_r8*log(ww)-55.0_r8 + + if(T.ge.regm) then ! fast-growth regime + + if(T.gt.-64.0_r8) then + A2_fast=A21_fast + B2_fast=B21_fast + else + A2_fast=A22_fast + B2_fast=B22_fast + endif + + k1_fast = exp(A2_fast + B2_fast*T + C2_fast*log(ww)) + k2_fast = A1_fast+B1_fast*T+C1_fast*log(ww) + + Ni = k1_fast*Na**(k2_fast) + Ni = min(Ni,Na) + + else ! slow-growth regime + + k1_slow = exp(A2_slow + (B2_slow+B3_slow*log(ww))*T + C2_slow*log(ww)) + k2_slow = A1_slow+B1_slow*T+C1_slow*log(ww) + + Ni = k1_slow*Na**(k2_slow) + Ni = min(Ni,Na) + + endif + + end if + + end subroutine hf + + !=============================================================================== + + subroutine Vpreice(P_in, T_in, R_in, C_in, S_in, V_out) + + ! based on Karcher et al. (2006) + ! VERTICAL VELOCITY CALCULATED FROM DEPOSITIONAL LOSS TERM + + ! arguments + REAL(r8), INTENT(in) :: P_in ! [Pa],INITIAL AIR pressure + REAL(r8), INTENT(in) :: T_in ! [K] ,INITIAL AIR temperature + REAL(r8), INTENT(in) :: R_in ! [m],INITIAL MEAN ICE CRYSTAL NUMBER RADIUS + REAL(r8), INTENT(in) :: C_in ! [m-3],INITIAL TOTAL ICE CRYSTAL NUMBER DENSITY, [1/cm3] + REAL(r8), INTENT(in) :: S_in ! [-],INITIAL ICE SATURATION RATIO;; if <1, use hom threshold Si + REAL(r8), INTENT(out) :: V_out ! [m/s], VERTICAL VELOCITY REDUCTION (caused by preexisting ice) + + ! parameters + REAL(r8), PARAMETER :: ALPHAc = 0.5_r8 ! density of ice (g/cm3), !!!V is not related to ALPHAc + REAL(r8), PARAMETER :: FA1c = 0.601272523_r8 + REAL(r8), PARAMETER :: FA2c = 0.000342181855_r8 + REAL(r8), PARAMETER :: FA3c = 1.49236645E-12_r8 + REAL(r8), PARAMETER :: WVP1c = 3.6E+10_r8 + REAL(r8), PARAMETER :: WVP2c = 6145.0_r8 + REAL(r8), PARAMETER :: FVTHc = 11713803.0_r8 + REAL(r8), PARAMETER :: THOUBKc = 7.24637701E+18_r8 + REAL(r8), PARAMETER :: SVOLc = 3.23E-23_r8 ! SVOL=XMW/RHOICE + REAL(r8), PARAMETER :: FDc = 249.239822_r8 + REAL(r8), PARAMETER :: FPIVOLc = 3.89051704E+23_r8 + REAL(r8) :: T,P,S,R,C + REAL(r8) :: A1,A2,A3,B1,B2 + REAL(r8) :: T_1,PICE,FLUX,ALP4,CISAT,DLOSS,VICE + + T = T_in ! K , K + P = P_in*1e-2_r8 ! Pa , hpa + + IF (S_in.LT.1.0_r8) THEN + S = 2.349_r8 - (T/259.0_r8) ! homogeneous freezing threshold, according to Ren & McKenzie, 2005 + ELSE + S = S_in ! INPUT ICE SATURATION RATIO, -, >1 + ENDIF + + R = R_in*1e2_r8 ! m => cm + C = C_in*1e-6_r8 ! m-3 => cm-3 + T_1 = 1.0_r8/ T + PICE = WVP1c * EXP(-(WVP2c*T_1)) + ALP4 = 0.25_r8 * ALPHAc + FLUX = ALP4 * SQRT(FVTHc*T) + CISAT = THOUBKc * PICE * T_1 + A1 = ( FA1c * T_1 - FA2c ) * T_1 + A2 = 1.0_r8/ CISAT + A3 = FA3c * T_1 / P + B1 = FLUX * SVOLc * CISAT * ( S-1.0_r8 ) + B2 = FLUX * FDc * P * T_1**1.94_r8 + DLOSS = FPIVOLc * C * B1 * R**2 / ( 1.0_r8+ B2 * R ) + VICE = ( A2 + A3 * S ) * DLOSS / ( A1 * S ) ! 2006,(19) + V_out = VICE*1e-2_r8 ! cm/s => m/s + + end subroutine Vpreice + + !=============================================================================== + + subroutine frachom(Tmean,RHimean,detaT,fhom) + + ! How much fraction of cirrus might reach Shom + ! base on "A cirrus cloud scheme for general circulation models", + ! B. Karcher and U. Burkhardt 2008 + + real(r8), intent(in) :: Tmean, RHimean, detaT + real(r8), intent(out) :: fhom + + real(r8), parameter :: seta = 6132.9_r8 ! K + integer, parameter :: Nbin=200 ! (Tmean - 3*detaT, Tmean + 3*detaT) + + real(r8) :: PDF_T(Nbin) ! temperature PDF; ! PDF_T=0 outside (Tmean-3*detaT, Tmean+3*detaT) + real(r8) :: Sbin(Nbin) ! the fluctuations of Si that are driven by the T variations + real(r8) :: Sihom, deta + integer :: i + + Sihom = 2.349_r8-Tmean/259.0_r8 ! homogeneous freezing threshold, according to Ren & McKenzie, 2005 + fhom = 0.0_r8 + + do i = Nbin, 1, -1 + + deta = (i - 0.5_r8 - Nbin/2)*6.0_r8/Nbin ! PDF_T=0 outside (Tmean-3*detaT, Tmean+3*detaT) + Sbin(i) = RHimean*exp(deta*detaT*seta/Tmean**2.0_r8) + PDF_T(i) = exp(-deta**2.0_r8/2.0_r8)*6.0_r8/(sqrt(2.0_r8*Pi)*Nbin) + + + if (Sbin(i).ge.Sihom) then + fhom = fhom + PDF_T(i) + else + exit + end if + end do + + fhom = min(1.0_r8, fhom/0.997_r8) ! accounting for the finite limits (-3 , 3) + end subroutine frachom + +end module oslo_aero_nucleate_ice diff --git a/src/physics/cam_oslo/microp_aero.F90 b/src/physics/cam_oslo/microp_aero.F90 index b0bf597d53..9cfab23524 100644 --- a/src/physics/cam_oslo/microp_aero.F90 +++ b/src/physics/cam_oslo/microp_aero.F90 @@ -36,14 +36,15 @@ module microp_aero use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn use cam_history, only: addfld, add_default, outfld use cam_logfile, only: iulog - use commondefinitions, only: nmodes_oslo => nmodes + ! + use commondefinitions, only: nmodes_oslo => nmodes use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC, MODE_IDX_OMBC_INTMIX_COAT_AIT use aerosoldef, only: lifeCycleNumberMedianRadius, l_dst_a2, l_dst_a3, l_bc_ai use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex, getCloudTracerIndex use oslo_utils, only: CalculateNumberConcentration use parmix_progncdnc - use hetfrz_classnuc_oslo - use nucleate_ice_oslo + use oslo_aero_hetfrz + use oslo_aero_nucleate_ice implicit none private From cdc579cff92665d69a90b4de13de4b65e4e1a554 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 30 Aug 2023 14:15:29 +0200 Subject: [PATCH 28/71] renamed oxi_diurnal_var.F90 oxi_diurnal_var.F90 --- .../oslo_aero/{oxi_diurnal_var.F90 => oslo_aero_diurnal_var.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/chemistry/oslo_aero/{oxi_diurnal_var.F90 => oslo_aero_diurnal_var.F90} (100%) diff --git a/src/chemistry/oslo_aero/oxi_diurnal_var.F90 b/src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 similarity index 100% rename from src/chemistry/oslo_aero/oxi_diurnal_var.F90 rename to src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 From 8a1962adf176fc5b463ca585f0af6dd3111a7b6b Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 30 Aug 2023 14:15:35 +0200 Subject: [PATCH 29/71] renamed oxi_diurnal_var.F90 oxi_diurnal_var.F90 --- .../oslo_aero/oslo_aero_diurnal_var.F90 | 993 +++++++++--------- src/physics/cam_oslo/mo_gas_phase_chemdr.F90 | 20 +- 2 files changed, 479 insertions(+), 534 deletions(-) diff --git a/src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 b/src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 index 3820a8bb2a..480ace2042 100644 --- a/src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 @@ -1,537 +1,488 @@ -module oxi_diurnal_var +module oslo_aero_diurnal_var -use chem_mods, only : nfs -use physconst, only : pi -use mo_chem_utls, only : get_inv_ndx -use ppgrid, only : pcols, pver -use phys_grid, only: get_rlat_all_p, get_rlon_all_p -use shr_kind_mod, only: r8 => shr_kind_r8 -implicit none -private -save + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only : pcols, pver + use phys_grid, only : get_rlat_all_p, get_rlon_all_p + use chem_mods, only : nfs + use physconst, only : pi + use time_manager, only : get_curr_date + use mo_chem_utls, only : get_inv_ndx + implicit none + private -public :: & - set_diurnal_invariants - -private :: & - sunrisesetxx , srisesetxx + public :: set_diurnal_invariants + private :: sunrisesetxx , srisesetxx integer, pointer :: id_oh,id_no3,id_ho2 logical :: inv_oh,inv_ho2,inv_no3 contains - - subroutine set_diurnal_invariants(invariants,dtc,ncol,lchnk,inv_oh,inv_ho2,id_oh,id_ho2, inv_no3, id_no3) !++IH: added ,inv_no3, id_no3 - - use chem_mods, only : nfs - use time_manager, only : get_curr_date - - - real(r8), intent(in) :: dtc ! Time step - integer, intent(in) :: ncol - integer, intent(in) :: lchnk ! chunk id - logical, intent(in) :: inv_oh, inv_ho2, inv_no3 !++IH: added inv_no3 - integer, intent(in) :: id_oh, id_ho2, id_no3 !++IH: added id_no3 - real(r8), intent(inout) :: invariants(ncol,pver,nfs) - - - - - integer :: i ! column index - integer :: k ! height index - integer :: iriseset ! sunrise/set flag - integer :: day, mon, yr, jyr ! date stuff - integer :: j ! working var - integer :: ncsec ! time stuff - - real(r8) :: deglat, deglon ! lat and long (degrees) - real(r8) :: solardec ! solar declination (degrees) - real(r8) :: sum ! working vars - real(r8) :: trise, tset ! sunrise and set times (h then d) - real(r8) :: tlight ! amount of daylight (d) - real(r8) :: trisej, tsetj ! working vars - real(r8) :: t1, t2, ta, tb ! working vars - real(r8) :: rlats(pcols), rlons(pcols) ! latitude & longitude (radians) - real(r8) :: fdiurn_oxid - real(r8) :: fdiurn_no3oxid !++IH - - - - call get_curr_date(yr, mon, day, ncsec) - call get_rlat_all_p( lchnk, ncol, rlats ) - call get_rlon_all_p( lchnk, ncol, rlons ) - -! jyr = mod( yr, 100 ) + 1900 -! if (jyr < 1950) jyr = jyr + 100 -! if (jyr > 2049) jyr = jyr - 100 - jyr=2000 -! Assume the daily cycle to follow year 2000. The subroutine is -! at any rate only valid between 1950 and 2050, so important years e.g. 1850 -! is out of boundary - - - do i=1,ncol - - fdiurn_oxid=1._r8 - fdiurn_no3oxid=1._r8 !++IH - - deglat = rlats(i)*180._r8/pi - deglat = max( -89.9999_r8, min( +89.9999_r8, deglat ) ) - deglon = rlons(i)*180._r8/pi - -! get sunrise and sunset times in UTC hours - call sunrisesetxx( deglon, deglat, jyr, mon, day, & - iriseset, trise, tset, solardec ) - -! convert rise/set times to days -! compute tlight = amount of daylight -! handle case of all day or night - if (iriseset > 0) then - trise = trise/24._r8 - tset = tset/24._r8 - tlight = tset - trise - if (tlight < 0._r8) then - tset = tset + 1.0_r8 - tlight = tlight + 1._r8 - end if - else - trise = 0._r8 - if (abs(deglat+solardec) .ge. 90._r8) then - tset = 1._r8 - else - tset = 0._r8 - end if - tlight = tset - trise !length of light period in a day - end if - -! if all day or all night (or very close to it), set fdiurn = 1.0 -! Also in periods with all night, we put the mean value for all night steps - if ((tlight .ge. 0.99_r8) .or. (tlight .le. 0.01_r8)) then - fdiurn_oxid = 1._r8 - fdiurn_no3oxid = 1._r8 !++IH -! otherwise determine overlap between current timestep and daylight times -! to account for all overlap possibilities, need to try this -! with rise/set times shifted by +/- 1 day - else !==> There is diurnal cycle - t1 = ncsec/86400._r8 !start of timestep (days) - t2 = t1 + dtc/86400._r8 !end of timestep (days) - sum = 0._r8 - do j = -1, 1 - trisej = trise + dfloat(j) !one day before sunrise, sunrise, one day after runrise - tsetj = trisej + tlight !time of sunset given "j" - ta = max( t1, trisej ) !start or sunrise (if later) - tb = min( t2, tsetj ) !end of step or sunset (if earlier) - sum = sum + max( tb-ta, 0._r8 ) - - end do - - !sum is length of timestep (in days) which has light - !"sum"/(t1-t2) is fraction of timestep which has light - !"tlight is fraction of day which has light - !So if fraction of dt is higher than avg fraction during day ==> increase oxidants - ! if fraction of dt is lower than avg fraction during day ==> decrease oxidants - - !++IH - if (inv_oh .or. inv_ho2) then - !--IH - fdiurn_oxid = max(1.0e-3_r8, sum/(t2-t1)/tlight) - !++IH - end if - if (inv_no3) then - fdiurn_no3oxid = max(1.0e-3_r8, (1._r8 - (sum/(t2-t1))) / (1._r8 - tlight)) - ! (1._r8 - (sum/(t2-t1))) is the fraction of timestep WITHOUT light - ! (1._r8 - tlight) is the fraction of day WITHOUT light - end if - !--IH - end if - - if (inv_oh) then - do k=1,pver - invariants(i,k,id_oh)=invariants(i,k,id_oh)*fdiurn_oxid - end do + subroutine set_diurnal_invariants(invariants,dtc,ncol,lchnk,inv_oh,inv_ho2,id_oh,id_ho2, inv_no3, id_no3) + + real(r8) , intent(in) :: dtc ! Time step + integer , intent(in) :: ncol + integer , intent(in) :: lchnk ! chunk id + logical , intent(in) :: inv_oh, inv_ho2, inv_no3 + integer , intent(in) :: id_oh, id_ho2, id_no3 + real(r8) , intent(inout) :: invariants(ncol,pver,nfs) + + integer :: i ! column index + integer :: k ! height index + integer :: iriseset ! sunrise/set flag + integer :: day, mon, yr, jyr ! date stuff + integer :: j ! working var + integer :: ncsec ! time stuff + real(r8) :: deglat, deglon ! lat and long (degrees) + real(r8) :: solardec ! solar declination (degrees) + real(r8) :: sum ! working vars + real(r8) :: trise, tset ! sunrise and set times (h then d) + real(r8) :: tlight ! amount of daylight (d) + real(r8) :: trisej, tsetj ! working vars + real(r8) :: t1, t2, ta, tb ! working vars + real(r8) :: rlats(pcols), rlons(pcols) ! latitude & longitude (radians) + real(r8) :: fdiurn_oxid + real(r8) :: fdiurn_no3oxid + + call get_curr_date(yr, mon, day, ncsec) + call get_rlat_all_p( lchnk, ncol, rlats ) + call get_rlon_all_p( lchnk, ncol, rlons ) + + ! jyr = mod( yr, 100 ) + 1900 + ! if (jyr < 1950) jyr = jyr + 100 + ! if (jyr > 2049) jyr = jyr - 100 + jyr=2000 + ! Assume the daily cycle to follow year 2000. The subroutine is + ! at any rate only valid between 1950 and 2050, so important years e.g. 1850 + ! is out of boundary + + do i=1,ncol + + fdiurn_oxid=1._r8 + fdiurn_no3oxid=1._r8 + + deglat = rlats(i)*180._r8/pi + deglat = max( -89.9999_r8, min( +89.9999_r8, deglat ) ) + deglon = rlons(i)*180._r8/pi + + ! get sunrise and sunset times in UTC hours + call sunrisesetxx( deglon, deglat, jyr, mon, day, iriseset, trise, tset, solardec ) + + ! convert rise/set times to days + ! compute tlight = amount of daylight + ! handle case of all day or night + if (iriseset > 0) then + trise = trise/24._r8 + tset = tset/24._r8 + tlight = tset - trise + if (tlight < 0._r8) then + tset = tset + 1.0_r8 + tlight = tlight + 1._r8 + end if + else + trise = 0._r8 + if (abs(deglat+solardec) .ge. 90._r8) then + tset = 1._r8 + else + tset = 0._r8 + end if + tlight = tset - trise !length of light period in a day + end if + + ! if all day or all night (or very close to it), set fdiurn = 1.0 + ! Also in periods with all night, we put the mean value for all night steps + if ((tlight .ge. 0.99_r8) .or. (tlight .le. 0.01_r8)) then + fdiurn_oxid = 1._r8 + fdiurn_no3oxid = 1._r8 !++IH + ! otherwise determine overlap between current timestep and daylight times + ! to account for all overlap possibilities, need to try this + ! with rise/set times shifted by +/- 1 day + else !==> There is diurnal cycle + t1 = ncsec/86400._r8 !start of timestep (days) + t2 = t1 + dtc/86400._r8 !end of timestep (days) + sum = 0._r8 + do j = -1, 1 + trisej = trise + dfloat(j) !one day before sunrise, sunrise, one day after runrise + tsetj = trisej + tlight !time of sunset given "j" + ta = max( t1, trisej ) !start or sunrise (if later) + tb = min( t2, tsetj ) !end of step or sunset (if earlier) + sum = sum + max( tb-ta, 0._r8 ) + + end do + + ! sum is length of timestep (in days) which has light + ! "sum"/(t1-t2) is fraction of timestep which has light + ! "tlight is fraction of day which has light + ! if fraction of dt is higher than avg fraction during day ==> increase oxidants + ! if fraction of dt is lower than avg fraction during day ==> decrease oxidants + + if (inv_oh .or. inv_ho2) then + fdiurn_oxid = max(1.0e-3_r8, sum/(t2-t1)/tlight) + end if + if (inv_no3) then + fdiurn_no3oxid = max(1.0e-3_r8, (1._r8 - (sum/(t2-t1))) / (1._r8 - tlight)) + ! (1._r8 - (sum/(t2-t1))) is the fraction of timestep WITHOUT light + ! (1._r8 - tlight) is the fraction of day WITHOUT light + end if + end if + + if (inv_oh) then + do k=1,pver + invariants(i,k,id_oh)=invariants(i,k,id_oh)*fdiurn_oxid + end do + end if + if (inv_ho2) then + do k=1,pver + invariants(i,k,id_ho2)=invariants(i,k,id_ho2)*fdiurn_oxid + end do + end if + if (inv_no3) then + do k=1,pver + invariants(i,k,id_no3)=invariants(i,k,id_no3)*fdiurn_no3oxid + end do + end if + + end do ! i= 1,ncol + end subroutine set_diurnal_invariants + + + !-------------------------------------------------------------------- + subroutine sunrisesetxx( xlong, ylat, iyear, imonth, iday, & + iflag, trise, tset, solardec ) + ! + ! input parameters + ! xlong - longitude in degrees (east longitudes are positive) + ! ylat - latitude in degrees (north latitudes are positive) + ! iyear - year + ! imonth - month + ! iday - day + ! output parameters + ! iflag - status flag + ! +1 - OK and there is a sunrise and sunset + ! 0 - OK but no sunrise or sunset + ! -1 = input parameters (date or position) are bad + ! trise - time of sunrise in UT hours + ! tset - time of sunset in UT hours + ! solardec - apparent solar declination in degrees + ! + ! written 17-aug-93 by r.c.easter + ! Rewritten into fortran 90 by Seland + + ! arguments + real(r8) ,intent(in) :: xlong + real(r8) ,intent(in) :: ylat + integer ,intent(in) :: iyear + integer ,intent(in) :: imonth + integer ,intent(in) :: iday + integer ,intent(out) :: iflag + real(r8) ,intent(out) :: trise + real(r8) ,intent(out) :: tset + real(r8) ,intent(out) :: solardec + + ! local + real(r8) :: sunrise, sunset, ap_dec + real(r8) :: xlongb + integer :: iriseset,i + + ! need xlong between -180 and +180 + xlongb = xlong + + if (xlongb .lt. -180.) then + xlongb = xlongb + 360._r8 + else if (xlongb .gt. 180._r8) then + xlongb = xlongb - 360._r8 end if - if (inv_ho2) then - do k=1,pver - invariants(i,k,id_ho2)=invariants(i,k,id_ho2)*fdiurn_oxid - end do + call srisesetxx( iyear, imonth, iday, ylat, xlongb, iriseset,sunrise, sunset, ap_dec) + + iflag = iriseset + if (iflag .eq. 0) then + iflag = 1 + if (abs(sunrise+100_r8) .le. 0.01_r8) iflag = 0 end if - - !++IH - if (inv_no3) then - do k=1,pver - invariants(i,k,id_no3)=invariants(i,k,id_no3)*fdiurn_no3oxid - end do + trise = sunrise + tset = sunset + solardec = ap_dec + + end subroutine sunrisesetxx + + !*************************************************************************** + subroutine srisesetxx(iyear, month, iday, rlat, rlong, iriseset,sunrise, sunset,ap_dec) + + integer ,intent(in) :: iyear + integer ,intent(in) :: month + integer ,intent(in) :: iday + real(r8) ,intent(in) :: rlat + real(r8) ,intent(in) :: rlong + integer ,intent(out) :: iriseset + real(r8) ,intent(out) :: sunrise + real(r8) ,intent(out) :: sunset + real(r8) ,intent(out) :: ap_dec + + !local + integer :: jday + integer :: iimonth(12), iimonthleap(12) + logical :: leapyr + + ! math definitions. + real(r8), parameter :: twopi = 2._r8*pi + real(r8), parameter :: deg_rad = 0.017453292519943295_r8 + real(r8), parameter :: rad_deg = 57.295779513082323_r8 + + ! local variables + real(r8) :: mean_anomaly, mean_longitude, mean_obliquity + real(r8) :: year + real(r8) :: delta_years,delta_days,days_j2000 + real(r8) :: cent_j2000,f_mean_anomaly,f_mean_longitude + real(r8) :: ecliptic_long,f_ap_ra, ap_ra,f_gmst0h + real(r8) :: gmst0h,rlat_r,tan_lat,tan_dec,tangterm + real(r8) :: timeterm + + data iimonth /0,31,59,90,120,151,181,212,243,273,304,334/ + data iimonthleap /0,31,60,91,121,152,182,213,244,274,305,335/ + leapyr = .false. + + ! "sunriseset.c" contains the integer function sunriseset() for calculating + ! the rising and setting times of the Sun as seen from a place on Earth on a + ! specific date. + ! + ! Version 1.0 - April 6, 1992. + ! (This code was adapted from "solarpos.c" Version 3.1.) + ! + ! sunriseset() employs the low precision formulas for the Sun's coordinates + ! given in the "Astronomical Almanac" of 1990 to compute the Sun's apparent + ! right ascension, apparent declination, and Greenwich mean sidereal time at + ! 0 hours Universal Time, and then the rising and setting times of the Sun. + ! The "Astronomical Almanac" (A. A.) states a precision of 0.01 degree for the + ! apparent coordinates between the years 1950 and 2050. + ! + ! The following assumptions and simplifications are made: + ! -> diurnal parallax is ignored, resulting in 0 to 9 arc seconds error in + ! apparent position. + ! -> diurnal aberration is also ignored, resulting in 0 to 0.02 second error + ! in right ascension and 0 to 0.3 arc second error in declination. + ! -> geodetic site coordinates are used, without correction for polar motion + ! (maximum amplitude of 0.3 arc second) and local gravity anomalies. + ! -> the formulas ignore atmospheric refraction, semi-diameter, and changes + ! in right ascension and declination over the course of a day; the + ! accuracies of sunrise and sunset are about 2 and 7 minutes for latitude + ! and longitude of 0 degrees, but accuracy degrades significantly for high + ! latitudes. + ! + ! + ! The necessary input parameters are: + ! -> the UT date, specified in one of three ways: + ! 1) year, month, day.fraction + ! 2) year, daynumber.fraction + ! 3) days.fraction elapsed since January 0, 1900. + ! Note: in GChM application, only specification #1 is currently valid + ! -> site geodetic (geographic) latitude and longitude. + ! + ! Refer to the function declaration for the parameter type specifications and + ! formats. + ! + ! sunriseset() returns -1 if an input parameter is out of bounds, or 0 if + ! values were written to the locations specified by the output parameters. + ! Sunrise and sunset times are in UT hours; if there is no sunrise or sunset + ! the values are -1.0. + ! + ! Author: Nels Larson + ! Pacific Northwest Lab. + ! P.O. Box 999 + ! Richland, WA 99352 + ! U.S.A. + ! + !-------------------------------------------------------------------------- + ! modifications for gchm application by eg chapman + ! 1. translated from c language to fortran + ! 2. input date must be in year, month, day.fraction format; other input + ! code eliminated. + ! 3. added indicator iriseset. when equal to -1, indicates location + ! or date is out of range. + ! + !--------------------------------------------------------------------------- + + !------------------------------------------------------------------------- + ! explanation of terms taken from c code + ! int iyear, Four digit year (Gregorian calendar). + ! [1950 through 2049; 0 if using days_1900] + ! month; Month number. + ! [1 through 12; 0 if using daynumber for day] + ! + ! day, /* Calendar day.fraction, or daynumber.fraction. + ! * [If month is NOT 0: + ! + ! * 0 through 32; 31st @ 18:10:00 UT = 31.75694 + ! * If month IS 0: + ! * 0 through 367; 366 @ 18:10:00 UT = 366.75694] */ + ! days_1900, /* Days since 1900 January 0 @ 00:00:00 UT. + ! * [18262.0 (1950/01/00) through 54788.0 (2049/12/32); + ! + ! * 1990/01/01 @ 18:10:00 UT = 32873.75694; + ! * 0.0 o.k. if using {year, month, day} or + ! * {year, daynumber}] */ + ! rlat Observation site geographic latitude. + ! [degrees.fraction, North positive] + ! rlong Observation site geographic longitude. + ! [degrees.fraction, East positive] + ! *ap_ra, /* Apparent solar right ascension. + ! * [hours; 0.0 <= *ap_ra < 24.0] */ + ! *ap_dec, /* Apparent solar declination. + ! * [degrees; -90.0 <= *ap_dec <= 90.0] */ + ! + ! *sunrise, /* Time of sunrise. + ! [UT hours.fraction; -1.0 if no sunrise or sunset] */ + ! *sunset; /* Time of sunset. + ! [UT hours.fraction; -1.0 if no sunset or sunrise] */ + ! int daynum(); /* Computes a sequential daynumber during a year. */ + ! int daynumber, /* Sequential daynumber during a year. */ + ! delta_days, /* Whole days since 2000 January 0. */ + ! delta_years; /* Whole years since 2000. */ + ! double cent_J2000, /* Julian centuries since epoch J2000.0 at 0h UT. */ + ! days_J2000, /* Days since epoch J2000.0. */ + ! ecliptic_long, /* Solar ecliptic longitude. */ + ! + ! gmst0h, /* Greenwich mean sidereal time at 0 hours UT. */ + ! integral, /* Integral portion of double precision number. */ + ! mean_anomaly, /* Earth mean anomaly. */ + ! mean_longitude, /* Solar mean longitude. */ + ! mean_obliquity, /* Mean obliquity of the ecliptic. */ + ! tan_dec, /* Tangent of apparent declination. */ + ! tan_lat, /* Tangent of latitude. */ + ! + ! tangterm, /* Tangent term of Sun rise/set equation. */ + ! timeterm; /* Time term of Sun rise/set equation. */ + !---------------------------------------------------------------------- + iriseset = 0 + + ! check latitude, longitude, dates for proper range before calculating dates. + if (((rlat .lt. -90._r8) .or. (rlat .gt. 90._r8)) .or. & + ((rlong .lt. -180._r8) .or. (rlong .gt. 180._r8))) then + iriseset = -1 + return end if - !--IH - - end do ! i= 1,ncol - end subroutine set_diurnal_invariants - - -!-------------------------------------------------------------------- - subroutine sunrisesetxx( xlong, ylat, iyear, imonth, iday, & - iflag, trise, tset, solardec ) -! -! provides interface to subr srisesetxx without use of common blocks -! -! input parameters -! xlong - longitude in degrees (east longitudes are positive) -! ylat - latitude in degrees (north latitudes are positive) -! iyear - year -! imonth - month -! iday - day -! output parameters -! iflag - status flag -! +1 - OK and there is a sunrise and sunset -! 0 - OK but no sunrise or sunset -! -1 = input parameters (date or position) are bad -! trise - time of sunrise in UT hours -! tset - time of sunset in UT hours -! solardec - apparent solar declination in degrees -! -! written 17-aug-93 by r.c.easter -! Rewritten into fortran 90 by Ø Seland - - - - -! arguments - - - real(r8) ,intent(in) :: xlong - real(r8) ,intent(in) :: ylat - integer ,intent(in) :: iyear - integer ,intent(in) :: imonth - integer ,intent(in) :: iday - integer ,intent(out) :: iflag - real(r8) ,intent(out) :: trise - real(r8) ,intent(out) :: tset - real(r8) ,intent(out) :: solardec -! local - real(r8) sunrise, sunset, ap_dec - real(r8) :: xlongb - integer :: iriseset,i - -! need xlong between -180 and +180 - xlongb = xlong -! do 1000 i = 1, 10 - if (xlongb .lt. -180.) then - xlongb = xlongb + 360._r8 - else if (xlongb .gt. 180._r8) then - xlongb = xlongb - 360._r8 -! else -! goto 1050 - end if -!1000 continue -!1050 continue - - call srisesetxx( iyear, imonth, iday, ylat, xlongb, & - iriseset,sunrise, sunset, ap_dec) - - iflag = iriseset - if (iflag .eq. 0) then - iflag = 1 - if (abs(sunrise+100_r8) .le. 0.01_r8) iflag = 0 - end if - trise = sunrise - tset = sunset - solardec = ap_dec - - end subroutine sunrisesetxx - - - -!c*************************************************************************** - subroutine srisesetxx(iyear, month, iday, rlat, rlong, & - iriseset,sunrise, sunset,ap_dec) - - - integer ,intent(in) :: iyear - integer ,intent(in) :: month - integer ,intent(in) :: iday - real(r8) ,intent(in) :: rlat - real(r8) ,intent(in) :: rlong - integer ,intent(out) :: iriseset - real(r8) ,intent(out) :: sunrise - real(r8) ,intent(out) :: sunset - real(r8) ,intent(out) :: ap_dec - - -!local - integer :: jday - - integer ,dimension(12) :: iimonth,iimonthleap - logical :: leapyr - -!c math definitions. -! real(r8),parameter :: twopi = 6.2831853071795864_r8 - real(r8),parameter :: twopi = 2._r8*pi - real(r8), parameter :: deg_rad = 0.017453292519943295_r8 - real(r8), parameter :: rad_deg = 57.295779513082323_r8 -! local variables - - real(r8) :: mean_anomaly, mean_longitude, mean_obliquity - real(r8) :: year - - real(r8) :: delta_years,delta_days,days_j2000 - real(r8) :: cent_j2000,f_mean_anomaly,f_mean_longitude - real(r8) :: ecliptic_long,f_ap_ra, ap_ra,f_gmst0h - real(r8) :: gmst0h,rlat_r,tan_lat,tan_dec,tangterm - real(r8) :: timeterm - - data iimonth /0,31,59,90,120,151,181,212,243,273,304,334/ - data iimonthleap /0,31,60,91,121,152,182,213,244,274,305,335/ - leapyr = .false. - -!! common / sundataxx_cmn / jday, iriseset, -! + sunrise, sunset, rloc_timehrs, ap_dec -!c-------------------------------------------------------------------------- -!c "sunriseset.c" contains the integer function sunriseset() for calculating -!c the rising and setting times of the Sun as seen from a place on Earth on a -!c specific date. -!c -!c Version 1.0 - April 6, 1992. -!c (This code was adapted from "solarpos.c" Version 3.1.) -!c -!c sunriseset() employs the low precision formulas for the Sun's coordinates -!c given in the "Astronomical Almanac" of 1990 to compute the Sun's apparent -!c right ascension, apparent declination, and Greenwich mean sidereal time at -!c 0 hours Universal Time, and then the rising and setting times of the Sun. -!c The "Astronomical Almanac" (A. A.) states a precision of 0.01 degree for the -!c apparent coordinates between the years 1950 and 2050. -!c -!c The following assumptions and simplifications are made: -!c -> diurnal parallax is ignored, resulting in 0 to 9 arc seconds error in -!c apparent position. -!c -> diurnal aberration is also ignored, resulting in 0 to 0.02 second error -!c in right ascension and 0 to 0.3 arc second error in declination. -!c -> geodetic site coordinates are used, without correction for polar motion -!c (maximum amplitude of 0.3 arc second) and local gravity anomalies. -!c -> the formulas ignore atmospheric refraction, semi-diameter, and changes -!c in right ascension and declination over the course of a day; the -!c accuracies of sunrise and sunset are about 2 and 7 minutes for latitude -!c and longitude of 0 degrees, but accuracy degrades significantly for high -!c latitudes. -!c -!c -!c The necessary input parameters are: -!c -> the UT date, specified in one of three ways: -!c 1) year, month, day.fraction -!c 2) year, daynumber.fraction -!c 3) days.fraction elapsed since January 0, 1900. -!c Note: in GChM application, only specification #1 is currently valid -!c -> site geodetic (geographic) latitude and longitude. -!c -!c Refer to the function declaration for the parameter type specifications and -!c formats. -!c -!c sunriseset() returns -1 if an input parameter is out of bounds, or 0 if -!c values were written to the locations specified by the output parameters. -!c Sunrise and sunset times are in UT hours; if there is no sunrise or sunset -!c the values are -1.0. -!c -!c Author: Nels Larson -!c Pacific Northwest Lab. -!c P.O. Box 999 -!c Richland, WA 99352 -!c U.S.A. -!c -!c-------------------------------------------------------------------------- -!c modifications for gchm application by eg chapman -!c 1. translated from c language to fortran -!c 2. input date must be in year, month, day.fraction format; other input -!c code eliminated. -!c 3. added indicator iriseset. when equal to -1, indicates location -!c or date is out of range. -!c -!c--------------------------------------------------------------------------- - -!c------------------------------------------------------------------------- -!c explanation of terms taken from c code -!c int iyear, Four digit year (Gregorian calendar). -!c [1950 through 2049; 0 if using days_1900] -!c month; Month number. -!c [1 through 12; 0 if using daynumber for day] -!c -!c day, /* Calendar day.fraction, or daynumber.fraction. -!c * [If month is NOT 0: -!c -!c * 0 through 32; 31st @ 18:10:00 UT = 31.75694 -!c * If month IS 0: -!c * 0 through 367; 366 @ 18:10:00 UT = 366.75694] */ -!c days_1900, /* Days since 1900 January 0 @ 00:00:00 UT. -!c * [18262.0 (1950/01/00) through 54788.0 (2049/12/32); -!c -!c * 1990/01/01 @ 18:10:00 UT = 32873.75694; -!c * 0.0 o.k. if using {year, month, day} or -!c * {year, daynumber}] */ -!c rlat Observation site geographic latitude. -!c [degrees.fraction, North positive] -!c rlong Observation site geographic longitude. -!c [degrees.fraction, East positive] -!c *ap_ra, /* Apparent solar right ascension. -!c * [hours; 0.0 <= *ap_ra < 24.0] */ -!c *ap_dec, /* Apparent solar declination. -!c * [degrees; -90.0 <= *ap_dec <= 90.0] */ -!c -!c *sunrise, /* Time of sunrise. -!c [UT hours.fraction; -1.0 if no sunrise or sunset] */ -!c *sunset; /* Time of sunset. -!c [UT hours.fraction; -1.0 if no sunset or sunrise] */ -!c int daynum(); /* Computes a sequential daynumber during a year. */ -!c int daynumber, /* Sequential daynumber during a year. */ -!c delta_days, /* Whole days since 2000 January 0. */ -!c delta_years; /* Whole years since 2000. */ -!c double cent_J2000, /* Julian centuries since epoch J2000.0 at 0h UT. */ -!c days_J2000, /* Days since epoch J2000.0. */ -!c ecliptic_long, /* Solar ecliptic longitude. */ -!c -!c gmst0h, /* Greenwich mean sidereal time at 0 hours UT. */ -!c integral, /* Integral portion of double precision number. */ -!c mean_anomaly, /* Earth mean anomaly. */ -!c mean_longitude, /* Solar mean longitude. */ -!c mean_obliquity, /* Mean obliquity of the ecliptic. */ -!c tan_dec, /* Tangent of apparent declination. */ -!c tan_lat, /* Tangent of latitude. */ -!c -!c tangterm, /* Tangent term of Sun rise/set equation. */ -!c timeterm; /* Time term of Sun rise/set equation. */ -!c---------------------------------------------------------------------- - iriseset = 0 -!c check latitude, longitude, dates for proper range before calculating dates. - if (((rlat .lt. -90._r8) .or. (rlat .gt. 90._r8)) .or. & - ((rlong .lt. -180._r8) .or. (rlong .gt. 180._r8))) then - iriseset = -1 - return - end if - -! Year assumed to be betweeen 1950 and 2049. As the model is outside these -! boundary in many cases. year 2000 is assumed for this version of the -! model - - -! if (iyear .lt. 1950 .or. iyear .gt. 2049) then -! iriseset = -1 -! return -! end if -! if (((month .lt. 1) .or. (month .gt. 12)) .or. & -! ((iday .lt. 0) .or. (iday .gt. 32))) then -! iriseset = -1 -! return -! end if -!c determine julian day number - - - -!c there is no year 0 in the Gregorian calendar and the leap year cycle -!c changes for earlier years. -! if (iyear .lt. 1) then -! iriseset = -1 -! return -! end if -!c leap years are divisible by 4, except for centurial years not divisible -!c by 400. - - -! year = real (iyear) -! if ((amod(year,4.) .eq. 0.0) .and. (amod(year,100.) .ne. 0.0)) & -! leapyr = 1 -! if(amod(year,400.) .eq. 0.0) leapyr = 1 - jday = iimonth(month) + iday -! if ((leapyr .eq. 1) .and. (month .gt. 2)) jday = jday + 1 - -! - -!The -!c construct Julian centuries since J2000 at 0 hours UT of date, -!c days.fraction since J2000, and UT hours. - delta_years = iyear - 2000._r8 -!c delta_days is days from 2000/01/00 (1900's are negative). - delta_days = delta_years * 365._r8 + delta_years / 4._r8 + jday - if (iyear .gt. 2000) delta_days = delta_days + 1._r8 -!c J2000 is 2000/01/01.5 - days_j2000 = delta_days - 1.5_r8 - cent_j2000 = days_j2000 / 36525._r8 -!c compute solar position parameters. -!c A. A. 1990, C24. - f_mean_anomaly = (357.528_r8 + 0.9856003_r8 * days_j2000) - f_mean_longitude = (280.460_r8 + 0.9856474_r8 * days_j2000) -!c put mean_anomaly and mean_longitude in the range 0 -> 2 pi. - mean_anomaly = (f_mean_anomaly / 360._r8 - int(f_mean_anomaly & - /360._r8)) * twopi - mean_longitude = (f_mean_longitude /360. - int( & - f_mean_longitude/360._r8)) * twopi - mean_obliquity = (23.439_r8 - 4.0e-7_r8 * days_j2000) * deg_rad - ecliptic_long = ((1.915_r8 * sin(mean_anomaly)) + & - (0.020_r8 * sin(2.0 * mean_anomaly))) * deg_rad + & - mean_longitude -! tangent of ecliptic_long separated into sine and cosine parts for ap_ra. - f_ap_ra = atan2(cos(mean_obliquity) * sin(ecliptic_long), & - cos(ecliptic_long)) -! change range of ap_ra from -pi -> pi to 0 -> 2 pi. - if (f_ap_ra .lt. 0.0) f_ap_ra = f_ap_ra + twopi -! put ap_ra in the range 0 -> 24 hours. - ap_ra = (f_ap_ra / twopi - int(f_ap_ra /twopi)) * 24._r8 - ap_dec = asin(sin(mean_obliquity) * sin(ecliptic_long)) -! calculate local mean sidereal time. -! A. A. 1990, B6-B7. -! horner's method of polynomial exponent expansion used for gmst0h. - f_gmst0h = 24110.54841_r8 + cent_j2000 * (8640184.812866_r8 & - +cent_j2000 * (0.093104_r8 - cent_j2000 * 6.2e-6_r8)) -! convert gmst0h from seconds to hours and put in the range 0 -> 24. -! 24 hours = 86400 seconds - gmst0h = (f_gmst0h / 86400._r8 - int(f_gmst0h / 86400._r8)) * 24._r8 - if (gmst0h .lt. 0._r8) gmst0h = gmst0h + 24._r8 -!c convert latitude to radians. - rlat_r = rlat * deg_rad -!c avoid tangent overflow at +-90 degrees. -!c 1.57079615 radians is equal to 89.99999 degrees. - if (abs(rlat_r) .lt. 1.57079615_r8) then - tan_lat = tan(rlat_r) - else - tan_lat = 6.0e6_r8 - end if - if (abs(ap_dec) .lt. 1.57079615_r8) then - tan_dec = tan(ap_dec) - else - tan_dec = 6.0e6_r8 - end if -!c compute UTs of sunrise and sunset. -!c A. A. 1990, A12. - tangterm = tan_lat * tan_dec - if (abs(tangterm) .gt. 1.0_r8) then - sunrise = -100._r8 - sunset = -100._r8 - else -!c compute angle of tangterm and convert to hours. - tangterm = acos(-tangterm) / twopi * 24._r8 - timeterm = ap_ra - rlong / 15._r8 - gmst0h - sunrise = timeterm - tangterm - sunset = timeterm + tangterm -!c put sunrise and sunset in the range 0 to 24 hours. -!cec inserted following statement since in some latitudes timeterm -!cec minus tangterm is less than -25 - if (sunrise .le. -24._r8) sunrise = sunrise + 48._r8 - if (sunrise .lt. 0._r8) sunrise = sunrise + 24._r8 - if (sunrise .ge. 24._r8) sunrise = sunrise - 24._r8 - if (sunset .lt. 0._r8) sunset = sunset + 24._r8 - if (sunset .ge. 24._r8) sunset = sunset - 24._r8 -!c mean sidereal day is 0.99727 mean solar days. - sunrise = sunrise * 0.99727_r8 - sunset = sunset * 0.99727_r8 - end if -!c convert ap_dec to degrees. - ap_dec = ap_dec * rad_deg - return - end subroutine srisesetxx - - -end module oxi_diurnal_var - - + ! Year assumed to be betweeen 1950 and 2049. As the model is outside these + ! boundary in many cases. year 2000 is assumed for this version of the + ! model + ! if (iyear .lt. 1950 .or. iyear .gt. 2049) then + ! iriseset = -1 + ! return + ! end if + ! if (((month .lt. 1) .or. (month .gt. 12)) .or. & + ! ((iday .lt. 0) .or. (iday .gt. 32))) then + ! iriseset = -1 + ! return + ! end if + ! determine julian day number + + ! there is no year 0 in the Gregorian calendar and the leap year cycle + ! changes for earlier years. + ! if (iyear .lt. 1) then + ! iriseset = -1 + ! return + ! end if + ! leap years are divisible by 4, except for centurial years not divisible by 400. + + ! year = real (iyear) + ! if ((amod(year,4.) .eq. 0.0) .and. (amod(year,100.) .ne. 0.0)) & + ! leapyr = 1 + ! if(amod(year,400.) .eq. 0.0) leapyr = 1 + + jday = iimonth(month) + iday + ! if ((leapyr .eq. 1) .and. (month .gt. 2)) jday = jday + 1 + + ! construct Julian centuries since J2000 at 0 hours UT of date, + ! days.fraction since J2000, and UT hours. + delta_years = iyear - 2000._r8 + + ! delta_days is days from 2000/01/00 (1900's are negative). + delta_days = delta_years * 365._r8 + delta_years / 4._r8 + jday + if (iyear .gt. 2000) delta_days = delta_days + 1._r8 + + ! J2000 is 2000/01/01.5 + days_j2000 = delta_days - 1.5_r8 + cent_j2000 = days_j2000 / 36525._r8 + + ! compute solar position parameters. + ! A. A. 1990, C24. + f_mean_anomaly = (357.528_r8 + 0.9856003_r8 * days_j2000) + f_mean_longitude = (280.460_r8 + 0.9856474_r8 * days_j2000) + + ! put mean_anomaly and mean_longitude in the range 0 -> 2 pi. + mean_anomaly = (f_mean_anomaly / 360._r8 - int(f_mean_anomaly/360._r8)) * twopi + mean_longitude = (f_mean_longitude /360. - int(f_mean_longitude/360._r8)) * twopi + mean_obliquity = (23.439_r8 - 4.0e-7_r8 * days_j2000) * deg_rad + ecliptic_long = ((1.915_r8 * sin(mean_anomaly)) + (0.020_r8 * sin(2.0 * mean_anomaly))) * deg_rad + mean_longitude + + ! tangent of ecliptic_long separated into sine and cosine parts for ap_ra. + f_ap_ra = atan2(cos(mean_obliquity) * sin(ecliptic_long), cos(ecliptic_long)) + + ! change range of ap_ra from -pi -> pi to 0 -> 2 pi. + if (f_ap_ra .lt. 0.0) f_ap_ra = f_ap_ra + twopi + + ! put ap_ra in the range 0 -> 24 hours. + ap_ra = (f_ap_ra / twopi - int(f_ap_ra /twopi)) * 24._r8 + ap_dec = asin(sin(mean_obliquity) * sin(ecliptic_long)) + + ! calculate local mean sidereal time. + ! A. A. 1990, B6-B7. + ! horner's method of polynomial exponent expansion used for gmst0h. + f_gmst0h = 24110.54841_r8 + cent_j2000 * (8640184.812866_r8 & + +cent_j2000 * (0.093104_r8 - cent_j2000 * 6.2e-6_r8)) + + ! convert gmst0h from seconds to hours and put in the range 0 -> 24. + ! 24 hours = 86400 seconds + gmst0h = (f_gmst0h / 86400._r8 - int(f_gmst0h / 86400._r8)) * 24._r8 + if (gmst0h .lt. 0._r8) gmst0h = gmst0h + 24._r8 + + ! convert latitude to radians. + rlat_r = rlat * deg_rad + + ! avoid tangent overflow at +-90 degrees. + ! 1.57079615 radians is equal to 89.99999 degrees. + if (abs(rlat_r) .lt. 1.57079615_r8) then + tan_lat = tan(rlat_r) + else + tan_lat = 6.0e6_r8 + end if + if (abs(ap_dec) .lt. 1.57079615_r8) then + tan_dec = tan(ap_dec) + else + tan_dec = 6.0e6_r8 + end if + + ! compute UTs of sunrise and sunset. + ! A. A. 1990, A12. + tangterm = tan_lat * tan_dec + if (abs(tangterm) .gt. 1.0_r8) then + sunrise = -100._r8 + sunset = -100._r8 + else + ! compute angle of tangterm and convert to hours. + tangterm = acos(-tangterm) / twopi * 24._r8 + timeterm = ap_ra - rlong / 15._r8 - gmst0h + sunrise = timeterm - tangterm + sunset = timeterm + tangterm + + ! put sunrise and sunset in the range 0 to 24 hours. + !ec inserted following statement since in some latitudes timeterm + !ec minus tangterm is less than -25 + if (sunrise .le. -24._r8) sunrise = sunrise + 48._r8 + if (sunrise .lt. 0._r8) sunrise = sunrise + 24._r8 + if (sunrise .ge. 24._r8) sunrise = sunrise - 24._r8 + if (sunset .lt. 0._r8) sunset = sunset + 24._r8 + if (sunset .ge. 24._r8) sunset = sunset - 24._r8 + + ! mean sidereal day is 0.99727 mean solar days. + sunrise = sunrise * 0.99727_r8 + sunset = sunset * 0.99727_r8 + end if + ! convert ap_dec to degrees. + ap_dec = ap_dec * rad_deg + return + end subroutine srisesetxx +end module oslo_aero_diurnal_var diff --git a/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 b/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 index e9a70b8ee6..8788535835 100644 --- a/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 +++ b/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 @@ -62,8 +62,6 @@ subroutine gas_phase_chemdr_inti() use rate_diags, only : rate_diags_init use cam_abortutils, only : endrun - implicit none - character(len=3) :: string integer :: n, m, err, ii logical :: history_cesm_forcing @@ -218,7 +216,7 @@ subroutine gas_phase_chemdr_inti() call addfld( 'HCL_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase hcl' ) call addfld( 'HCL_STS', (/ 'lev' /), 'I', 'mol/mol', 'STS condensed HCL' ) - !++IH: Adding extra fields for oxi-output (before and after diurnal variations.) + ! Adding extra fields for oxi-output (before and after diurnal variations.) call addfld ('OH_bef ', (/ 'lev' /), 'A','unit', 'OH invariants before adding diurnal variations' ) call addfld ('HO2_bef ', (/ 'lev' /), 'A','unit', 'HO2 invariants before adding diurnal variations' ) call addfld ('NO3_bef ', (/ 'lev' /), 'A','unit', 'NO3 invariants before adding diurnal variations' ) @@ -329,23 +327,19 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & use mo_chm_diags, only : chm_diags, het_diags use perf_mod, only : t_startf, t_stopf use gas_wetdep_opts, only : gas_wetdep_method - use oxi_diurnal_var, only : set_diurnal_invariants + use oslo_aero_diurnal_var, only : set_diurnal_invariants use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx use infnan, only : nan, assignment(=) use rate_diags, only : rate_diags_calc use mo_mass_xforms, only : mmr2vmr, vmr2mmr, h2o_to_vmr, mmr2vmri use orbit, only : zenith -! -! LINOZ -! + ! + ! LINOZ use lin_strat_chem, only : do_lin_strat_chem, lin_strat_chem_solve use linoz_data, only : has_linoz_data -! -! for aqueous chemistry and aerosol growth -! - use aero_model, only : aero_model_gasaerexch - - use aero_model, only : aero_model_strat_surfarea + ! + ! for aqueous chemistry and aerosol growth + use aero_model, only : aero_model_gasaerexch, aero_model_strat_surfarea implicit none From cda1d11ec8334fd629f3ab51378b30a735e5fe56 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 30 Aug 2023 16:38:04 +0200 Subject: [PATCH 30/71] more cleanup --- src/chemistry/oslo_aero/aero_model.F90 | 42 +- src/chemistry/oslo_aero/aerocom_dry_mod.F90 | 14 +- src/chemistry/oslo_aero/aerocom_mod.F90 | 42 +- src/chemistry/oslo_aero/aerocom_opt_mod.F90 | 14 +- src/chemistry/oslo_aero/aerosoldef.F90 | 2 +- src/chemistry/oslo_aero/intlog.F90 | 15 +- src/chemistry/oslo_aero/oslo_aero_conc.F90 | 831 +++++++++++++++ ...mxsub.F90 => oslo_aero_optical_params.F90} | 59 +- .../{opttab.F90 => oslo_aero_sw_tables.F90} | 75 +- src/chemistry/oslo_aero/parmix_progncdnc.F90 | 979 ------------------ src/physics/cam_oslo/microp_aero.F90 | 31 +- src/physics/cam_oslo/ndrop.F90 | 21 +- src/physics/cam_oslo/radiation.F90 | 12 +- 13 files changed, 959 insertions(+), 1178 deletions(-) create mode 100644 src/chemistry/oslo_aero/oslo_aero_conc.F90 rename src/chemistry/oslo_aero/{pmxsub.F90 => oslo_aero_optical_params.F90} (95%) rename src/chemistry/oslo_aero/{opttab.F90 => oslo_aero_sw_tables.F90} (98%) delete mode 100644 src/chemistry/oslo_aero/parmix_progncdnc.F90 diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 4334b0d784..b0400dd99b 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -28,29 +28,29 @@ module aero_model use drydep_mod, only: inidrydep use wetdep, only: wetdep_init ! - use oslo_aero_depos, only: oslo_aero_depos_init, oslo_aero_depos_dry, oslo_aero_depos_wet - use oslo_aero_coag, only: coagtend, clcoag - use oslo_utils, only: calculateNumberConcentration - use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName - use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers - use aerosoldef, only: lifeCycleNumberMedianRadius - use aerosoldef, only: getCloudTracerName - use aerosoldef, only: aero_register - use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub - use condtend, only: registerCondensation, initializeCondensation, condtend_sub - use sox_cldaero_mod, only: sox_cldaero_init - use intlog, only: initlogn - use seasalt_model, only: seasalt_init, seasalt_emis, seasalt_active - use dust_model, only: dust_init, dust_emis, dust_active - use oslo_ocean_intr, only: oslo_ocean_init, oslo_dms_emis_intr - use opttab, only: initopt, initopt_lw - use commondefinitions, only: originalSigma, originalNumberMedianRadius - use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes - use const, only: numberToSurface + use oslo_aero_depos, only: oslo_aero_depos_init, oslo_aero_depos_dry, oslo_aero_depos_wet + use oslo_aero_coag, only: coagtend, clcoag + use oslo_utils, only: calculateNumberConcentration + use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName + use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers + use aerosoldef, only: lifeCycleNumberMedianRadius + use aerosoldef, only: getCloudTracerName + use aerosoldef, only: aero_register + use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub + use condtend, only: registerCondensation, initializeCondensation, condtend_sub + use sox_cldaero_mod, only: sox_cldaero_init + use intlog, only: initlogn + use seasalt_model, only: seasalt_init, seasalt_emis, seasalt_active + use dust_model, only: dust_init, dust_emis, dust_active + use oslo_ocean_intr, only: oslo_ocean_init, oslo_dms_emis_intr + use oslo_aero_sw_tables, only: initopt, initopt_lw + use commondefinitions, only: originalSigma, originalNumberMedianRadius + use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes + use const, only: numberToSurface use calcaersize #ifdef AEROCOM - use aerocom_opt_mod, only: initaeropt - use aerocom_dry_mod, only: initdryp + use aerocom_opt_mod, only: initaeropt + use aerocom_dry_mod, only: initdryp #endif implicit none diff --git a/src/chemistry/oslo_aero/aerocom_dry_mod.F90 b/src/chemistry/oslo_aero/aerocom_dry_mod.F90 index 5ae901a737..68c4095ed5 100644 --- a/src/chemistry/oslo_aero/aerocom_dry_mod.F90 +++ b/src/chemistry/oslo_aero/aerocom_dry_mod.F90 @@ -2,13 +2,13 @@ module aerocom_dry_mod #ifdef AEROCOM - use shr_kind_mod , only: r8 => shr_kind_r8 - use ppgrid , only: pcols, pver - use commondefinitions , only: nmodes, nbmodes - use opttab , only: cate, cat, fac, faq, fbc, fombg, fbcbg, nbmp1 - use lininterpol_mod , only: lininterpol3dim, lininterpol4dim, lininterpol5dim - use oslo_control , only: oslo_getopts, dir_string_length - use cam_logfile , only: iulog + use shr_kind_mod , only: r8 => shr_kind_r8 + use ppgrid , only: pcols, pver + use commondefinitions , only: nmodes, nbmodes + use oslo_aero_sw_tables, only: cate, cat, fac, faq, fbc, fombg, fbcbg, nbmp1 + use lininterpol_mod , only: lininterpol3dim, lininterpol4dim, lininterpol5dim + use oslo_control , only: oslo_getopts, dir_string_length + use cam_logfile , only: iulog implicit none private diff --git a/src/chemistry/oslo_aero/aerocom_mod.F90 b/src/chemistry/oslo_aero/aerocom_mod.F90 index 37f2cfcf24..55803eadb2 100644 --- a/src/chemistry/oslo_aero/aerocom_mod.F90 +++ b/src/chemistry/oslo_aero/aerocom_mod.F90 @@ -3,14 +3,16 @@ module aerocom_mod #ifdef AEROCOM use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_history, only: outfld - use constituents, only: pcnst - use const - use aerosoldef - use commondefinitions + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_history, only: outfld + use physics_types, only: physics_state + ! use aerocom_opt_mod, only: extinction_coeffs, extinction_coeffsn use aerocom_dry_mod, only: aerodry_prop + use aerosoldef + use commondefinitions + use oslo_aero_sw_tables + use const public :: aerocom public :: opticsAtConstRh @@ -1453,7 +1455,7 @@ subroutine aerocom(daylight, Cam) irfmax=1 #endif ! AEROCOM_INSITU - ! Note: using xrhnull etc as proxy for constant RH input values (see opttab.F90) + ! Note: using xrhnull etc as proxy for constant RH input values (see oslo_aero_sw_tables.F90) do irf=1,irfmax do k=1,pver do icol=1,ncol @@ -1475,21 +1477,8 @@ subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & xfombg, ifombg1, vnbc, vaitbc, v_soana) ! Extra AeroCom diagnostics requiring table look-ups with constant/fixed RH, - ! i.e. for RH = (/"00","40","55","65","75","85" /) (see opttab.F90) - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_history, only: outfld - use constituents, only: pcnst - use opttab - use const - use aerosoldef - use commondefinitions - use physics_types, only: physics_state - use aeroopt_mod, only : extinction_coeffs, extinction_coeffsn - - implicit none - ! + ! i.e. for RH = (/"00","40","55","65","75","85" /) (see oslo_aero_sw_tables.F90) + ! Input arguments ! integer, intent(in) :: lchnk ! chunk identifier @@ -1787,13 +1776,6 @@ subroutine intfrh (lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relh, frh) ! Written by Alf Kirkevaag in November 2011, based on interpol1to3 in optinterpol.F90 ! called by NorESM/physpkg - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use opttab, only: rh - use commondefinitions, only: nmodes - - implicit none - ! ! Input arguments integer, intent(in) :: lchnk ! chunk identifier integer, intent(in) :: ncol ! number of atmospheric columns @@ -1815,7 +1797,7 @@ subroutine intfrh (lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relh, frh) real(r8) :: t_xrh, t_rh1, t_rh2 parameter (e=2.718281828) - ! Relative humidity intries from opttab.F90: + ! Relative humidity intries from oslo_aero_sw_tables ! rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, & ! 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) ! Humidity growth factors which are consistent with the aerosol optics look-up tables: diff --git a/src/chemistry/oslo_aero/aerocom_opt_mod.F90 b/src/chemistry/oslo_aero/aerocom_opt_mod.F90 index 986e81bc7e..e17cf34394 100644 --- a/src/chemistry/oslo_aero/aerocom_opt_mod.F90 +++ b/src/chemistry/oslo_aero/aerocom_opt_mod.F90 @@ -2,13 +2,13 @@ module aerocom_opt_mod #ifdef AEROCOM - use shr_kind_mod , only : r8 => shr_kind_r8 - use ppgrid , only : pcols, pver - use commondefinitions , only : nmodes, nbmodes - use opttab , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg - use oslo_control , only : oslo_getopts, dir_string_length - use cam_logfile , only : iulog - use lininterpol_mod , only : lininterpol3dim, lininterpol4dim, lininterpol5dim + use shr_kind_mod , only : r8 => shr_kind_r8 + use ppgrid , only : pcols, pver + use commondefinitions , only : nmodes, nbmodes + use oslo_aero_sw_tables , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg + use oslo_control , only : oslo_getopts, dir_string_length + use cam_logfile , only : iulog + use lininterpol_mod , only : lininterpol3dim, lininterpol4dim, lininterpol5dim implicit none private diff --git a/src/chemistry/oslo_aero/aerosoldef.F90 b/src/chemistry/oslo_aero/aerosoldef.F90 index da2600225f..c0ae9dbc86 100644 --- a/src/chemistry/oslo_aero/aerosoldef.F90 +++ b/src/chemistry/oslo_aero/aerosoldef.F90 @@ -129,7 +129,7 @@ module aerosoldef real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: belowCloudScavengingCoefficientProcessModes = & (/0.02_r8, 0.01_r8, 0.02_r8, 0.02_r8, 0.02_r8, 0.02_r8 /) - !Growth of aerosols, duplicated in opttab!! AK: NB oppdaterte tall i opttab, rh der er ikke helt lik rhtab... + !Growth of aerosols, duplicated in oslo_aero_sw_tables real(r8), public,dimension (10) :: rhtab real(r8), public,dimension (10,pcnst):: rdivr0(10,pcnst) diff --git a/src/chemistry/oslo_aero/intlog.F90 b/src/chemistry/oslo_aero/intlog.F90 index c6c598e89d..5534c30a35 100644 --- a/src/chemistry/oslo_aero/intlog.F90 +++ b/src/chemistry/oslo_aero/intlog.F90 @@ -1,15 +1,14 @@ module intlog - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols - use commondefinitions, only: nmodes, nbmodes - use opttab, only: nbmp1, cate, fac, faq, fbc, cat - use lininterpol_mod, only: lininterpol3dim, lininterpol4dim + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols + use cam_logfile, only: iulog + use oslo_control, only: oslo_getopts,dir_string_length + use commondefinitions, only: nmodes, nbmodes + use oslo_aero_sw_tables, only: cate, fac, faq, fbc, cat + use lininterpol_mod, only: lininterpol3dim, lininterpol4dim use aerosoldef - use cam_logfile, only: iulog - use oslo_control, only: oslo_getopts,dir_string_length - implicit none private diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 new file mode 100644 index 0000000000..f02431b929 --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_aero_conc.F90 @@ -0,0 +1,831 @@ +module oslo_aero_conc + + use const , only : volumeToNumber,smallNumber + use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o + use ppgrid , only : pcols, pver + use shr_kind_mod , only: r8 => shr_kind_r8 + use physconst , only: pi + use constituents , only: pcnst, cnst_name + ! + use intlog, only: intlog1to3_sub, intlog4_sub, intlog5to10_sub + use oslo_utils, only: calculateNumberConcentration + use const, only: smallNumber + use oslo_aero_coag, only: normalizedCoagulationSink + use condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV + use commondefinitions + use aerosoldef + + implicit none + private + + public :: oslo_aero_conc_calc + public :: calculateBulkProperties + public :: partitionMass + + private :: getAerosolMask + private :: calculateHygroscopicity + private :: addModeHygroscopicity + private :: doLognormalInterpolation + private :: modalapp2d + + ! Size of molecule-layer which defines when particles are coated + real(r8), parameter :: coatingLimit = 2.e-9_r8 ![m] + + ! The fraction of soluble material required in a components before it!will add to any coating + real(r8), parameter :: solubleMassFractionCoatingLimit=0.50_r8 + real(r8), parameter :: aThird = 1.0_r8/3.0_r8 + real(r8), parameter :: ln10 = log(10.0_r8) + +contains + + !******************************************************************************************** + subroutine oslo_aero_conc_calc(ncol, mmr, rho_air, CProcessModes, & + f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & + numberConcentration, volumeConcentration, hygroscopicity, lnsigma, hasAerosol, volumeCore, volumeCoat) + + !---------------------------------------------- + ! Calculate concentrations of aerosol modes based on lifecycle species + !---------------------------------------------- + + ! arguments + integer, intent(in) :: ncol ! Number of columns used in chunk + real(r8), intent(in) :: mmr(pcols,pver,pcnst) ! [kg/kg] mass mixing ratio of tracers + real(r8), intent(in) :: rho_air(pcols,pver) ! [kg/m3] air density + logical, intent(out) :: hasAerosol(pcols, pver, nmodes) ! [t/f] do we have this type of aerosol here? + real(r8), intent(out) :: f_acm(pcols,pver, nbmodes) ! [frc] carbon fraction in mode + real(r8), intent(out) :: f_bcm(pcols,pver, nbmodes) ! [frc] fraction of c being bc + real(r8), intent(out) :: f_aqm(pcols, pver, nbmodes) ! [frc] fraction of sulfate being aquous + real(r8), intent(out) :: f_so4_condm(pcols, pver, nbmodes) ! [frc] fraction of non-aquous SO4 being condensate + real(r8), intent(out) :: f_soam(pcols, pver, nbmodes) ! Needed in "get component fraction" + real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ! [#/m3] number concentraiton + real(r8), intent(out) :: volumeConcentration(pcols,pver,nmodes) ! [m3/m3] volume concentration + real(r8), intent(out) :: hygroscopicity(pcols,pver,nmodes) ! [mol_{aer}/mol_{water}] hygroscopicity + real(r8), intent(out) :: lnsigma(pcols,pver,nmodes) ! [-] log(base e) sigma + real(r8), intent(out) :: CProcessModes(pcols,pver) + real(r8), intent(out) :: cam(pcols,pver,nbmodes) + real(r8), intent(out) :: f_c(pcols, pver) + real(r8), intent(out) :: f_aq(pcols,pver) + real(r8), intent(out) :: f_bc(pcols,pver) + real(r8), intent(out) :: f_so4_cond(pcols,pver) + real(r8), intent(out) :: f_soa(pcols,pver) + real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) + real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) + + ! local variables + real(r8) :: f_aitbc(pcols,pver) ! [-] bc fraction in the coated bc-oc mode + real(r8) :: f_nbc(pcols,pver) ! [-] mass fraction of bc in uncoated bc/oc mode + real(r8) :: f_soana(pcols,pver) ! [-] + + !Get mass, number concentration and the total add-ons (previous convaer) + call calculateBulkProperties(ncol, mmr, rho_air, numberConcentration, CProcessModes, & + f_c, f_bc, f_aq, f_so4_cond, f_soa, f_aitbc, f_nbc, f_soana) + + ! Find the points where we have aerosol (number concentration) + call getAerosolMask(ncol, numberConcentration, hasAerosol) + + ! Find out how much is added per size-mode (modalapp) + call partitionMass( ncol, numberConcentration, CProcessModes, & + f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam) + + ! Calculate they hygroscopicity + call calculateHygroscopicity( ncol, mmr, numberConcentration, rho_air, Cam, & + f_acm, f_bcm, f_aqm, hasAerosol, hygroscopicity, & + volumeConcentration, volumeCore, volumeCoat) + + ! Do the interpolation to new modes + call doLognormalInterpolation(ncol, numberConcentration, hasAerosol, cam, & + volumeConcentration, f_c, f_acm, f_bcm, f_aqm, f_aitbc, lnSigma) + + end subroutine oslo_aero_conc_calc + + !****************************************************************** + subroutine calculateBulkProperties( & + ncol & + ,qm & !I [kg/kg] transported tracers + ,rho_air & !I [kg/m3] air density + ,numberConcentration & !O [#/m3] + ,CProcessModes & !O [kg/m3] total added material + ,f_c & !O [-] fraction of aerosol which is carbon + ,f_bc & !O [-] fraction of carbon which is bc + ,f_aq & !O [-] fraction of sulfate which is aq. + ,f_so4_cond & !O [-] fraction of non-aq so4 which is condensate + ,f_soa & !O [-] fraction of OM which is SOA + ,f_aitbc & !O [-] fraction of bc in the background tracer mode + ,f_nbc & !O [-] fraction of bc in the background tracer mode 14 + ,f_soana & !O [-] fraction of soa in background int-mix mode (1) + ) + + !---------------------------------------------- + ! Create bulk properties (dependent on tracers, not size modes) + !---------------------------------------------- + + ! arguments + integer , intent(in) :: ncol ! [nbr] number of columns used + real(r8), intent(in) :: qm(pcols,pver,pcnst) ! [kg/kg] mmr for transported tracers + real(r8), intent(in) :: rho_air(pcols,pver) ! [kg/m3] air density + real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ! [#/m3] aerosol number concentration + real(r8), intent(out) :: f_c(pcols,pver) ![-] mass fraction of process mode being c + real(r8), intent(out) :: f_bc(pcols,pver) ![-] mass fraction of c being bc + real(r8), intent(out) :: f_aq(pcols,pver) ![-] mass fraction of s being aq phase + real(r8), intent(out) :: f_so4_cond(pcols,pver) ![-] mass fraction of non-aq s being condensate + real(r8), intent(out) :: f_soa(pcols,pver) ![-] mass fraction of OM being SOA + real(r8), intent(out) :: f_aitbc(pcols,pver) ![-] mass fraction of bc in bc/oc mixed, coated mode + real(r8), intent(out) :: f_nbc(pcols,pver) ![-] mass fraction of bc in bc/oc mixed, un-coated mode + real(r8), intent(out) :: f_soana(pcols,pver) ![-] mass fraction of soa in background in int mix ait mode (1) + + !Local variables + real(r8) :: totalProcessModes(pcols,pver) ! [kg/kg] Int. mixed (cond./coag./aq.) SO4+BC+OC concentration + real(r8) :: CProcessModes(pcols,pver) ! [kg/m3] Int. mixed (cond./coag./aq.) SO4+BC+OC concentration + integer :: k !counter for layers + + ! Total number concentration per mode + call calculateNumberConcentration(ncol, qm, rho_air, numberConcentration) + + do k=1,pver + + !Total coagulated bc and oc and SO4 (condensate, wet phase and coagulated) (kg/kg) + !internally mixed with background modes + totalProcessModes(:ncol,k) = qm(:ncol,k,l_bc_ac) + qm(:ncol,k,l_om_ac) & + + qm(:ncol,k,l_so4_a1) + qm(:ncol,k,l_so4_a2) + qm(:ncol,k,l_so4_ac) + qm(:ncol,k,l_soa_a1) + + CProcessModes(:ncol,k) = rho_air(:ncol,k)*totalProcessModes(:ncol,k) !==> kg/m3 + + !fraction of process-mode being carbonaceous + f_c(:ncol,k) = min((qm(:ncol,k,l_bc_ac)+qm(:ncol,k,l_om_ac)+qm(:ncol,k,l_soa_a1) )& + /(totalProcessModes(:ncol,k)+smallNumber), 1.0_r8) + + !fraction of "c" being bc (total is oc and bc) + f_bc(:ncol,k) = min(qm(:ncol,k,l_bc_ac)/(qm(:ncol,k,l_bc_ac)+qm(:ncol,k,l_om_ac)+qm(:ncol,k,l_soa_a1)+smallNumber), 1.0_r8) + + !fraction of non-aqeous phase sulphate being condensate + f_so4_cond(:ncol,k) = min(qm(:ncol,k,l_so4_a1)/(qm(:ncol,k,l_so4_a1)+qm(:ncol,k,l_so4_ac)+smallNumber), 1.0_r8) + + !fraction of sulphate being aquous phase (total is condensate + aqeous phase + coagulate) + f_aq(:ncol,k) = min(qm(:ncol,k,l_so4_a2) & + /(qm(:ncol,k,l_so4_a1)+qm(:ncol,k,l_so4_a2)+qm(:ncol,k,l_so4_ac)+smallNumber),1.0_r8) + + !fraction of bc in the sulfate-coated bc/oc mode (total background is bc and oc) + f_aitbc(:ncol,k) = min(qm(:ncol,k,l_bc_ai) / (qm(:ncol,k,l_bc_ai) + qm(:ncol,k,l_om_ai) + smallNumber), 1.0_r8) + + !fraction of bc in the un-coated bc/oc (total is bc and oc) + f_nbc(:ncol,k) = min(qm(:ncol,k,l_bc_ni) / (qm(:ncol,k,l_bc_ni) + qm(:ncol,k,l_om_ni) + smallNumber),1.0_r8) + + !fraction of OM process-mode which is SOA + f_soa(:ncol,k) = min(qm(:ncol,k,l_soa_a1) / (qm(:ncol,k,l_om_ac) + qm(:ncol,k,l_soa_a1) + smallNumber), 1.0_r8) + + !fraction of "background" int-mix (mode 1) which is SOA + f_soana(:ncol,k) = min(qm(:ncol,k,l_soa_na) / (qm(:ncol,k,l_soa_na) + qm(:ncol,k,l_so4_na) + smallNumber), 1.0_r8 ) + + end do !k + + return + end subroutine calculateBulkProperties + + !******************************************************************************** + subroutine partitionMass( ncol, Nnatk, CProcessModes, & + f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam) + + integer , intent(in) :: ncol ! [nbr] number of columns used + real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! [#/m3] number concentration + real(r8), intent(in) :: CProcessModes(pcols,pver) ! [kg/m3] total added mass + real(r8), intent(in) :: f_c(pcols,pver) ! [frc] fraction of added mass being c + real(r8), intent(in) :: f_bc(pcols,pver) ! [frc] fraction of c being bc + real(r8), intent(in) :: f_aq(pcols,pver) ! [frc] fraction of SO4 being aq + real(r8), intent(in) :: f_so4_cond(pcols,pver) ! [frc] fraction of SO4 coag+cond being cond + real(r8), intent(in) :: f_soa(pcols,pver) ! [frc] fraction of OM being SOA + real(r8), intent(out) :: cam(pcols, pver, nbmodes) ! [kg/m3] added mass distributed to modes + real(r8), intent(out) :: f_acm(pcols,pver,nbmodes) ! [frc] as f_c per mode + real(r8), intent(out) :: f_bcm(pcols,pver,nbmodes) ! [frc] as f_bc per mode + real(r8), intent(out) :: f_aqm(pcols,pver,nbmodes) ! [frc] as f_aq per mode + real(r8), intent(out) :: f_so4_condm(pcols,pver,nbmodes) ! [frc] fraction of non aq sulfate being coagulate + real(r8), intent(out) :: f_soam(pcols,pver,nbmodes) ! [frc] fraction of OC being SOA + + call modalapp2d(ncol, Nnatk(1,1,1), CProcessModes, & + f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam) + + end subroutine partitionMass + + !************************************************************* + subroutine getAerosolMask(ncol,numberConcentration, hasAerosol) + + ! Find out where we have aerosols + + integer, intent(in) :: ncol !number of columns used + real(r8), intent(in) :: numberConcentration(pcols, pver, 0:nmodes) + logical, intent(out) :: hasAerosol(pcols, pver, nmodes) + integer :: k !counter for levels + integer :: m !counter for modes + + do m=1,nmodes + do k=1,pver + where(numberConcentration(:ncol,k,m) .gt. smallNumber) + hasAerosol(:ncol,k,m)= .true. + elsewhere + hasAerosol(:ncol,k,m) = .false. + end where + end do !levels + end do !modes + + end subroutine getAerosolMask + + !************************************************************* + subroutine calculateHygroscopicity(ncol, mmr, numberConcentration, rho_air, Cam, & + f_acm, f_bcm, f_aqm, hasAerosol, hygroscopicity, volumeConcentration, volumeCore,volumeCoat) + + ! A parameterization of aerosol activation 2. Multiple aerosol types, JGR, vol 105, noD5, pp 6837 + ! http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract + ! Abdul-Razzak and S. Ghan: + + !INPUT + integer, intent(in) :: ncol + real(r8), intent(in) :: mmr(pcols,pver,pcnst) !I [kg/kg] mass mixing ratios + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes)!I [#/m3] number concentrations + real(r8), intent(in) :: rho_air(pcols,pver) !I [kg/m3] air density + real(r8), intent(in) :: Cam(pcols, pver, nbmodes) !I [kg/m3] total added mass during microphysics + real(r8), intent(in) :: f_acm(pcols,pver,nbmodes) !I [-] fraction of added mass which is carbon + real(r8), intent(in) :: f_aqm(pcols,pver,nbmodes) !I [-] fraction of sulfate which is aq. phase + real(r8), intent(in) :: f_bcm(pcols,pver,nbmodes) !I [-] fraction of C which is bc + logical, intent(in) :: hasAerosol(pcols,pver,nmodes) !I [t/f] do we have aerosols + + !OUTPUT + real(r8), intent(out) :: hygroscopicity(pcols,pver,nmodes) + real(r8), intent(out) :: volumeConcentration(pcols,pver,nmodes) + + !Local variables + real(r8) :: hygroscopicityAvg(pcols,pver) + real(r8) :: hygroscopicityCoat(pcols,pver) + real(r8) :: massConcentrationTracerInMode(pcols,pver) + real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) ![m3] + real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) ![m3] + real(r8) :: averageRadiusCore(pcols,pver) ![m] + real(r8) :: averageRadiusTotal(pcols,pver) ![m] + integer :: kcomp !counter for modes + integer :: l !counter for components + integer :: tracerIndex + integer :: k !counter for levels + integer :: i + + !initialize + hygroscopicity(:,:,:) = 0.0_r8 + volumeConcentration(:,:,:)=0.0_r8 + + do kcomp=1,nmodes + + !Don't do anything if no tracers in mode + if(getNumberOfBackgroundTracersInMode(kcomp) .lt. 1)then + volumeCore(:,:,kcomp)=smallNumber + volumeCoat(:,:,kcomp)=smallNumber + volumeConcentration(:,:,kcomp)=smallNumber + hygroscopicity(:,:,kcomp) = smallNumber + cycle + end if + + hygroscopicityAvg(:,:) = 0.0_r8 + hygroscopicityCoat(:,:) = 0.0_r8 + volumeCore(:,:,kcomp) = 0.0_r8 + volumeCoat(:,:,kcomp) = 0.0_r8 + + !Loop over tracers in mode + do l=1,getNumberOfBackgroundTracersInMode(kcomp) + + tracerIndex = getTracerIndex(kcomp,l,.false.) !get index in physcis space + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = mmr(:ncol,k,tracerIndex)*rho_air(:ncol,k) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , tracerIndex & + ) + end do !background tracers in mode (l) + + !The background modes can have tracer mass added to them + if(kcomp .le. nbmodes)then + + !added aquous sulfate + if(isTracerInMode(kcomp,l_so4_a2))then + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*f_aqm(:ncol,k,kcomp) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , l_so4_a2 & + ) + endif + + !added condensate/coagulate + !All modes which have coagulate have also condensate, so it is + !ok to check for condensate and add the combined mass.. + if(isTracerInMode(kcomp,l_so4_a1))then + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*(1.0_r8 - f_aqm(:ncol,k,kcomp)) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , l_so4_a1 & + ) + endif + !Added bc + if(isTracerInMode(kcomp,l_bc_ac))then + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*f_bcm(:ncol,k,kcomp) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , l_bc_ac & + ) + endif + + !Added oc (both POM and SOA), then both have the same + !properties, so add combined mass here. + !All modes which have condensate also has coagulate, so OK to check + !for condensate and distribute the sum.. + if(isTracerInMode(kcomp,l_soa_a1))then + + do k=1,pver + massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*(1.0_r8 -f_bcm(:ncol,k,kcomp)) + end do + + call addModeHygroscopicity( ncol & + , hasAerosol(:,:,kcomp) & !true if any concentration in this point + , massConcentrationTracerInMode & + , volumeCore(:,:,kcomp) & + , volumeCoat(:,:,kcomp) & + , hygroscopicityAvg & + , hygroscopicityCoat & + , l_om_ac & + ) + endif + end if + + !Note: NCAR definitions of molecular weights are kg/kmol. This is used + !inside "addModeHygroscopicity" and here as in molecularWeightWater. SI units are kg/mol, but + !the error cancels out since eqn 4 has Mw_water/Mw_tracer + + do k=1,pver + + !Finally, when the sums are calculated, Apply finally eqn 4 here!! + + where (hasAerosol(:ncol,k,kcomp)) + where(VolumeCoat(:ncol,k,kcomp) .gt. 1.e-30_r8) + !If there is enough soluble material, a coating will be formed: In that case, the + !volume of the aerosol in question is only the volume of the coating! + hygroscopicityCoat(:ncol,k) = molecularWeightWater*hygroscopicityCoat(:ncol,k) & + & /( density_water * volumeCoat(:ncol,k,kcomp)) !Note use of volume Coating here + elsewhere + hygroscopicityCoat(:ncol,k) = 1.e-30_r8 + endwhere + !mode total volume: + volumeConcentration(:ncol,k,kcomp) = volumeCore(:ncol,k,kcomp) + volumeCoat(:ncol,k,kcomp) + + !hygroscopicity of mixture (Note use of total volume to get average hygroscopicity) + hygroscopicityAvg(:ncol,k) = molecularWeightWater*hygroscopicityAvg(:ncol,k) & + & /(density_water * volumeConcentration(:ncol,k,kcomp)) + + + !Average size of insoluble core (average radius) + averageRadiusCore(:ncol,k) = 0.5_r8*( (volumeCore(:ncol,k,kcomp)) / numberConcentration(:ncol,k,kcomp) * (6.0_r8/pi))**athird + + !Average size of total aerosol (average radius) + averageRadiusTotal(:ncol,k) = 0.5_r8*((volumeConcentration(:ncol,k,kcomp)) / numberConcentration(:ncol,k,kcomp)*(6.0_r8/pi))**athird + + !do i=1,ncol + ! if(numberConcentration(i,k,kcomp) .gt. 1.e6 .and. kcomp.eq.6 )then + ! print*, "hygro_check",kcomp,numberConcentration(i,k,kcomp), averageRadiusTotal(i,k)*1.e6, averageRadiusCore(i,k)*1.e6 & + ! , hygroscopicityCoat(i,k), hygroscopicityAvg(i,k), (averageRadiusTotal(i,k)-averageRadiusCore(i,k))*1.e9 + ! endif + !end do + + !use one or the other hygroscopicity based on coating + where ( averageRadiusTotal(:ncol,k) - averageRadiusCore(:ncol,k) .gt. coatingLimit ) + hygroscopicity(:ncol,k,kcomp) = hygroscopicityCoat(:ncol,k) + elsewhere + hygroscopicity(:ncol,k,kcomp) = hygroscopicityAvg(:ncol,k) + endwhere + elsewhere ! No aerosol + hygroscopicity(:ncol,k,kcomp) = 1.e-10_r8 + end where + + end do !levels + + end do !kcomp /modes + + end subroutine calculateHygroscopicity + + !************************************************************************************** + subroutine addModeHygroscopicity (ncol, hasAerosol, massConcentrationTracerInMode, & + volumeCore, volumeCoat, hygroscopicityAvg, hygroscopicityCoat, tracerIndex) + + ! arguments + integer , intent(in) :: ncol + logical , intent(in) :: hasAerosol(pcols,pver) ![bool] true if we have any aerosol here + real(r8) , intent(in) :: massConcentrationTracerInMode(pcols,pver) ![kg/m3] mass concentration in + integer , intent(in) :: tracerIndex !in physics space + real(r8) , intent(inout) :: volumeCore(pcols, pver) !O [m3/m3] volume of insoluble core + real(r8) , intent(inout) :: volumeCoat(pcols, pver) !O [m3/m3] volume of total aerosol + real(r8) , intent(inout) :: hygroscopicityAvg(pcols, pver) !O [-] average hygroscopicity + real(r8) , intent(inout) :: hygroscopicityCoat(pcols, pver) !O [-] average hygroscopicity + + ! local variables + real(r8) :: massFractionInCoating + integer :: k !counter for levels + + ! Only tracers more soluble than 20% can add to the coating volume + if(solubleMassFraction(tracerIndex) .gt. solubleMassFractionCoatingLimit)then + massFractionInCoating = 1.0_r8 !all volume goes to coating + else + massFractionInCoating = 0.0_r8 !zero volume goes to coating + endif + + do k=1,pver + + where(hasAerosol(:ncol,k) .eqv. .true.) + + volumeCore(:ncol,k) = volumeCore(:ncol,k) & + + massConcentrationTracerInMode(:ncol,k)/rhopart(tracerIndex)*(1.0_r8 - massFractionInCoating) + + volumeCoat(:ncol,k) = volumeCoat(:ncol,k) & + + massConcentrationTracerInMode(:ncol,k)/rhopart(tracerIndex)*massFractionInCoating + + !sum up numerator in eqn 4 in Abdul-Razzak et al (average + !hygrocopicity) Note that molecular weight is that of the + !AEROSOL TYPE This is because of some conflict with mozart + !which needs molecular weight of OC tracers to be 12 when + !reading emissions So molecular weight is duplicated, and + !the molecular weight of the TYPE is used here! + + hygroscopicityAvg(:ncol,k) = hygroscopicityAvg(:ncol,k) + & + massConcentrationTracerInMode(:ncol,k)*numberOfIons(tracerIndex)*osmoticCoefficient(tracerIndex) & + *solubleMassFraction(tracerIndex)/aerosol_type_molecular_weight(aerosolType(tracerIndex)) + + !Contribution to hygroscopicity of coating (only if goes to coating) + !sum up numerator in eqn 4 in Abdul-Razzak et al (average hygrocopicity) + !Note that molecular weight is that of the AEROSOL TYPE + !This is because of some conflict with mozart which needs + !molecular weight of OC tracers to be 12 when reading + !emissions So molecular weight is duplicated, and the + !molecular weight of the TYPE is used here! + + hygroscopicityCoat(:ncol,k) = hygroscopicityCoat(:ncol,k) + & + massConcentrationTracerInMode(:ncol,k)*numberOfIons(tracerIndex)*osmoticCoefficient(tracerIndex) & + *solubleMassFraction(tracerIndex)/aerosol_type_molecular_weight(aerosolType(tracerIndex)) & + *massFractionInCoating !Only add to this if mass goes to coating + + elsewhere + + hygroscopicityAvg(:ncol,k) = 1.0e-10_r8 + hygroscopicityCoat(:ncol,k)= 1.0e-10_r8 + + end where + + end do + + end subroutine addModeHygroscopicity + + !**************************************************************** + subroutine doLognormalInterpolation(ncol, numberConcentration, hasAerosol, & + cam, volumeConcentration, f_c, f_acm, f_bcm, f_aqm, f_aitbc, lnSigma) + + ! arguments + integer , intent(in) :: ncol + real(r8) , intent(in) :: volumeConcentration(pcols,pver,nmodes) + logical , intent(in) :: hasAerosol(pcols,pver,nmodes) + real(r8) , intent(in) :: cam(pcols,pver,nbmodes) ![kg/m3] total added mass per mode + real(r8) , intent(in) :: f_c(pcols,pver) ![frc] fraction of carbon in total add-on + real(r8) , intent(in) :: f_acm(pcols,pver,nbmodes) ![frc] fraction of carbon per mode (in add-on) + real(r8) , intent(in) :: f_bcm(pcols,pver,nbmodes) ![frc] fraction of bc in carbon per mode + real(r8) , intent(in) :: f_aqm(pcols,pver,nbmodes) ![frc] fraction of aq in sulfate added + real(r8) , intent(in) :: f_aitbc(pcols,pver) ![frc] fraction of bc in coated bc/oc mode + real(r8) , intent(inout) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration + real(r8) , intent(out) :: lnsigma(pcols,pver,nmodes) ![-] log (base e) of std. dev + + ! local variables + real(r8) :: nconccm3(pcols,pver) + real(r8) :: camUg(pcols,pver) + real(r8) :: log10sig(pcols,pver) ! [-] logarithm (base 10) of look up tables + real(r8) :: f_ocm(pcols,pver,4) ! [-] fraction of added mass which is either SOA condensate or OC coagulate + integer :: iloop + integer :: kcomp + integer :: i + integer :: k + real(r8), dimension(pcols,pver,nbmodes) :: cxs ![ug/m3] NOTE NON-SI UNITS non-allocated mass + integer , dimension(pcols) :: ind ![idx] index in mapping (not really used) + real(r8), dimension(pcols,pver) :: radius_tmp ![m] radius in look up tables + + + !total mass not allocated to any mode + !this is non-zero if the look-up table can not cope with all the add-on mass + !cxstot(:,:) = 0.0_r8 + + !Remove this later! + do i=1,ncol + ind(i)=i + end do + + ! calculate fraction of added mass which is either SOA condensate or OC coagulate, + ! which in AeroTab are both treated as condensate for kcomp=1-4 + do kcomp=1,4 + do k=1,pver + do i=1,ncol + f_ocm(i,k,kcomp) = f_acm(i,k,kcomp)*(1.0_r8-f_bcm(i,k,kcomp)) + enddo + enddo + enddo + + do iloop=1,1 ! loop over i>1 for testing CPU use in intlog* + + !Go through all "background" size-modes (kcomp=1-10) + do kcomp=1,nbmodes + + camUg(:,:) = cam(:,:,kcomp)*1.e9_r8 + nConccm3(:,:) = 1e-6_r8*numberConcentration(:,:,kcomp) + + !Calculate growth from knowing added process specific internally mixed mass to each background mode + !(level sent but not needed, and kcomp not needed for intlog4_sub) + + if( kcomp .ge. MODE_IDX_SO4SOA_AIT .and. kcomp .le. MODE_IDX_BC_AIT)then ! kcomp=1,2 + + do k=1,pver + call intlog1to3_sub( & + ncol & !I number of points + , ind & !I [idx] mappoing of points to use + , kcomp & !I [idx] mode index + , camUg(:,k) & !I [ug/m3] mass concentration + , nConccm3(:,k) & !I [#/cm3] number concentration + , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. + , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table + , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance + , radius_tmp(:,k) & !O [m] Number median radius + ) + + end do !loop on levels + + else if(kcomp .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT)then ! kcomp=4 + + do k=1,pver + call intlog4_sub( & + ncol & !I number of points + , ind & !I [idx] mappoing of points to use + , kcomp & !I [idx] mode index + , camUg(:,k) & !I [ug/m3] mass concentration + , nConccm3(:,k) & !I [#/cm3] number concentration + , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. + , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous + , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table + , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance + , radius_tmp(:,k) & !O [m] Number median radius + ) + end do + + else if (kcomp .ge. MODE_IDX_SO4_AC .and. kcomp .le. MODE_IDX_SS_A3)then ! kcomp=5-10 + + do k=1,pver + call intlog5to10_sub( & + ncol & !I [nbr] number of points used + , ind & !I [mapping] (not used) + , kcomp & !I [mode index] + , camUg(:,k) & !I [ug/m3] mass concentration + , nConccm3(:,k) & !I [#/cm3] number concentration + , f_acm(:,k,kcomp) & !I [frc] fraction of aerosol which is carbon + , f_bcm(:,k,kcomp) & !I [frc] fraction of carbon which is bc + , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous + , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table (not given to any mode) + , log10sig(:,k) & !O logarithm (base 10) sigma, is later thrown away begause of volume balance + , radius_tmp(:,k) & !O [m] Number median radius + ) + end do ! k + + endif + + !initialize + lnsigma(:,:,kcomp) = log(2.0_r8) + + !The whole point of the interpolation routines is to get the new sigma ==> so trust the sigma + + !This means that in order to conserve the volume (which is known), we have to throw away + !the number concentration. Should create a diagnostic or a warning if number concenration is very different + !from the original number concentration since in principal, the number concentration is + !also conserved! + do k=1,pver + !Don't change number concentration unless "hasAerosol" is true + where(hasAerosol(:ncol,k,kcomp)) + + lnsigma(:ncol,k,kcomp) = ln10*log10sig(:ncol,k) + + numberConcentration(:ncol,k,kcomp) = volumeConcentration(:ncol,k,kcomp)*6.0_r8/pi & + /(2.0_r8*radius_tmp(:ncol,k))**3 & + *DEXP(-4.5_r8*lnsigma(:ncol,k,kcomp)*lnsigma(:ncol,k,kcomp)) + + !==> Now we have a set of n, vol, sigma which is consistent and gives back whatever the + !lookup tables told us! If the look up tables were conserving volume we didn't have to do + !the step just above!! + + !Sum up all mass which was not added to any mode (mass exceeding the max limit in the look-up tables) + !cxstot(:ncol,k) = cxstot(:ncol,k) + cxs(:ncol,k,kcomp)*1.e-9_r8 ! ug/m3 ==> kg/m3 + + end where + end do + + end do !kcomp + + !The modes which do not have any added aerosol: + do kcomp=nbmodes+1,nmodes + do k=1,pver + lnsigma(:ncol,k,kcomp) = log(originalSigma(kcomp)) + end do + end do + + !AK (fxm): "unactivated" code below... + !Excessive internally mixed process mass added to the background modes (exceeding the max limit in the look-up tables) + !is instead added to / lumped with the externally mixed non-background modes (kcomp=11,12,14) + !numberConcentration(:,:,MODE_IDX_SO4_NUC) = numberConcentration(:,:,MODE_IDX_SO4_NUC) & + ! + (volumeToNumber(MODE_IDX_SO4_NUC) & !excess sulfate mass is moved to this mode + ! *RESHAPE(cxstot,(/pcols,pver/)) & + ! *(1.0_r8-f_c(:,:))/rhopart(l_so4_n)) + + !numberConcentration(:,:,MODE_IDX_BC_NUC) = numberConcentration(:,:,MODE_IDX_BC_NUC) & + ! + (volumeToNumber(MODE_IDX_BC_NUC) & !excess carbon mass is moved to this mode + ! * RESHAPE(cxstot,(/pcols,pver/)) & + ! * f_c(:,:)/rhopart(l_bc_n)) + + !SKIP LUMPING OF OC-MODE TO MODE MODE_IDX_LUMPED ORGANICS SINCE THIS WILL MESS UP THE HASAEROSOL-MASK! + ! modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) = efact_omn & !excess OM mass is moved to this mode (originally kcomp=13) + ! * (modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) + cxstot(i)*modedefs(i)%f_c*(1.0_r8-modedefs(i)%f_bc)) + + + enddo ! iloop + + end subroutine doLognormalInterpolation + + !******************************************************************************************** + subroutine modalapp2d(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm,fbcm,faqm,fso4condm,fsoam) + + ! Calculation of the apportionment of internally mixed SO4, BC and OC + ! mass between the various background mineral and sea-salt modes. + ! Now also Aitken-modes are subject to condensation of H2SO4, and both n and + ! Aitken modes may coagulate onto the mineral/sea-salt background aerosol. + !SOA + ! May 2013: The SO4(Ait) mode now takes into account condensed SOA in addition + ! to H2SO4, but as long as SOA is not allowed to condense on more than one + ! mode, no changes are necessary here. NB: to allow SOA to condense also on + ! the BC(Ait) and/or other modes, change this code accordingly! Without any + ! changes, Cam(pcols,1) = condensed SO4 onto the SO4(ait) mode still. + !SOA + ! Alf Grini, february 2014 : Added info about units, + ! used values calculated at initialization. + ! changed in-out variables to components of derived data types (modedefs) + ! defined in microphysics_oslo.F90, and corrected for mass balance error + ! for SO4 due to lumping of coagulate and condensate. + + ! Arguments + integer , intent(in) :: ncol ! number of columns used + real(r8), intent(in) :: Nnatkbg(pcols,pver,nbmodes) ! aerosol background mode number concentration #/m3 + real(r8), intent(in) :: Ca(pcols,pver) ! internally mixed mass, tot=SO4+OC+BC + real(r8), intent(in) :: f_c(pcols,pver) ! mass fraction (OC+BC)/tot + real(r8), intent(in) :: f_bc(pcols,pver) ! mass fraction BC/(OC+BC) + real(r8), intent(in) :: f_aq(pcols,pver) ! mass fraction SO4(aq)/SO4 + real(r8), intent(in) :: f_soa(pcols,pver) ! mass fraction SOA/(POM+SOA) + real(r8), intent(in) :: f_so4_cond(pcols,pver) ! mass fraction SO4_COND/(COND+COAG) + real(r8), intent(out) :: Cam(pcols,pver,nbmodes) ! modal internal mass, tot=SO4+BC+OC + real(r8), intent(out) :: fcm(pcols,pver,nbmodes) ! modal mass fraction (OC+BC)/tot + real(r8), intent(out) :: fbcm(pcols,pver,nbmodes) ! modal mass fraction BC/(OC+BC) + real(r8), intent(out) :: faqm(pcols,pver,nbmodes) ! modal mass fraction SO4(aq)/SO4 + real(r8), intent(out) :: fso4condm(pcols,pver,nbmodes) ! modal mass fraction (SO4(cond)/SO4(cond+coag)) + real(r8), intent(out) :: fsoam(pcols,pver,nbmodes) ! modal mass fraction SOA / (POM+SOA) + + ! + ! Local variables + real(r8) condensationSinkSO4(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode + real(r8) condensationSinkOA(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode + real(r8) coagulationSink(pcols,pver,nbmodes) ![1/s] loss rate of BC through coagulation on any mode + real(r8) aquousPhaseSink(pcols,pver,nbmodes) ![-] fraction of particles available for aq. phase in any mode + + real(r8) sumCondensationSinkSO4(pcols,pver) ![1/s] sum condensation sink to all modes + real(r8) sumCondensationSinkOA(pcols,pver) ![1/s] sum condensation sink to all modes + real(r8) sumCoagulationSink(pcols,pver) ![1/s] sum coagulation sink to all modes + real(r8) sumAquousPhaseSink(pcols,pver) ![1/s] sum aquous phase sink to all modes + + real(r8) fcondkSO4(pcols,pver,nbmodes) + real(r8) fcondkOA(pcols,pver,nbmodes) + real(r8) fcoagk(pcols,pver,nbmodes) + real(r8) faqk(pcols,pver,nbmodes) + + real(r8) cabck(pcols,pver,nbmodes) ![kg/m3] bc distributed to each mode + real(r8) caock(pcols,pver,nbmodes) ![kg/m3] pom coagulate distributed to each mode + real(r8) csoacondsk(pcols,pver,nbmodes) + real(r8) caqsk(pcols,pver,nbmodes) ![kg/m3] aq phase sulfate distributed to each mode + real(r8) cso4condsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode + real(r8) cso4coagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode + real(r8) cso4condcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode + real(r8) coccondcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode + + integer :: i !counter for modes + integer :: k !counter for levels + + !Find the sink on any mode (0 is omitted here, WHY??, it does receive matter in oslo_aero_coag/condtend!!)) + !Should either remove it from there or add something to it here! + do i=1,nbmodes + do k=1,pver + condensationSinkSO4(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_H2SO4)*Nnatkbg(:ncol,k,i) + condensationSinkOA(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_ORG_SV)*Nnatkbg(:ncol,k,i) + coagulationSink(:ncol,k,i) = normalizedCoagulationSink(i,MODE_IDX_BC_NUC)*Nnatkbg(:ncol,k,i) !use a typical coagulator (BC_NUC) + aquousPhaseSink(:ncol,k,i) = numberFractionAvailableAqChem(i)*Nnatkbg(:ncol,k,i) !aq phase sink to this mode + end do + enddo + + !Sum the sinks + sumCondensationSinkSO4(:,:) = 0.0_r8 + sumCondensationSinkOA(:,:) = 0.0_r8 + sumCoagulationSink(:,:) = 0.0_r8 + sumAquousPhaseSink(:,:) = 0.0_r8 + do i=1,nbmodes + do k=1,pver + sumCondensationSinkSO4(:ncol,k) = sumCondensationSinkSO4(:ncol,k) + condensationSinkSO4(:ncol,k,i) + sumCondensationSinkOA(:ncol,k) = sumCondensationSinkOA(:ncol,k) + condensationSinkOA(:ncol,k,i) + sumCoagulationSink(:ncol,k) = sumCoagulationSink(:ncol,k) + coagulationSink(:ncol,k,i) + sumAquousPhaseSink(:ncol,k) = sumAquousPhaseSink(:ncol,k) + aquousPhaseSink(:ncol,k,i) + end do + end do + + ! And finally the contribution from each mode relative to the totals are calculated, + ! assuming that the apportionment of mass for the first iteration (in time) is representative + ! for the whole apportionment process (which is ok for small and moderate masses added): + do i=1,nbmodes + do k=1,pver + !Get the fraction of contribution per process per mode + fcondkSO4(:ncol,k,i)=condensationSinkSO4(:ncol,k,i)/(sumCondensationSinkSO4(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode + fcondkOA(:ncol,k,i)=condensationSinkOA(:ncol,k,i)/(sumCondensationSinkOA(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode + fcoagk(:ncol,k,i)=coagulationSink(:ncol,k,i)/(sumCoagulationSink(:ncol,k)+1.e-100_r8) !fraction of coagulation sink in this mode + faqk(:ncol,k,i)=aquousPhaseSink(:ncol,k,i)/(sumAquousPhaseSink(:ncol,k)+1.e-100_r8) !fraction of aquous phase sink in this mode + + !BC coagulate to this mode [kg/m3] + cabck(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*f_bc(:ncol,k)*Ca(:ncol,k) + + !OC coagulate to this mode [kg/m3] + caock(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*(1.0_r8-f_soa(:ncol,k))*Ca(:ncol,k) + + !SOA condensate to this mode [kg/m3] + csoacondsk(:ncol,k,i) = fcondkOA(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*f_soa(:ncol,k)*Ca(:ncol,k) + + !Aquous phase SO4 to this mode [kg/m3] + caqsk(:ncol,k,i)=faqk(:ncol,k,i)*f_aq(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) + + !so4 condensate + cso4condsk(:ncol,k,i)=fcondkSO4(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*f_so4_cond(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) + + !soa coagulate + cso4coagsk(:ncol,k,i) = fcoagk(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*(1.0_r8-f_so4_cond(:ncol,k))*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) ![kg/m3] so4 coagulate + end do + enddo + + !The tables take as input the combined coagulate and condensate (both POM and SOA) + !The activation needs them separately for mass balance! + cso4condcoagsk(:ncol,:,:) = cso4condsk(:ncol,:,:) + cso4coagsk(:ncol,:,:) + coccondcoagsk(:ncol,:,:) = caock(:ncol,:,:) + csoacondsk(:ncol,:,:) + + do i=1,nbmodes + do k=1,pver + Cam(:ncol,k,i)= cabck(:ncol,k,i) & !BC + + coccondcoagsk(:ncol,k,i) & !OM + + caqsk(:ncol,k,i) + cso4condcoagsk(:ncol,k,i) + smallNumber!SO4 ==> !total process mode mass to mode i + + fcm(:ncol,k,i)=(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i))/(Cam(:ncol,k,i)+smallNumber) !fraction of mass being carbon (oc or bc) + fbcm(:ncol,k,i)=cabck(:ncol,k,i)/(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i)+smallNumber) !fraction of carbon mass being bc + faqm(:ncol,k,i)=caqsk(:ncol,k,i)/(caqsk(:ncol,k,i)+cso4condcoagsk(:ncol,k,i)+smallNumber) !fraction of sulfate being aq phase + + !Not needed for tables, but for mass balances in activation + fso4condm(:ncol,k,i) = cso4condsk(:ncol,k,i)/(cso4condcoagsk(:ncol,k,i) + smallNumber) !fraction of cond+coag which is coag + fsoam(:ncol,k,i) = csoacondsk(:ncol,k,i)/(coccondcoagsk(:ncol,k,i) + smallNumber) !fraction of OC which is SOA + end do + enddo + + end subroutine modalapp2d + +end module oslo_aero_conc diff --git a/src/chemistry/oslo_aero/pmxsub.F90 b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 similarity index 95% rename from src/chemistry/oslo_aero/pmxsub.F90 rename to src/chemistry/oslo_aero/oslo_aero_optical_params.F90 index 16e1808ffa..26f7e9b43a 100644 --- a/src/chemistry/oslo_aero/pmxsub.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 @@ -1,34 +1,38 @@ -module pmxsub_mod +module oslo_aero_optical_params + + ! Optical parameters for a composite aerosol is calculated by interpolation + ! from the tables kcomp1.out-kcomp14.out. + + use ppgrid + use shr_kind_mod, only: r8 => shr_kind_r8 + use cam_history, only: outfld + use constituents, only: pcnst + use physconst, only: rair,pi + use physics_types, only: physics_state + use wv_saturation, only: qsat_water + ! + use oslo_utils, only: calculateNumberConcentration + use oslo_aero_conc, only: calculateBulkProperties, partitionMass + use commondefinitions + use const + use aerosoldef + use oslo_aero_sw_tables implicit none + private + + public :: oslo_aero_optical_params_calc !=============================================================================== contains !=============================================================================== - subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, & - volc_ext_earth, volc_omega_earth, & + subroutine oslo_aero_optical_params_calc(lchnk, ncol, pint, pmid, & + coszrs, state, t, cld, qm1, Nnatk, & + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & + volc_ext_sun, volc_omega_sun, volc_g_sun, volc_ext_earth, volc_omega_earth, & aodvis, absvis) - ! Optical parameters for a composite aerosol is calculated by interpolation - ! from the tables kcomp1.out-kcomp14.out. - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_history, only: outfld - use constituents, only: pcnst - use physconst, only: rair,pi - use oslo_utils, only: calculateNumberConcentration - use parmix_progncdnc, only: calculateBulkProperties, partitionMass - use opttab - use const - use aerosoldef - use commondefinitions - use physics_types, only: physics_state - use wv_saturation, only: qsat_water - ! Input arguments integer , intent(in) :: lchnk ! chunk identifier integer , intent(in) :: ncol ! number of atmospheric columns @@ -115,8 +119,8 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & !------------------------------------------------------------------------- ! calculate relative humidity for table lookup into rh grid - call qsat_water(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), & - es(1:ncol,1:pver), qs(1:ncol,1:pver)) + call qsat_water(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), es(1:ncol,1:pver), qs(1:ncol,1:pver)) + rht(1:ncol,1:pver) = state%q(1:ncol,1:pver,1) / qs(1:ncol,1:pver) rh_temp(1:ncol,1:pver) = min(rht(1:ncol,1:pver),1._r8) @@ -518,6 +522,9 @@ subroutine pmxsub(lchnk, ncol, pint, pmid, coszrs, state, t, cld, qm1, Nnatk, & call outfld('ABSVVOLC',absvisvolc ,pcols,lchnk) call outfld('BVISVOLC',bevisvolc ,pcols,lchnk) - end subroutine pmxsub + end subroutine oslo_aero_optical_params_calc + + + -end module pmxsub_mod +end module oslo_aero_optical_params diff --git a/src/chemistry/oslo_aero/opttab.F90 b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 similarity index 98% rename from src/chemistry/oslo_aero/opttab.F90 rename to src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 index 951daef355..218e2e0662 100644 --- a/src/chemistry/oslo_aero/opttab.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 @@ -1,4 +1,4 @@ -module opttab +module oslo_aero_sw_tables ! Purpose: To read in SW look-up tables for calculation of aerosol optical properties, ! and to define the grid for discrete input-values in these look-up tables. @@ -114,11 +114,6 @@ module opttab subroutine initopt() !--------------------------------------------------------------- - ! Modified by Egil Storen/NoSerC July 2002. - ! The sequence of the indices in arrays om1, g1, be1 and ke1 - ! (common block /tab1/) has been rearranged to avoid cache - ! problems while running subroutine interpol1. Files also - ! involved by this modification: interpol1.F and opttab.h. ! Modified for new aerosol schemes by Alf Kirkevaag in January ! 2006. Modified for new wavelength bands and look-up tables ! by Alf Kirkevaag in December 2013, and for SOA in August 2015. @@ -548,23 +543,18 @@ end subroutine initopt subroutine initopt_lw !--------------------------------------------------------------- - ! Modified by Egil Storen/NoSerC July 2002. - ! The sequence of the indices in arrays om1, g1, be1 and ke1 - ! (common block /tab1/) has been rearranged to avoid cache - ! problems while running subroutine interpol1. Files also - ! involved by this modification: interpol1.F and opttab.h. ! Modified for new aerosol schemes by Alf Kirkevaag in January - ! 2006. Based on opttab.F90 and modified for new wavelength + ! 2006. Modified for new wavelength ! bands and look-up tables by Alf Kirkevaag in January 2014, ! and for SOA in August 2015. !--------------------------------------------------------------- - integer kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq - integer ifombg, ifbcbg - integer ic, ifil, lin, linmax - real(r8) catot, relh, frac, fabc, fraq, frombg, frbcbg - real(r8) spabs - real(r8) rh2(10) + integer :: kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq + integer :: ifombg, ifbcbg + integer :: ic, ifil, lin, linmax + real(r8) :: catot, relh, frac, fabc, fraq, frombg, frbcbg + real(r8) :: spabs + real(r8) :: rh2(10) real(r8) :: eps2 = 1.e-2_r8 real(r8) :: eps3 = 1.e-3_r8 real(r8) :: eps4 = 1.e-4_r8 @@ -574,28 +564,17 @@ subroutine initopt_lw call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) - open(40,file=trim(aerotab_table_dir)//'/lwkcomp1.out' & - ,form="formatted",status="old") - open(41,file=trim(aerotab_table_dir)//'/lwkcomp2.out' & - ,form="formatted",status="old") - open(42,file=trim(aerotab_table_dir)//'/lwkcomp3.out' & - ,form="formatted",status="old") - open(43,file=trim(aerotab_table_dir)//'/lwkcomp4.out' & - ,form="formatted",status="old") - open(44,file=trim(aerotab_table_dir)//'/lwkcomp5.out' & - ,form="formatted",status="old") - open(45,file=trim(aerotab_table_dir)//'/lwkcomp6.out' & - ,form="formatted",status="old") - open(46,file=trim(aerotab_table_dir)//'/lwkcomp7.out' & - ,form="formatted",status="old") - open(47,file=trim(aerotab_table_dir)//'/lwkcomp8.out' & - ,form="formatted",status="old") - open(48,file=trim(aerotab_table_dir)//'/lwkcomp9.out' & - ,form="formatted",status="old") - open(49,file=trim(aerotab_table_dir)//'/lwkcomp10.out'& - ,form="formatted",status="old") - open(50,file=trim(aerotab_table_dir)//'/lwkcomp0.out'& - ,form="formatted",status="old") + open(40,file=trim(aerotab_table_dir)//'/lwkcomp1.out' ,form="formatted",status="old") + open(41,file=trim(aerotab_table_dir)//'/lwkcomp2.out' ,form="formatted",status="old") + open(42,file=trim(aerotab_table_dir)//'/lwkcomp3.out' ,form="formatted",status="old") + open(43,file=trim(aerotab_table_dir)//'/lwkcomp4.out' ,form="formatted",status="old") + open(44,file=trim(aerotab_table_dir)//'/lwkcomp5.out' ,form="formatted",status="old") + open(45,file=trim(aerotab_table_dir)//'/lwkcomp6.out' ,form="formatted",status="old") + open(46,file=trim(aerotab_table_dir)//'/lwkcomp7.out' ,form="formatted",status="old") + open(47,file=trim(aerotab_table_dir)//'/lwkcomp8.out' ,form="formatted",status="old") + open(48,file=trim(aerotab_table_dir)//'/lwkcomp9.out' ,form="formatted",status="old") + open(49,file=trim(aerotab_table_dir)//'/lwkcomp10.out' ,form="formatted",status="old") + open(50,file=trim(aerotab_table_dir)//'/lwkcomp0.out' ,form="formatted",status="old") ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) do ifil = 40,50 @@ -611,13 +590,8 @@ subroutine initopt_lw ifil = 11 linmax=nlwbands do lin = 1,linmax - read(39+ifil,996) kcomp, iwl, relh, spabs - ka0(iwl)=spabs ! unit m^2/g - - ! write(*,*) 'kcomp, ka =', kcomp, ka0(iwl) - end do do iwl=1,nlwbands @@ -627,10 +601,8 @@ subroutine initopt_lw stop endif enddo - write(iulog,*)'lw mode 0 ok' - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc ! Mode 1 (H2SO4 + condesate from H2SO4 and SOA) !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc @@ -735,10 +707,6 @@ subroutine initopt_lw ka2to3(iwl,irelh,ictot,ifac,kcomp)=spabs ! unit m^2/g - ! write(*,*) 'kcomp, ka =', kcomp, ka2to3(iwl,irelh,ictot,ifac,kcomp) - ! if(ifil==2) write(iulog,*) 'iwl,irelh,ictot,ifac,kcomp,ka =', & - ! iwl,irelh,ictot,kcomp,ka2to3(iwl,irelh,ictot,ifac,kcomp) - end do ! lin end do ! ifil @@ -984,14 +952,12 @@ subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & real(r8) :: eps10 = 1.e-10_r8 !------------------------------------------------------------------------ ! - ! write(*,*) 'Before xrh-loop' do k=1,pver do icol=1,ncol xrh(icol,k) = min(max(rhum(icol,k),rh(1)),rh(10)) end do end do - ! write(*,*) 'Before rh-loop' do irelh=1,9 do k=1,pver do icol=1,ncol @@ -1001,7 +967,6 @@ subroutine inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & end do end do end do - ! write(*,*) 'xrh, irh1, irh2 =', xrh(1,26), irh1(1,26), irh2(1,26) do k=1,pver do icol=1,ncol @@ -2800,4 +2765,4 @@ subroutine checkTableHeader (ifil) enddo end subroutine checkTableHeader -end module opttab +end module oslo_aero_sw_tables diff --git a/src/chemistry/oslo_aero/parmix_progncdnc.F90 b/src/chemistry/oslo_aero/parmix_progncdnc.F90 deleted file mode 100644 index bb0f847f5b..0000000000 --- a/src/chemistry/oslo_aero/parmix_progncdnc.F90 +++ /dev/null @@ -1,979 +0,0 @@ -module parmix_progncdnc - - use const , only : volumeToNumber,smallNumber - use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o - use ppgrid , only : pcols, pver - use shr_kind_mod , only: r8 => shr_kind_r8 - use commondefinitions - use aerosoldef - use physconst , only: pi - use constituents , only: pcnst, cnst_name - use intlog , only : intlog1to3_sub, intlog4_sub, intlog5to10_sub - use constituents , only: cnst_name - - implicit none - public - - !Size of molecule-layer which defines when particles are coated - real(r8), parameter :: coatingLimit = 2.e-9_r8 ![m] - - !The fraction of soluble material required in a components before it - !will add to any coating - real(r8), parameter :: solubleMassFractionCoatingLimit=0.50_r8 - - real(r8), parameter :: aThird = 1.0_r8/3.0_r8 - real(r8), parameter :: ln10 = log(10.0_r8) - -contains - - !Calculate concentrations of aerosol modes based on lifecycle species - !Create an array of "mode_definition_t" which holds the aerosol concentrations - subroutine parmix_progncdnc_sub( & - ncol & !I [nbr] number of columns used - ,mmr & !I [kg/kg] mass mixing ratio of tracers - ,rho_air & !I [kg/m3] air density - ,CProcessModes & - ,f_c & - ,f_bc & - ,f_aq & - ,f_so4_cond & - ,f_soa & - ,cam & - ,f_acm & !O [frc] carbon fraction in mode - ,f_bcm & !O [frc] fraction of c being bc - ,f_aqm & !O [frc] fraction of sulfate being aquous - ,f_so4_condm & !O [frc] fraction of non-aquous SO4 being condensate - ,f_soam & - ,numberConcentration & !O [#/m3] number concentration - ,volumeConcentration & !O [m3/m3] volume concentration - ,hygroscopicity & !O [mol/mol] - ,lnsigma & !O [-] log sigma - ,hasAerosol & !I [t/f] do we have this type of aerosol here? - ,volumeCore & - ,volumeCoat & - ) - - !input - integer, intent(in) :: ncol !Number of columns used in chunk - real(r8), intent(in) :: mmr(pcols,pver,pcnst) - real(r8), intent(in) :: rho_air(pcols,pver) - - !output - logical, intent(out) :: hasAerosol(pcols, pver, nmodes) - real(r8), intent(out) :: f_acm(pcols,pver, nbmodes) - real(r8), intent(out) :: f_bcm(pcols,pver, nbmodes) - real(r8), intent(out) :: f_aqm(pcols, pver, nbmodes) - real(r8), intent(out) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction" - real(r8), intent(out) :: f_soam(pcols, pver, nbmodes) !Needed in "get component fraction" - real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton - real(r8), intent(out) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration - real(r8), intent(out) :: hygroscopicity(pcols,pver,nmodes) ![mol_{aer}/mol_{water}] hygroscopicity - real(r8), intent(out) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma - real(r8),intent(out) :: CProcessModes(pcols,pver) - real(r8),intent(out) :: cam(pcols,pver,nbmodes) - real(r8),intent(out) :: f_c(pcols, pver) - real(r8),intent(out) :: f_aq(pcols,pver) - real(r8),intent(out) :: f_bc(pcols,pver) - real(r8),intent(out) :: f_so4_cond(pcols,pver) - real(r8),intent(out) :: f_soa(pcols,pver) - real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) - real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) - - real(r8) :: f_aitbc(pcols,pver) ! [-] bc fraction in the coated bc-oc mode - real(r8) :: f_nbc(pcols,pver) ! [-] mass fraction of bc in uncoated bc/oc mode - real(r8) :: f_soana(pcols,pver) ! [-] - - !Get mass, number concentration and the total add-ons (previous convaer) - call calculateBulkProperties( & - ncol & !I - , mmr & !I - , rho_air & !I - , numberConcentration & !O - , CProcessModes & !O - , f_c & !O - , f_bc & !O - , f_aq & !O - , f_so4_cond & !O - , f_soa & !O - , f_aitbc & !O - , f_nbc & !O - , f_soana & !O - ) - - !Find the points where we have aerosol (number concentration) - call getAerosolMask(ncol, numberConcentration, hasAerosol) - - !Findn out how much is added per size-mode (modalapp) - call partitionMass( ncol & - ,numberConcentration & - ,CProcessModes & !I [kg/m3] total added mass - ,f_c & !I [frc] fraction of added mass being c - ,f_bc & !I [frc] fraction of c being bc - ,f_aq & !I [frc] fraction of SO4 being aq - ,f_so4_cond & !I [frc] fraction of SO4 coag+cond being cond - ,f_soa & !I [frc] fraction of OM being SOA - ,cam & !O [kg/m3] added mass distributed to modes - ,f_acm & !O [frc] as f_c per mode - ,f_bcm & !O [frc] as f_bc per mode - ,f_aqm & !O [frc] as f_aq per mode - ,f_so4_condm & !O [frc] as f_so4_cond per mode - ,f_soam & !O [frc] - ) - - !Calculate they hygroscopicity (previously in cldwat_par.F90) - call calculateHygroscopicity( ncol & - ,mmr & - ,numberConcentration & - ,rho_air & - ,Cam & - ,f_acm & - ,f_bcm & - ,f_aqm & - ,hasAerosol & - ,hygroscopicity & - ,volumeConcentration & - ,volumeCore & - ,volumeCoat & - ) - - !Do the interpolation to new modes - call doLognormalInterpolation(ncol & - ,numberConcentration & - ,hasAerosol & - ,cam & - ,volumeConcentration & - ,f_c & - ,f_acm & - ,f_bcm & - ,f_aqm & - ,f_aitbc & !I [frc] bc fraction in int mix bc/oc mode - ,lnSigma & - ) - - end subroutine parmix_progncdnc_sub - - !****************************************************************** - !purpose: Create bulk properties (dependent on tracers, not size modes) - subroutine calculateBulkProperties( & - ncol & - ,qm & !I [kg/kg] transported tracers - ,rho_air & !I [kg/m3] air density - ,numberConcentration & !O [#/m3] aerosol number concentration - ,CProcessModes & !O [kg/m3] total added material - ,f_c & !O [-] fraction of aerosol which is carbon - ,f_bc & !O [-] fraction of carbon which is bc - ,f_aq & !O [-] fraction of sulfate which is aq. - ,f_so4_cond & !O [-] fraction of non-aq so4 which is condensate - ,f_soa & !O [-] fraction of OM which is SOA - ,f_aitbc & !O [-] fraction of bc in the background tracer mode - ,f_nbc & !O [-] fraction of bc in the background tracer mode 14 - ,f_soana & !O [-] fraction of soa in background int-mix mode (1) - ) - - use shr_kind_mod, only: r8 => shr_kind_r8 - use aerosoldef - use oslo_utils, only : calculateNumberConcentration - use const, only : smallNumber - - implicit none - - integer, intent(in) :: ncol ! [nbr] number of columns used - real(r8), intent(in) :: rho_air(pcols,pver) ! [kg/m3] air density - real(r8), intent(in) :: qm(pcols,pver,pcnst) ! [kg/kg] mmr for transported tracers - - real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ! [#/m3] - - real(r8), intent(out) :: f_c(pcols,pver) ![-] mass fraction of process mode being c - real(r8), intent(out) :: f_bc(pcols,pver) ![-] mass fraction of c being bc - real(r8), intent(out) :: f_aq(pcols,pver) ![-] mass fraction of s being aq phase - real(r8), intent(out) :: f_so4_cond(pcols,pver) ![-] mass fraction of non-aq s being condensate - real(r8), intent(out) :: f_soa(pcols,pver) ![-] mass fraction of OM being SOA - real(r8), intent(out) :: f_aitbc(pcols,pver) ![-] mass fraction of bc in bc/oc mixed, coated mode - real(r8), intent(out) :: f_nbc(pcols,pver) ![-] mass fraction of bc in bc/oc mixed, un-coated mode - real(r8), intent(out) :: f_soana(pcols,pver) ![-] mass fraction of soa in background in int mix ait mode (1) - !Local variables - real(r8) :: totalProcessModes(pcols,pver) ! [kg/kg] Int. mixed (cond./coag./aq.) SO4+BC+OC concentration - real(r8) :: CProcessModes(pcols,pver) ! [kg/m3] Int. mixed (cond./coag./aq.) SO4+BC+OC concentration - - integer :: k !counter for layers - - !Total number concentration per mode - call calculateNumberConcentration(ncol, qm, rho_air, numberConcentration) - - do k=1,pver - - !Total coagulated bc and oc and SO4 (condensate, wet phase and coagulated) (kg/kg) - !internally mixed with background modes - totalProcessModes(:ncol,k) = qm(:ncol,k,l_bc_ac) + qm(:ncol,k,l_om_ac) & - + qm(:ncol,k,l_so4_a1) + qm(:ncol,k,l_so4_a2) + qm(:ncol,k,l_so4_ac) + qm(:ncol,k,l_soa_a1) - - CProcessModes(:ncol,k) = rho_air(:ncol,k)*totalProcessModes(:ncol,k) !==> kg/m3 - - !fraction of process-mode being carbonaceous - f_c(:ncol,k) = min((qm(:ncol,k,l_bc_ac)+qm(:ncol,k,l_om_ac)+qm(:ncol,k,l_soa_a1) )& - /(totalProcessModes(:ncol,k)+smallNumber), 1.0_r8) - - !fraction of "c" being bc (total is oc and bc) - f_bc(:ncol,k) = min(qm(:ncol,k,l_bc_ac)/(qm(:ncol,k,l_bc_ac)+qm(:ncol,k,l_om_ac)+qm(:ncol,k,l_soa_a1)+smallNumber), 1.0_r8) - - !fraction of non-aqeous phase sulphate being condensate - f_so4_cond(:ncol,k) = min(qm(:ncol,k,l_so4_a1)/(qm(:ncol,k,l_so4_a1)+qm(:ncol,k,l_so4_ac)+smallNumber), 1.0_r8) - - !fraction of sulphate being aquous phase (total is condensate + aqeous phase + coagulate) - f_aq(:ncol,k) = min(qm(:ncol,k,l_so4_a2) & - /(qm(:ncol,k,l_so4_a1)+qm(:ncol,k,l_so4_a2)+qm(:ncol,k,l_so4_ac)+smallNumber),1.0_r8) - - !fraction of bc in the sulfate-coated bc/oc mode (total background is bc and oc) - f_aitbc(:ncol,k) = min(qm(:ncol,k,l_bc_ai) / (qm(:ncol,k,l_bc_ai) + qm(:ncol,k,l_om_ai) + smallNumber), 1.0_r8) - - !fraction of bc in the un-coated bc/oc (total is bc and oc) - f_nbc(:ncol,k) = min(qm(:ncol,k,l_bc_ni) / (qm(:ncol,k,l_bc_ni) + qm(:ncol,k,l_om_ni) + smallNumber),1.0_r8) - - !fraction of OM process-mode which is SOA - f_soa(:ncol,k) = min(qm(:ncol,k,l_soa_a1) / (qm(:ncol,k,l_om_ac) + qm(:ncol,k,l_soa_a1) + smallNumber), 1.0_r8) - - !fraction of "background" int-mix (mode 1) which is SOA - f_soana(:ncol,k) = min(qm(:ncol,k,l_soa_na) / (qm(:ncol,k,l_soa_na) + qm(:ncol,k,l_so4_na) + smallNumber), 1.0_r8 ) - - end do !k - - return - end subroutine calculateBulkProperties - - !******************************************************************************** - subroutine partitionMass( ncol & !I [nbr] number of columns used - ,Nnatk & !I [#/m3] number concentration - ,CProcessModes & !I [kg/m3] total added mass - ,f_c & !I [frc] fraction of added mass being c - ,f_bc & !I [frc] fraction of c being bc - ,f_aq & !I [frc] fraction of SO4 being aq - ,f_so4_cond & !I [frc] fraction of SO4 coag+cond being cond - ,f_soa & !I [frc] fraction of OM being SOA - ,cam & !O [kg/m3] added mass distributed to modes - ,f_acm & !O [frc] as f_c per mode - ,f_bcm & !O [frc] as f_bc per mode - ,f_aqm & !O [frc] as f_aq per mode - ,f_so4_condm & !O [frc] fraction of non aq sulfate being coagulate - ,f_soam & !O [frc] fraction of OC being SOA - ) - - implicit none - - integer, intent(in) :: ncol - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) - real(r8), intent(in) :: CProcessModes(pcols,pver) - real(r8), intent(in) :: f_c(pcols,pver) - real(r8), intent(in) :: f_bc(pcols,pver) - real(r8), intent(in) :: f_aq(pcols,pver) - real(r8), intent(in) :: f_so4_cond(pcols,pver) - real(r8), intent(in) :: f_soa(pcols,pver) - real(r8), intent(out) :: f_aqm(pcols,pver,nbmodes) - real(r8), intent(out) :: f_acm(pcols,pver,nbmodes) - real(r8), intent(out) :: f_bcm(pcols,pver,nbmodes) - real(r8), intent(out) :: f_so4_condm(pcols,pver,nbmodes) - real(r8), intent(out) :: f_soam(pcols,pver,nbmodes) - real(r8), intent(out) :: cam(pcols, pver, nbmodes) - - !Budget of condensate SO4 - integer :: i - - !++test - integer :: k,l,lptr,m,m1,kcomp - real(r8) :: total - real(r8) :: fraction(pcols,pver,pcnst) !ak: oversized, but only for test use - !--test - - call modalapp2d_sub(ncol & - ,Nnatk(1,1,1) & !I [#/m3] Total number concentration (skip mode 0) - ,CProcessModes & !I [kg/m3] Total process mode mass concentration - ,f_c & !I [frc] fraction of process mode mass being oc or bc - ,f_bc & !I [frc] fraction of coagulate mass being bc - ,f_aq & !I [frc] fraction of process mode sulfate mass being aq - ,f_so4_cond & - ,f_soa & - ,cam & !O [kg/m3] Process mode mass distributed to each mode - ,f_acm & !O [frc] as f_c, for each mode - ,f_bcm & !O [frc] as f_bc, for each mode - ,f_aqm & !O [frc] as f_aq, for each mode - ,f_so4_condm & !O [frc] - ,f_soam & - ) - - end subroutine partitionMass - - !************************************************************* - !Find out where we have aerosols - subroutine getAerosolMask(ncol,numberConcentration, hasAerosol) - implicit none - - integer, intent(in) :: ncol !number of columns used - real(r8), intent(in) :: numberConcentration(pcols, pver, 0:nmodes) - logical, intent(out) :: hasAerosol(pcols, pver, nmodes) - integer :: k !counter for levels - integer :: m !counter for modes - - do m=1,nmodes - do k=1,pver - where(numberConcentration(:ncol,k,m) .gt. smallNumber) - hasAerosol(:ncol,k,m)= .true. - elsewhere - hasAerosol(:ncol,k,m) = .false. - end where - end do !levels - end do !modes - end subroutine - !************************************************************* - - - !************************************************************** - subroutine calculateHygroscopicity( ncol & - ,mmr & - ,numberConcentration & - ,rho_air & - ,Cam & - ,f_acm & - ,f_bcm & - ,f_aqm & - ,hasAerosol & - ,hygroscopicity & - ,volumeConcentration & - ,volumeCore & - ,volumeCoat & - ) - - !All theory in this subroutine is from - !Abdul-Razzak and S. Ghan: - !A parameterization of aerosol activation 2. Multiple aerosol types, JGR, vol 105, noD5, pp 6837 - !http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract - implicit none - - !INPUT - integer, intent(in) :: ncol - real(r8), intent(in) :: mmr(pcols,pver,pcnst) !I [kg/kg] mass mixing ratios - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes)!I [#/m3] number concentrations - real(r8), intent(in) :: rho_air(pcols,pver) !I [kg/m3] air density - real(r8), intent(in) :: Cam(pcols, pver, nbmodes) !I [kg/m3] total added mass during microphysics - real(r8), intent(in) :: f_acm(pcols,pver,nbmodes) !I [-] fraction of added mass which is carbon - real(r8), intent(in) :: f_aqm(pcols,pver,nbmodes) !I [-] fraction of sulfate which is aq. phase - real(r8), intent(in) :: f_bcm(pcols,pver,nbmodes) !I [-] fraction of C which is bc - logical, intent(in) :: hasAerosol(pcols,pver,nmodes) !I [t/f] do we have aerosols - - !OUTPUT - real(r8), intent(out) :: hygroscopicity(pcols,pver,nmodes) - real(r8), intent(out) :: volumeConcentration(pcols,pver,nmodes) - - !Local variables - real(r8) :: hygroscopicityAvg(pcols,pver) - real(r8) :: hygroscopicityCoat(pcols,pver) - real(r8) :: massConcentrationTracerInMode(pcols,pver) - real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) ![m3] - real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) ![m3] - real(r8) :: averageRadiusCore(pcols,pver) ![m] - real(r8) :: averageRadiusTotal(pcols,pver) ![m] - integer :: kcomp !counter for modes - integer :: l !counter for components - integer :: tracerIndex - integer :: k !counter for levels - integer :: i - - !initialize - hygroscopicity(:,:,:) = 0.0_r8 - volumeConcentration(:,:,:)=0.0_r8 - - do kcomp=1,nmodes - - !Don't do anything if no tracers in mode - if(getNumberOfBackgroundTracersInMode(kcomp) .lt. 1)then - volumeCore(:,:,kcomp)=smallNumber - volumeCoat(:,:,kcomp)=smallNumber - volumeConcentration(:,:,kcomp)=smallNumber - hygroscopicity(:,:,kcomp) = smallNumber - cycle - end if - - hygroscopicityAvg(:,:) = 0.0_r8 - hygroscopicityCoat(:,:) = 0.0_r8 - volumeCore(:,:,kcomp) = 0.0_r8 - volumeCoat(:,:,kcomp) = 0.0_r8 - - !Loop over tracers in mode - do l=1,getNumberOfBackgroundTracersInMode(kcomp) - - tracerIndex = getTracerIndex(kcomp,l,.false.) !get index in physcis space - - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = mmr(:ncol,k,tracerIndex)*rho_air(:ncol,k) - end do - - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , tracerIndex & - ) - end do !background tracers in mode (l) - - !The background modes can have tracer mass added to them - if(kcomp .le. nbmodes)then - - !added aquous sulfate - if(isTracerInMode(kcomp,l_so4_a2))then - - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*f_aqm(:ncol,k,kcomp) - end do - - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , l_so4_a2 & - ) - endif - - !added condensate/coagulate - !All modes which have coagulate have also condensate, so it is - !ok to check for condensate and add the combined mass.. - if(isTracerInMode(kcomp,l_so4_a1))then - - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*(1.0_r8 - f_aqm(:ncol,k,kcomp)) - end do - - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , l_so4_a1 & - ) - endif - !Added bc - if(isTracerInMode(kcomp,l_bc_ac))then - - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*f_bcm(:ncol,k,kcomp) - end do - - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , l_bc_ac & - ) - endif - - !Added oc (both POM and SOA), then both have the same - !properties, so add combined mass here. - !All modes which have condensate also has coagulate, so OK to check - !for condensate and distribute the sum.. - if(isTracerInMode(kcomp,l_soa_a1))then - - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*(1.0_r8 -f_bcm(:ncol,k,kcomp)) - end do - - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , l_om_ac & - ) - endif - end if - - !Note: NCAR definitions of molecular weights are kg/kmol. This is used - !inside "addModeHygroscopicity" and here as in molecularWeightWater. SI units are kg/mol, but - !the error cancels out since eqn 4 has Mw_water/Mw_tracer - - do k=1,pver - - !Finally, when the sums are calculated, Apply finally eqn 4 here!! - - where (hasAerosol(:ncol,k,kcomp)) - where(VolumeCoat(:ncol,k,kcomp) .gt. 1.e-30_r8) - !If there is enough soluble material, a coating will be formed: In that case, the - !volume of the aerosol in question is only the volume of the coating! - hygroscopicityCoat(:ncol,k) = molecularWeightWater*hygroscopicityCoat(:ncol,k) & - & /( density_water * volumeCoat(:ncol,k,kcomp)) !Note use of volume Coating here - elsewhere - hygroscopicityCoat(:ncol,k) = 1.e-30_r8 - endwhere - !mode total volume: - volumeConcentration(:ncol,k,kcomp) = volumeCore(:ncol,k,kcomp) + volumeCoat(:ncol,k,kcomp) - - !hygroscopicity of mixture (Note use of total volume to get average hygroscopicity) - hygroscopicityAvg(:ncol,k) = molecularWeightWater*hygroscopicityAvg(:ncol,k) & - & /(density_water * volumeConcentration(:ncol,k,kcomp)) - - - !Average size of insoluble core (average radius) - averageRadiusCore(:ncol,k) = 0.5_r8*( (volumeCore(:ncol,k,kcomp)) / numberConcentration(:ncol,k,kcomp) * (6.0_r8/pi))**athird - - !Average size of total aerosol (average radius) - averageRadiusTotal(:ncol,k) = 0.5_r8*((volumeConcentration(:ncol,k,kcomp)) / numberConcentration(:ncol,k,kcomp)*(6.0_r8/pi))**athird - - !do i=1,ncol - ! if(numberConcentration(i,k,kcomp) .gt. 1.e6 .and. kcomp.eq.6 )then - ! print*, "hygro_check",kcomp,numberConcentration(i,k,kcomp), averageRadiusTotal(i,k)*1.e6, averageRadiusCore(i,k)*1.e6 & - ! , hygroscopicityCoat(i,k), hygroscopicityAvg(i,k), (averageRadiusTotal(i,k)-averageRadiusCore(i,k))*1.e9 - ! endif - !end do - - !use one or the other hygroscopicity based on coating - where ( averageRadiusTotal(:ncol,k) - averageRadiusCore(:ncol,k) .gt. coatingLimit ) - hygroscopicity(:ncol,k,kcomp) = hygroscopicityCoat(:ncol,k) - elsewhere - hygroscopicity(:ncol,k,kcomp) = hygroscopicityAvg(:ncol,k) - endwhere - elsewhere ! No aerosol - hygroscopicity(:ncol,k,kcomp) = 1.e-10_r8 - end where - - end do !levels - - end do !kcomp /modes - - end subroutine calculateHygroscopicity - - !************************************************************************************** - subroutine addModeHygroscopicity ( ncol & ![nbr] number of columns used - , hasAerosol & ![bool] do we have any aerosol here? - , massConcentrationTracerInMode & ![kg/m3] mass concentration of aerosol in a mode - , volumeCore & ![m3/m3] volume concentration we are adding - , volumeCoat & ![m3/m3] volume concentration we are adding - , hygroscopicityAvg & ![mol_{aerosol}/mol_{tracer} hygroscopicity - , hygroscopicityCoat & ![mol_{aerosol}/mol_{tracer} hygroscopicity coating - , tracerIndex & ![idx] which tracer are we talking about (physics space) - ) - - implicit none - - integer, intent(in) :: ncol - real(r8), intent(in) :: massConcentrationTracerInMode(pcols,pver) ![kg/m3] mass concentration in - logical, intent(in) :: hasAerosol(pcols,pver) ![bool] true if we have any aerosol here - integer, intent(in) :: tracerIndex !in physics space - - real(r8), intent(inout) :: volumeCore(pcols, pver) !O [m3/m3] volume of insoluble core - real(r8), intent(inout) :: volumeCoat(pcols, pver) !O [m3/m3] volume of total aerosol - real(r8), intent(inout) :: hygroscopicityAvg(pcols, pver) !O [-] average hygroscopicity - real(r8), intent(inout) :: hygroscopicityCoat(pcols, pver) !O [-] average hygroscopicity - - real(r8) :: massFractionInCoating - - integer :: k !counter for levels - - !Only tracers more soluble than 20% can add to the coating volume - if(solubleMassFraction(tracerIndex) .gt. solubleMassFractionCoatingLimit)then - massFractionInCoating = 1.0_r8 !all volume goes to coating - else - massFractionInCoating = 0.0_r8 !zero volume goes to coating - endif - - do k=1,pver - - where(hasAerosol(:ncol,k) .eqv. .true.) - - volumeCore(:ncol,k) = volumeCore(:ncol,k) & - + massConcentrationTracerInMode(:ncol,k)/rhopart(tracerIndex)*(1.0_r8 - massFractionInCoating) - - volumeCoat(:ncol,k) = volumeCoat(:ncol,k) + massConcentrationTracerInMode(:ncol,k)/rhopart(tracerIndex)*massFractionInCoating - - !sum up numerator in eqn 4 in Abdul-Razzak et al (average hygrocopicity) - !Note that molecular weight is that of the AEROSOL TYPE - !This is because of some conflict with mozart which needs molecular weight of OC tracers to be 12 when reading emissions - !So molecular weight is duplicated, and the molecular weight of the TYPE is used here! - hygroscopicityAvg(:ncol,k) = hygroscopicityAvg(:ncol,k) + & - massConcentrationTracerInMode(:ncol,k)*numberOfIons(tracerIndex)*osmoticCoefficient(tracerIndex) & - *solubleMassFraction(tracerIndex)/aerosol_type_molecular_weight(aerosolType(tracerIndex)) - - !Contribution to hygroscopicity of coating (only if goes to coating) - !sum up numerator in eqn 4 in Abdul-Razzak et al (average hygrocopicity) - !Note that molecular weight is that of the AEROSOL TYPE - !This is because of some conflict with mozart which needs molecular weight of OC tracers to be 12 when reading emissions - !So molecular weight is duplicated, and the molecular weight of the TYPE is used here! - hygroscopicityCoat(:ncol,k) = hygroscopicityCoat(:ncol,k) + & - massConcentrationTracerInMode(:ncol,k)*numberOfIons(tracerIndex)*osmoticCoefficient(tracerIndex) & - *solubleMassFraction(tracerIndex)/aerosol_type_molecular_weight(aerosolType(tracerIndex)) & - *massFractionInCoating !Only add to this if mass goes to coating - - elsewhere - hygroscopicityAvg(:ncol,k) = 1.0e-10_r8 - hygroscopicityCoat(:ncol,k)= 1.0e-10_r8 - end where - - end do - - end subroutine addModeHygroscopicity - - !**************************************************************** - - subroutine doLognormalInterpolation(ncol & - ,numberConcentration & - ,hasAerosol & - ,cam & - ,volumeConcentration & - ,f_c & - ,f_acm & - ,f_bcm & - ,f_aqm & - ,f_aitbc & - ,lnSigma & - ) - - implicit none - - !input - integer, intent(in) :: ncol - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) - logical, intent(in) :: hasAerosol(pcols,pver,nmodes) - real(r8), intent(in) :: cam(pcols,pver,nbmodes) ![kg/m3] total added mass per mode - real(r8), intent(in) :: f_c(pcols,pver) ![frc] fraction of carbon in total add-on - real(r8), intent(in) :: f_acm(pcols,pver,nbmodes) ![frc] fraction of carbon per mode (in add-on) - real(r8), intent(in) :: f_bcm(pcols,pver,nbmodes) ![frc] fraction of bc in carbon per mode - real(r8), intent(in) :: f_aqm(pcols,pver,nbmodes) ![frc] fraction of aq in sulfate added - real(r8), intent(in) :: f_aitbc(pcols,pver) ![frc] fraction of bc in coated bc/oc mode - - !output - real(r8), intent(inout) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration - real(r8), intent(out) :: lnsigma(pcols,pver,nmodes) ![-] log (base e) of std. dev - - - !work arrays - real(r8) :: nconccm3(pcols,pver) - real(r8) :: camUg(pcols,pver) - real(r8) :: log10sig(pcols,pver) ![-] logarithm (base 10) of look up tables - real(r8), dimension(pcols,pver,nbmodes) :: cxs ![ug/m3] NOTE NON-SI UNITS non-allocated mass - !real(r8), dimension(pcols,pver) :: cxstot ![kg/m3] non allocated mass - integer, dimension(pcols) :: ind ![idx] index in mapping (not really used) - real(r8), dimension(pcols,pver) :: radius_tmp ![m] radius in look up tables - real(r8) :: f_ocm(pcols,pver,4) ! [-] fraction of added mass which is either SOA condensate or OC coagulate - integer :: iloop - integer :: kcomp - integer :: i - integer :: k - - - !total mass not allocated to any mode - !this is non-zero if the look-up table can not cope with all the add-on mass - !cxstot(:,:) = 0.0_r8 - - !Remove this later! - do i=1,ncol - ind(i)=i - end do - - ! calculate fraction of added mass which is either SOA condensate or OC coagulate, - ! which in AeroTab are both treated as condensate for kcomp=1-4 - do kcomp=1,4 - do k=1,pver - do i=1,ncol - f_ocm(i,k,kcomp) = f_acm(i,k,kcomp)*(1.0_r8-f_bcm(i,k,kcomp)) - enddo - enddo - enddo - - do iloop=1,1 ! loop over i>1 for testing CPU use in intlog* - - !Go through all "background" size-modes (kcomp=1-10) - do kcomp=1,nbmodes - - camUg(:,:) = cam(:,:,kcomp)*1.e9_r8 - nConccm3(:,:) = 1e-6_r8*numberConcentration(:,:,kcomp) - - !Calculate growth from knowing added process specific internally mixed mass to each background mode - !(level sent but not needed, and kcomp not needed for intlog4_sub) - - if( kcomp .ge. MODE_IDX_SO4SOA_AIT .and. kcomp .le. MODE_IDX_BC_AIT)then ! kcomp=1,2 - - do k=1,pver - call intlog1to3_sub( & - ncol & !I number of points - , ind & !I [idx] mappoing of points to use - , kcomp & !I [idx] mode index - , camUg(:,k) & !I [ug/m3] mass concentration - , nConccm3(:,k) & !I [#/cm3] number concentration - , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. - , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table - , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance - , radius_tmp(:,k) & !O [m] Number median radius - ) - - end do !loop on levels - - else if(kcomp .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT)then ! kcomp=4 - - do k=1,pver - call intlog4_sub( & - ncol & !I number of points - , ind & !I [idx] mappoing of points to use - , kcomp & !I [idx] mode index - , camUg(:,k) & !I [ug/m3] mass concentration - , nConccm3(:,k) & !I [#/cm3] number concentration - , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. - , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous - , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table - , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance - , radius_tmp(:,k) & !O [m] Number median radius - ) - end do - - else if (kcomp .ge. MODE_IDX_SO4_AC .and. kcomp .le. MODE_IDX_SS_A3)then ! kcomp=5-10 - - do k=1,pver - call intlog5to10_sub( & - ncol & !I [nbr] number of points used - , ind & !I [mapping] (not used) - , kcomp & !I [mode index] - , camUg(:,k) & !I [ug/m3] mass concentration - , nConccm3(:,k) & !I [#/cm3] number concentration - , f_acm(:,k,kcomp) & !I [frc] fraction of aerosol which is carbon - , f_bcm(:,k,kcomp) & !I [frc] fraction of carbon which is bc - , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous - , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table (not given to any mode) - , log10sig(:,k) & !O logarithm (base 10) sigma, is later thrown away begause of volume balance - , radius_tmp(:,k) & !O [m] Number median radius - ) - end do ! k - - endif - - !initialize - lnsigma(:,:,kcomp) = log(2.0_r8) - - !The whole point of the interpolation routines is to get the new sigma ==> so trust the sigma - - !This means that in order to conserve the volume (which is known), we have to throw away - !the number concentration. Should create a diagnostic or a warning if number concenration is very different - !from the original number concentration since in principal, the number concentration is - !also conserved! - do k=1,pver - !Don't change number concentration unless "hasAerosol" is true - where(hasAerosol(:ncol,k,kcomp)) - - lnsigma(:ncol,k,kcomp) = ln10*log10sig(:ncol,k) - - numberConcentration(:ncol,k,kcomp) = volumeConcentration(:ncol,k,kcomp)*6.0_r8/pi & - /(2.0_r8*radius_tmp(:ncol,k))**3 & - *DEXP(-4.5_r8*lnsigma(:ncol,k,kcomp)*lnsigma(:ncol,k,kcomp)) - - !==> Now we have a set of n, vol, sigma which is consistent and gives back whatever the - !lookup tables told us! If the look up tables were conserving volume we didn't have to do - !the step just above!! - - !Sum up all mass which was not added to any mode (mass exceeding the max limit in the look-up tables) - !cxstot(:ncol,k) = cxstot(:ncol,k) + cxs(:ncol,k,kcomp)*1.e-9_r8 ! ug/m3 ==> kg/m3 - - end where - end do - - end do !kcomp - - !The modes which do not have any added aerosol: - do kcomp=nbmodes+1,nmodes - do k=1,pver - lnsigma(:ncol,k,kcomp) = log(originalSigma(kcomp)) - end do - end do - - !AK (fxm): "unactivated" code below... - !Excessive internally mixed process mass added to the background modes (exceeding the max limit in the look-up tables) - !is instead added to / lumped with the externally mixed non-background modes (kcomp=11,12,14) - !numberConcentration(:,:,MODE_IDX_SO4_NUC) = numberConcentration(:,:,MODE_IDX_SO4_NUC) & - ! + (volumeToNumber(MODE_IDX_SO4_NUC) & !excess sulfate mass is moved to this mode - ! *RESHAPE(cxstot,(/pcols,pver/)) & - ! *(1.0_r8-f_c(:,:))/rhopart(l_so4_n)) - - !numberConcentration(:,:,MODE_IDX_BC_NUC) = numberConcentration(:,:,MODE_IDX_BC_NUC) & - ! + (volumeToNumber(MODE_IDX_BC_NUC) & !excess carbon mass is moved to this mode - ! * RESHAPE(cxstot,(/pcols,pver/)) & - ! * f_c(:,:)/rhopart(l_bc_n)) - - !SKIP LUMPING OF OC-MODE TO MODE MODE_IDX_LUMPED ORGANICS SINCE THIS WILL MESS UP THE HASAEROSOL-MASK! - ! modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) = efact_omn & !excess OM mass is moved to this mode (originally kcomp=13) - ! * (modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) + cxstot(i)*modedefs(i)%f_c*(1.0_r8-modedefs(i)%f_bc)) - - - enddo ! iloop - - end subroutine doLognormalInterpolation - - - subroutine modalapp2d_sub(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm,fbcm,faqm,fso4condm,fsoam) - - ! Calculation of the apportionment of internally mixed SO4, BC and OC - ! mass between the various background mineral and sea-salt modes. Separated - ! from pmxsub into a independent subroutine by Alf Kirkevåg on September - ! 12'th, 2005, and converted to 2D for use in parmix on September 15'th. - ! Modified for new aerosol schemes by Alf Kirkevaag in January 2006: Now - ! also Aitken-modes are subject to condensation of H2SO4, and both n and - ! Aitken modes may coagulate onto the mineral/sea-salt background aerosol. - !SOA - ! May 2013: The SO4(Ait) mode now takes into account condensed SOA in addition - ! to H2SO4, but as long as SOA is not allowed to condense on more than one - ! mode, no changes are necessary here. NB: to allow SOA to condense also on - ! the BC(Ait) and/or other modes, change this code accordingly! Without any - ! changes, Cam(pcols,1) = condensed SO4 onto the SO4(ait) mode still. - !SOA - ! Alf Grini, february 2014 : Added info about units, - ! used values calculated at initialization. - ! changed in-out variables to components of derived data types (modedefs) - ! defined in microphysics_oslo.F90, and corrected for mass balance error - ! for SO4 due to lumping of coagulate and condensate. - - - use ppgrid, only : pcols, pver - use shr_kind_mod, only: r8 => shr_kind_r8 - - use commondefinitions - use aerosoldef - use const, only: smallNumber - use oslo_aero_coag, only: normalizedCoagulationSink - use condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV - - implicit none - ! - ! Input arguments - ! - integer , intent(in) :: ncol ! number of columns used - real(r8), intent(in) :: Nnatkbg(pcols,pver,nbmodes) ! aerosol background mode number concentration #/m3 - real(r8), intent(in) :: Ca(pcols,pver) ! internally mixed mass, tot=SO4+OC+BC - real(r8), intent(in) :: f_c(pcols,pver) ! mass fraction (OC+BC)/tot - real(r8), intent(in) :: f_bc(pcols,pver) ! mass fraction BC/(OC+BC) - real(r8), intent(in) :: f_aq(pcols,pver) ! mass fraction SO4(aq)/SO4 - real(r8), intent(in) :: f_soa(pcols,pver) ! mass fraction SOA/(POM+SOA) - real(r8), intent(in) :: f_so4_cond(pcols,pver) ! mass fraction SO4_COND/(COND+COAG) - ! - ! Output arguments - ! - real(r8), intent(out) :: Cam(pcols,pver,nbmodes) ! modal internal mass, tot=SO4+BC+OC - real(r8), intent(out) :: fcm(pcols,pver,nbmodes) ! modal mass fraction (OC+BC)/tot - real(r8), intent(out) :: fbcm(pcols,pver,nbmodes) ! modal mass fraction BC/(OC+BC) - real(r8), intent(out) :: faqm(pcols,pver,nbmodes) ! modal mass fraction SO4(aq)/SO4 - real(r8), intent(out) :: fso4condm(pcols,pver,nbmodes) !modal mass fraction (SO4(cond)/SO4(cond+coag)) - real(r8), intent(out) :: fsoam(pcols,pver,nbmodes)! modal mass fraction SOA / (POM+SOA) - - ! - ! Local variables - real(r8) condensationSinkSO4(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode - real(r8) condensationSinkOA(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode - real(r8) coagulationSink(pcols,pver,nbmodes) ![1/s] loss rate of BC through coagulation on any mode - real(r8) aquousPhaseSink(pcols,pver,nbmodes) ![-] fraction of particles available for aq. phase in any mode - - real(r8) sumCondensationSinkSO4(pcols,pver) ![1/s] sum condensation sink to all modes - real(r8) sumCondensationSinkOA(pcols,pver) ![1/s] sum condensation sink to all modes - real(r8) sumCoagulationSink(pcols,pver) ![1/s] sum coagulation sink to all modes - real(r8) sumAquousPhaseSink(pcols,pver) ![1/s] sum aquous phase sink to all modes - - real(r8) fcondkSO4(pcols,pver,nbmodes) - real(r8) fcondkOA(pcols,pver,nbmodes) - real(r8) fcoagk(pcols,pver,nbmodes) - real(r8) faqk(pcols,pver,nbmodes) - - real(r8) cabck(pcols,pver,nbmodes) ![kg/m3] bc distributed to each mode - real(r8) caock(pcols,pver,nbmodes) ![kg/m3] pom coagulate distributed to each mode - real(r8) csoacondsk(pcols,pver,nbmodes) - real(r8) caqsk(pcols,pver,nbmodes) ![kg/m3] aq phase sulfate distributed to each mode - real(r8) cso4condsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode - real(r8) cso4coagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode - real(r8) cso4condcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode - real(r8) coccondcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode - - integer :: i !counter for modes - integer :: k !counter for levels - - !Find the sink on any mode (0 is omitted here, WHY??, it does receive matter in oslo_aero_coag/condtend!!)) - !Should either remove it from there or add something to it here! - do i=1,nbmodes - do k=1,pver - condensationSinkSO4(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_H2SO4)*Nnatkbg(:ncol,k,i) - condensationSinkOA(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_ORG_SV)*Nnatkbg(:ncol,k,i) - coagulationSink(:ncol,k,i) = normalizedCoagulationSink(i,MODE_IDX_BC_NUC)*Nnatkbg(:ncol,k,i) !use a typical coagulator (BC_NUC) - aquousPhaseSink(:ncol,k,i) = numberFractionAvailableAqChem(i)*Nnatkbg(:ncol,k,i) !aq phase sink to this mode - end do - enddo - - !Sum the sinks - sumCondensationSinkSO4(:,:) = 0.0_r8 - sumCondensationSinkOA(:,:) = 0.0_r8 - sumCoagulationSink(:,:) = 0.0_r8 - sumAquousPhaseSink(:,:) = 0.0_r8 - do i=1,nbmodes - do k=1,pver - sumCondensationSinkSO4(:ncol,k) = sumCondensationSinkSO4(:ncol,k) + condensationSinkSO4(:ncol,k,i) - sumCondensationSinkOA(:ncol,k) = sumCondensationSinkOA(:ncol,k) + condensationSinkOA(:ncol,k,i) - sumCoagulationSink(:ncol,k) = sumCoagulationSink(:ncol,k) + coagulationSink(:ncol,k,i) - sumAquousPhaseSink(:ncol,k) = sumAquousPhaseSink(:ncol,k) + aquousPhaseSink(:ncol,k,i) - end do - end do - - ! And finally the contribution from each mode relative to the totals are calculated, - ! assuming that the apportionment of mass for the first iteration (in time) is representative - ! for the whole apportionment process (which is ok for small and moderate masses added): - do i=1,nbmodes - do k=1,pver - !Get the fraction of contribution per process per mode - fcondkSO4(:ncol,k,i)=condensationSinkSO4(:ncol,k,i)/(sumCondensationSinkSO4(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode - fcondkOA(:ncol,k,i)=condensationSinkOA(:ncol,k,i)/(sumCondensationSinkOA(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode - fcoagk(:ncol,k,i)=coagulationSink(:ncol,k,i)/(sumCoagulationSink(:ncol,k)+1.e-100_r8) !fraction of coagulation sink in this mode - faqk(:ncol,k,i)=aquousPhaseSink(:ncol,k,i)/(sumAquousPhaseSink(:ncol,k)+1.e-100_r8) !fraction of aquous phase sink in this mode - - !BC coagulate to this mode [kg/m3] - cabck(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*f_bc(:ncol,k)*Ca(:ncol,k) - - !OC coagulate to this mode [kg/m3] - caock(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*(1.0_r8-f_soa(:ncol,k))*Ca(:ncol,k) - - !SOA condensate to this mode [kg/m3] - csoacondsk(:ncol,k,i) = fcondkOA(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*f_soa(:ncol,k)*Ca(:ncol,k) - - !Aquous phase SO4 to this mode [kg/m3] - caqsk(:ncol,k,i)=faqk(:ncol,k,i)*f_aq(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) - - !so4 condensate - cso4condsk(:ncol,k,i)=fcondkSO4(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*f_so4_cond(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) - - !soa coagulate - cso4coagsk(:ncol,k,i) = fcoagk(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*(1.0_r8-f_so4_cond(:ncol,k))*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) ![kg/m3] so4 coagulate - end do - enddo - - !The tables take as input the combined coagulate and condensate (both POM and SOA) - !The activation needs them separately for mass balance! - cso4condcoagsk(:ncol,:,:) = cso4condsk(:ncol,:,:) + cso4coagsk(:ncol,:,:) - coccondcoagsk(:ncol,:,:) = caock(:ncol,:,:) + csoacondsk(:ncol,:,:) - - do i=1,nbmodes - do k=1,pver - Cam(:ncol,k,i)= cabck(:ncol,k,i) & !BC - + coccondcoagsk(:ncol,k,i) & !OM - + caqsk(:ncol,k,i) + cso4condcoagsk(:ncol,k,i) + smallNumber!SO4 ==> !total process mode mass to mode i - - fcm(:ncol,k,i)=(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i))/(Cam(:ncol,k,i)+smallNumber) !fraction of mass being carbon (oc or bc) - fbcm(:ncol,k,i)=cabck(:ncol,k,i)/(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i)+smallNumber) !fraction of carbon mass being bc - faqm(:ncol,k,i)=caqsk(:ncol,k,i)/(caqsk(:ncol,k,i)+cso4condcoagsk(:ncol,k,i)+smallNumber) !fraction of sulfate being aq phase - - !Not needed for tables, but for mass balances in activation - fso4condm(:ncol,k,i) = cso4condsk(:ncol,k,i)/(cso4condcoagsk(:ncol,k,i) + smallNumber) !fraction of cond+coag which is coag - fsoam(:ncol,k,i) = csoacondsk(:ncol,k,i)/(coccondcoagsk(:ncol,k,i) + smallNumber) !fraction of OC which is SOA - end do - enddo - - return - end subroutine modalapp2d_sub - -end module parmix_progncdnc diff --git a/src/physics/cam_oslo/microp_aero.F90 b/src/physics/cam_oslo/microp_aero.F90 index 9cfab23524..95b5640d52 100644 --- a/src/physics/cam_oslo/microp_aero.F90 +++ b/src/physics/cam_oslo/microp_aero.F90 @@ -26,7 +26,7 @@ module microp_aero use ppgrid, only: pcols, pver, pverp use ref_pres, only: top_lev => trop_cloud_top_lev use physconst, only: rair - use constituents, only: cnst_get_ind + use constituents, only: cnst_get_ind, pcnst use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum use physics_types, only: physics_state_copy, physics_update use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field @@ -42,7 +42,7 @@ module microp_aero use aerosoldef, only: lifeCycleNumberMedianRadius, l_dst_a2, l_dst_a3, l_bc_ai use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex, getCloudTracerIndex use oslo_utils, only: CalculateNumberConcentration - use parmix_progncdnc + use oslo_aero_conc use oslo_aero_hetfrz use oslo_aero_nucleate_ice @@ -442,30 +442,9 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) if (trim(eddy_scheme) == 'CLUBB_SGS') deallocate(tke) ! Get size distributed interstitial aerosol - call parmix_progncdnc_sub( & - ncol & !I [nbr] number of columns used - ,state%q & !I [kg/kg] mass mixing ratio of tracers - ,rho & !I [kg/m3] air density - ,CProcessModes & !O [kg/m3] added mass (total distributed all background modes) - ,f_c & !O - ,f_bc & !O - ,f_aq & !O - ,f_so4_cond & !O - ,f_soa & - ,cam & !O - ,f_acm & !O [frc] carbon fraction in mode - ,f_bcm & !O [frc] fraction of c being bc - ,f_aqm & !O [frc] fraction of sulfate being aquous - ,f_so4_condm & !O [frc] fraction of non-aquous SO4 being condensate - ,f_soam & - ,numberConcentration & !O [#/m3] number concentration - ,volumeConcentration & !O [m3/m3] volume concentration - ,hygroscopicity & !O [mol/mol] - ,lnsigma & !O [-] log sigma - ,hasAerosol & !I [t/f] do we have this type of aerosol here? - ,volumeCore & - ,volumeCoat & - ) + call oslo_aero_conc_calc(ncol, state%q, rho, CProcessModes, & + f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & + numberConcentration, volumeConcentration, hygroscopicity, lnsigma, hasAerosol, volumeCore, volumeCoat) !ICE Nucleation call nucleate_ice_oslo_calc(state1, wsubi, pbuf, deltatin, ptend_loc, numberConcentration) diff --git a/src/physics/cam_oslo/ndrop.F90 b/src/physics/cam_oslo/ndrop.F90 index ba343cb3cf..bea38527ed 100644 --- a/src/physics/cam_oslo/ndrop.F90 +++ b/src/physics/cam_oslo/ndrop.F90 @@ -21,9 +21,11 @@ module ndrop use cam_abortutils, only: endrun use cam_logfile, only: iulog use phys_control, only: use_hetfrz_classnuc + ! use aerosoldef - use parmix_progncdnc - use oslo_utils, only: calculateNumberMedianRadius + use commondefinitions, only: nmodes, nbmodes + use const, only: smallNumber + use oslo_utils, only: calculateNumberMedianRadius implicit none @@ -1555,8 +1557,7 @@ end subroutine explmix !=============================================================================== subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - na, nmode, volume, hygro, & - fn, fm, fluxn, fluxm, flux_fullact, lnsigman ) + na, nmode, volume, hygro, fn, fm, fluxn, fluxm, flux_fullact, lnsigman ) ! calculates number, surface, and mass fraction of aerosols activated as CCN ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud @@ -1752,9 +1753,7 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & zeta(m)=twothird*sqrtalw*aten/sqrtg enddo - call maxsat(zeta,eta,nmode,smc,smax & - ,f1_var, f2_var & - ) + call maxsat(zeta, eta, nmode, smc, smax, f1_var, f2_var) lnsmax=log(smax) @@ -1908,16 +1907,14 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & eta(m)=etafactor1*etafactor2(m) zeta(m)=twothird*sqrtalw*aten/sqrtg if(present(lnsigman))then - f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) - f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) + f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) + f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) else call endrun("Problem with variable std. dev single updraft") endif enddo - call maxsat(zeta,eta,nmode,smc,smax & - ,f1_var, f2_var & - ) + call maxsat(zeta, eta, nmode, smc, smax, f1_var, f2_var) lnsmax=log(smax) xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 diff --git a/src/physics/cam_oslo/radiation.F90 b/src/physics/cam_oslo/radiation.F90 index 44a7132721..4089e4fd78 100644 --- a/src/physics/cam_oslo/radiation.F90 +++ b/src/physics/cam_oslo/radiation.F90 @@ -43,7 +43,9 @@ module radiation use perf_mod, only: t_startf, t_stopf use cam_logfile, only: iulog use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands - use pmxsub_mod, only: pmxsub + ! + use oslo_aero_optical_params, only: oslo_aero_optical_params_calc + use commondefinitions, only: nmodes, nbmodes implicit none private @@ -1194,12 +1196,10 @@ subroutine radiation_tend( & ! No aerocom variables passed for now ! dod440, dod550, dod870, abs550, abs550alt - call pmxsub(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & + call oslo_aero_optical_params_calc(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & coszrs, state, state%t, cld, qdirind, Nnatk, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & - per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, & - volc_ext_earth, volc_omega_earth, & + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & + volc_ext_sun, volc_omega_sun, volc_g_sun, volc_ext_earth, volc_omega_earth, & aodvis, absvis) call get_variability(sfac) From 7cfdff7216540d72322a236d1067d049e0e1e814 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 31 Aug 2023 09:52:50 +0200 Subject: [PATCH 31/71] rename ndrop.F90 to oslo_aero_ndrop and made it an oslo_aero specific module --- .../oslo_aero/oslo_aero_ndrop.F90} | 866 ++++++++---------- src/physics/cam_oslo/microp_aero.F90 | 8 +- 2 files changed, 391 insertions(+), 483 deletions(-) rename src/{physics/cam_oslo/ndrop.F90 => chemistry/oslo_aero/oslo_aero_ndrop.F90} (71%) diff --git a/src/physics/cam_oslo/ndrop.F90 b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 similarity index 71% rename from src/physics/cam_oslo/ndrop.F90 rename to src/chemistry/oslo_aero/oslo_aero_ndrop.F90 index bea38527ed..31a0f5fa20 100644 --- a/src/physics/cam_oslo/ndrop.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 @@ -1,36 +1,47 @@ -module ndrop +module oslo_aero_ndrop !--------------------------------------------------------------------------------- - ! Purpose: - ! CAM Interface for droplet activation by modal aerosols + ! Droplet activation by oslo modal aerosols + ! Compute vertical diffusion and nucleation of cloud droplets !--------------------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, pverp - use physconst, only: pi, rhoh2o, mwh2o, r_universal, rh2o - use physconst, only: gravit, latvap, cpair, epsilo, rair - use constituents, only: pcnst, cnst_get_ind, cnst_name, cnst_spec_class_gas, cnst_species_class - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field - use wv_saturation, only: qsat - use phys_control, only: phys_getopts - use ref_pres, only: top_lev => trop_cloud_top_lev - use shr_spfn_mod, only: erf => shr_spfn_erf - use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use phys_control, only: use_hetfrz_classnuc + use shr_kind_mod, only: r8 => shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp + use physconst, only: pi, rhoh2o, mwh2o, r_universal, rh2o + use physconst, only: gravit, latvap, cpair, rair + use constituents, only: pcnst, cnst_get_ind, cnst_name, cnst_spec_class_gas, cnst_species_class + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field + use wv_saturation, only: qsat + use phys_control, only: phys_getopts, use_hetfrz_classnuc + use ref_pres, only: top_lev => trop_cloud_top_lev + use shr_spfn_mod, only: erf => shr_spfn_erf + use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld + use cam_abortutils, only: endrun + use cam_logfile, only: iulog ! - use aerosoldef + use oslo_utils, only: calculateNumberMedianRadius + use aerosoldef, only: getNumberOfTracersInMode, getNumberOfAerosolTracers, getTracerIndex + use aerosoldef, only: getCloudTracerName, getCloudTracerIndex, getConstituentFraction + use aerosoldef, only: fillAerosolTracerList, fillInverseAerosolTracerList use commondefinitions, only: nmodes, nbmodes use const, only: smallNumber - use oslo_utils, only: calculateNumberMedianRadius implicit none + private - public :: ndrop_init, dropmixnuc, activate_modal + ! public routines + public :: ndrop_init_oslo + public :: dropmixnuc_oslo + ! private routines + private :: explmix_oslo + private :: maxsat_oslo + private :: ccncalc_oslo + private :: activate_modal_oslo + + ! private variables real(r8) :: t0 ! reference temperature real(r8) :: aten real(r8) :: surften ! surface tension of water w/respect to air (N/m) @@ -39,10 +50,11 @@ module ndrop real(r8) :: sq2, sqpi integer, parameter :: psat=7 ! number of supersaturations to calc ccn concentration - real(r8), parameter :: supersat(psat)= & ! supersaturation (%) to determine ccn concentration - (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.15_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) - character(len=8) :: ccn_name(psat)= & - (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6','CCN7'/) + + ! supersaturation (%) to determine ccn concentration + real(r8), parameter :: supersat(psat)= (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.15_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) + + character(len=8) :: ccn_name(psat)= (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6','CCN7'/) ! indices in state and pbuf structures integer :: numliq_idx = -1 @@ -88,7 +100,7 @@ module ndrop contains !=============================================================================== - subroutine ndrop_init + subroutine ndrop_init_oslo() integer :: ii, l, lptr, m, mm integer :: nspec_max ! max number of species in a mode @@ -123,7 +135,7 @@ subroutine ndrop_init ! get info about the modal aerosols ! get ntot_amode ! TODO: make these local variables and don't allocate - ntot_amode = nmodes !from opttab + ntot_amode = nmodes allocate( & nspec_amode(ntot_amode), & sigmag_amode(ntot_amode), & @@ -148,11 +160,10 @@ subroutine ndrop_init ncnst_tot = ncnst_tot + nspec_amode(m) + 1 end do - allocate( & - mam_idx(ntot_amode,0:nspec_max), & - mam_cnst_idx(ntot_amode,0:nspec_max), & - fieldname(ncnst_tot), & - fieldname_cw(ncnst_tot) ) + allocate(mam_idx(ntot_amode,0:nspec_max)) + allocate(mam_cnst_idx(ntot_amode,0:nspec_max)) + allocate(fieldname(ncnst_tot)) + allocate(fieldname_cw(ncnst_tot)) ! Local indexing compresses the mode and number/mass indicies into one index. ! This indexing is used by the pointer arrays used to reference state and pbuf @@ -168,18 +179,19 @@ subroutine ndrop_init ! Add dropmixnuc tendencies for all modal aerosol species call phys_getopts(history_amwg_out = history_amwg, & - history_aerosol_out = history_aerosol, & - prog_modal_aero_out=prog_modal_aero) + history_aerosol_out = history_aerosol, prog_modal_aero_out=prog_modal_aero) prog_modal_aero = .TRUE. n_aerosol_tracers = getNumberOfAerosolTracers() call fillAerosolTracerList(aerosolTracerList) call fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) - do ii=1,n_aerosol_tracers - print*, "aerosolTracerList", ii, aerosolTracerList(ii), inverseAerosolTracerList(aerosolTracerList(ii)) - end do + if (masterproc) then + do ii=1,n_aerosol_tracers + write(iulog,*) "aerosolTracerList", ii, aerosolTracerList(ii), inverseAerosolTracerList(aerosolTracerList(ii)) + end do + end if - lq(:)=.FALSE. !Initialize + lq(:) = .false. !Initialize !Set up tendencies for tracers (output) do m=1,ntot_amode @@ -252,76 +264,66 @@ subroutine ndrop_init call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics') call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number') - end subroutine ndrop_init + end subroutine ndrop_init_oslo !=============================================================================== - subroutine dropmixnuc( & - state, ptend, dtmicro, pbuf, wsub, & ! Input - cldn, cldo, cldliqf, & - hasAerosol, & - CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, & - cam, f_acm, f_bcm, f_aqm, f_so4_condm, & - f_soam, & - numberConcentration, volumeConcentration, & - hygroscopicity, lnsigma, & - tendnd, & ! Output - fn_in) + subroutine dropmixnuc_oslo( state, ptend, dtmicro, pbuf, wsub, & + cldn, cldo, cldliqf, hasAerosol, CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & + numberConcentration, volumeConcentration, hygroscopicity, lnsigma, tendnd, fn_in) ! vertical diffusion and nucleation of cloud droplets ! assume cloud presence controlled by cloud fraction ! doesn't distinguish between warm, cold clouds ! arguments - type(physics_state), target, intent(in) :: state - type(physics_ptend), intent(out) :: ptend - real(r8), intent(in) :: dtmicro ! time step for microphysics (s) - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: wsub(pcols,pver) ! subgrid vertical velocity - real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction - real(r8), intent(in) :: cldo(pcols,pver) ! cloud fraction on previous time step - real(r8), intent(in) :: cldliqf(pcols,pver) ! liquid cloud fraction (liquid / (liquid + ice)) - logical , intent(in) :: hasAerosol(pcols, pver, nmodes) - real(r8), intent(in) :: CProcessModes(pcols,pver) - real(r8), intent(in) :: cam(pcols,pver,nbmodes) - real(r8), intent(in) :: f_c(pcols,pver) - real(r8), intent(in) :: f_aq(pcols,pver) - real(r8), intent(in) :: f_bc(pcols,pver) - real(r8), intent(in) :: f_so4_cond(pcols,pver) - real(r8), intent(in) :: f_soa(pcols,pver) - real(r8), intent(in) :: f_acm(pcols,pver, nbmodes) - real(r8), intent(in) :: f_bcm(pcols,pver, nbmodes) - real(r8), intent(in) :: f_aqm(pcols, pver, nbmodes) - real(r8), intent(in) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction - real(r8), intent(in) :: f_soam(pcols,pver,nbmodes) - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration - real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) ![-] hygroscopicity - real(r8), intent(in) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma - real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) + type(physics_state), target, intent(in) :: state + type(physics_ptend), intent(out) :: ptend + real(r8), intent(in) :: dtmicro ! time step for microphysics (s) + type(physics_buffer_desc), pointer :: pbuf(:) + real(r8), intent(in) :: wsub(pcols,pver) ! subgrid vertical velocity + real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction + real(r8), intent(in) :: cldo(pcols,pver) ! cloud fraction on previous time step + real(r8), intent(in) :: cldliqf(pcols,pver) ! liquid cloud fraction (liquid / (liquid + ice)) + logical , intent(in) :: hasAerosol(pcols, pver, nmodes) + real(r8), intent(in) :: CProcessModes(pcols,pver) + real(r8), intent(in) :: f_c(pcols,pver) + real(r8), intent(in) :: f_bc(pcols,pver) + real(r8), intent(in) :: f_aq(pcols,pver) + real(r8), intent(in) :: f_so4_cond(pcols,pver) + real(r8), intent(in) :: f_soa(pcols,pver) + real(r8), intent(in) :: cam(pcols,pver,nbmodes) + real(r8), intent(in) :: f_acm(pcols,pver, nbmodes) + real(r8), intent(in) :: f_bcm(pcols,pver, nbmodes) + real(r8), intent(in) :: f_aqm(pcols, pver, nbmodes) + real(r8), intent(in) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction + real(r8), intent(in) :: f_soam(pcols,pver,nbmodes) + real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton + real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration + real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) ![-] hygroscopicity + real(r8), intent(in) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma + real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) ! Local variables - integer :: lchnk ! chunk identifier - integer :: ncol ! number of columns - real(r8), pointer :: ncldwtr(:,:) ! droplet number concentration (#/kg) - real(r8), pointer :: temp(:,:) ! temperature (K) - real(r8), pointer :: omega(:,:) ! vertical velocity (Pa/s) - real(r8), pointer :: pmid(:,:) ! mid-level pressure (Pa) - real(r8), pointer :: pint(:,:) ! pressure at layer interfaces (Pa) - real(r8), pointer :: pdel(:,:) ! pressure thickess of layer (Pa) - real(r8), pointer :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) - real(r8), pointer :: zm(:,:) ! geopotential height of level (m) - - real(r8), pointer :: kvh(:,:) ! vertical diffusivity (m2/s) - - type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios + integer :: lchnk ! chunk identifier + integer :: ncol ! number of columns + real(r8), pointer :: ncldwtr(:,:) ! droplet number concentration (#/kg) + real(r8), pointer :: temp(:,:) ! temperature (K) + real(r8), pointer :: omega(:,:) ! vertical velocity (Pa/s) + real(r8), pointer :: pmid(:,:) ! mid-level pressure (Pa) + real(r8), pointer :: pint(:,:) ! pressure at layer interfaces (Pa) + real(r8), pointer :: pdel(:,:) ! pressure thickess of layer (Pa) + real(r8), pointer :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) + real(r8), pointer :: zm(:,:) ! geopotential height of level (m) + real(r8), pointer :: kvh(:,:) ! vertical diffusivity (m2/s) + type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios type(ptr2d_t), allocatable :: qqcw(:) - real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios - real(r8) :: qqcwtend(pver) ! tendency of cloudborne aerosol mass, number mixing ratios + real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios + real(r8) :: qqcwtend(pver) ! tendency of cloudborne aerosol mass, number mixing ratios real(r8), parameter :: zkmin = 0.01_r8, zkmax = 100._r8 - real(r8), parameter :: wmixmin = 0.1_r8 ! minimum turbulence vertical velocity (m/s) + real(r8), parameter :: wmixmin = 0.1_r8 ! minimum turbulence vertical velocity (m/s) real(r8) :: sq2pi integer :: i, k, l, m, mm, n @@ -330,7 +332,7 @@ subroutine dropmixnuc( & integer :: lptr integer :: nsubmix, nsubmix_bnd integer, save :: count_submix(100) - integer :: phase ! phase of aerosol + integer :: phase ! phase of aerosol real(r8) :: arg real(r8) :: dtinv @@ -338,60 +340,60 @@ subroutine dropmixnuc( & real(r8) :: lcldn(pcols,pver) real(r8) :: lcldo(pcols,pver) - real(r8) :: zs(pver) ! inverse of distance between levels (m) - real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) - real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries - real(r8) :: srcn(pver) ! droplet source rate (/s) - real(r8) :: cs(pcols,pver) ! air density (kg/m3) - real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) - real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) - real(r8) :: dz(pcols,pver) ! geometric thickness of layers (m) - - real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) - real(r8) :: wtke_cen(pcols,pver) ! turbulent vertical velocity at center of layer k (m/s) + real(r8) :: zs(pver) ! inverse of distance between levels (m) + real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) + real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries + real(r8) :: srcn(pver) ! droplet source rate (/s) + real(r8) :: cs(pcols,pver) ! air density (kg/m3) + real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) + real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) + real(r8) :: dz(pcols,pver) ! geometric thickness of layers (m) + + real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) + real(r8) :: wtke_cen(pcols,pver) ! turbulent vertical velocity at center of layer k (m/s) real(r8) :: wbar, wmix, wmin, wmax - real(r8) :: zn(pver) ! g/pdel (m2/g) for layer - real(r8) :: flxconv ! convergence of flux into lowest layer + real(r8) :: zn(pver) ! g/pdel (m2/g) for layer + real(r8) :: flxconv ! convergence of flux into lowest layer - real(r8) :: wdiab ! diabatic vertical velocity - real(r8) :: ekd(pver) ! diffusivity for droplets (m2/s) - real(r8) :: ekk(0:pver) ! density*diffusivity for droplets (kg/m3 m2/s) - real(r8) :: ekkp(pver) ! zn*zs*density*diffusivity - real(r8) :: ekkm(pver) ! zn*zs*density*diffusivity + real(r8) :: wdiab ! diabatic vertical velocity + real(r8) :: ekd(pver) ! diffusivity for droplets (m2/s) + real(r8) :: ekk(0:pver) ! density*diffusivity for droplets (kg/m3 m2/s) + real(r8) :: ekkp(pver) ! zn*zs*density*diffusivity + real(r8) :: ekkm(pver) ! zn*zs*density*diffusivity real(r8) :: dum, dumc real(r8) :: tmpa real(r8) :: dact - real(r8) :: fluxntot ! (#/cm2/s) + real(r8) :: fluxntot ! (#/cm2/s) real(r8) :: dtmix real(r8) :: alogarg - real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap + real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap - real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) - real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) - real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) + real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) + real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) + real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) real(r8) :: cldo_tmp, cldn_tmp real(r8) :: tau_cld_regenerate real(r8) :: zeroaer(pver) - real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) + real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) - real(r8), allocatable :: nact(:,:) ! fractional aero. number activation rate (/s) - real(r8), allocatable :: mact(:,:) ! fractional aero. mass activation rate (/s) + real(r8), allocatable :: nact(:,:) ! fractional aero. number activation rate (/s) + real(r8), allocatable :: mact(:,:) ! fractional aero. mass activation rate (/s) - real(r8), allocatable :: raercol(:,:,:) ! single column of aerosol mass, number mixing ratios - real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase + real(r8), allocatable :: raercol(:,:,:) ! single column of aerosol mass, number mixing ratios + real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase - !to avoid excessive calls to boundary layer scheme + !to avoid excessive calls to boundary layer scheme real(r8), allocatable :: raercol_tracer(:,:,:) real(r8), allocatable :: raercol_cw_tracer(:,:,:) real(r8), allocatable :: mact_tracer(:,:) real(r8), allocatable :: mfullact_tracer(:,:) real(r8) :: na(pcols), va(pcols), hy(pcols) - real(r8), allocatable :: naermod(:) ! (1/m3) - real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode - real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) + real(r8), allocatable :: naermod(:) ! (1/m3) + real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode + real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) real(r8) :: source(pver) @@ -796,7 +798,7 @@ subroutine dropmixnuc( & if (cldn_tmp-cldo_tmp > 0.01_r8) then - ! rce-comment - use wtke at layer centers for new-cloud activation + ! use wtke at layer centers for new-cloud activation wbar = wtke_cen(i,k) wmix = 0._r8 wmin = 0._r8 @@ -804,15 +806,14 @@ subroutine dropmixnuc( & wdiab = 0._r8 ! load aerosol properties, assuming external mixtures - naermod(:) = 0.0_r8 vaerosol(:) = 0.0_r8 hygro(:) = 0.0_r8 lnsigman(:) = log(2.0_r8) - m=0 + m = 0 do kcomp = 1,nmodes - if(hasAerosol(i,k,kcomp) .eqv. .TRUE.)then + if(hasAerosol(i,k,kcomp)) then m = m + 1 naermod(m) = numberConcentration(i,k,kcomp) vaerosol(m) = volumeConcentration(i,k,kcomp) @@ -822,17 +823,16 @@ subroutine dropmixnuc( & end if end do numberOfModes = m - !Call the activation procedure - if(numberOfModes .gt. 0)then + + ! Call the activation procedure + if (numberOfModes .gt. 0)then if (use_hetfrz_classnuc) then - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & + call activate_modal_oslo( wbar, wmix, wdiab, wmin, wmax, & temp(i,k), cs(i,k), naermod, numberOfModes, & vaerosol, hygro, fn_in(i,k,1:nmodes), fm, fluxn, & fluxm, flux_fullact(k), lnsigman) else - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & + call activate_modal_oslo( wbar, wmix, wdiab, wmin, wmax, & temp(i,k), cs(i,k), naermod, numberOfModes, & vaerosol, hygro, fn, fm, fluxn, & fluxm, flux_fullact(k), lnsigman) @@ -898,12 +898,11 @@ subroutine dropmixnuc( & ! ...................................................................... ! start of k-loop for calc of old cloud activation tendencies .......... ! - ! rce-comment - ! changed this part of code to use current cloud fraction (cldn) exclusively - ! consider case of cldo(:)=0, cldn(k)=1, cldn(k+1)=0 - ! previous code (which used cldo below here) would have no cloud-base activation - ! into layer k. however, activated particles in k mix out to k+1, - ! so they are incorrectly depleted with no replacement + ! use current cloud fraction (cldn) exclusively + ! consider case of cldo(:)=0, cldn(k)=1, cldn(k+1)=0 + ! previous code (which used cldo below here) would have no cloud-base activation + ! into layer k. however, activated particles in k mix out to k+1, + ! so they are incorrectly depleted with no replacement ! old_cloud_main_k_loop do k = top_lev, pver @@ -958,21 +957,15 @@ subroutine dropmixnuc( & numberOfModes = m if(numberOfModes .gt. 0)then if (use_hetfrz_classnuc) then - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn_in(i,k,:), fm, fluxn, & - fluxm, flux_fullact(k) & - ,lnsigman & - ) + call activate_modal_oslo(wbar, wmix, wdiab, wmin, wmax, & + temp(i,k), cs(i,k), naermod, numberOfModes , & + vaerosol, hygro, fn_in(i,k,:), fm, fluxn, & + fluxm, flux_fullact(k), lnsigman) else - call activate_modal( & - wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn, fm, fluxn, & - fluxm, flux_fullact(k) & - ,lnsigman & - ) + call activate_modal_oslo(wbar, wmix, wdiab, wmin, wmax, & + temp(i,k), cs(i,k), naermod, numberOfModes , & + vaerosol, hygro, fn, fm, fluxn, & + fluxm, flux_fullact(k), lnsigman) end if endif @@ -1012,34 +1005,32 @@ subroutine dropmixnuc( & fluxntot = 0.0_r8 - ! rce-comment 1 - ! flux of activated mass into layer k (in kg/m2/s) - ! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) - ! source of activated mass (in kg/kg/s) = flux divergence - ! = actmassflux/(cs(i,k)*dz(i,k)) - ! so need factor of csbot_cscen = csbot(k)/cs(i,k) - ! dum=1./(dz(i,k)) + ! flux of activated mass into layer k (in kg/m2/s) + ! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) + ! source of activated mass (in kg/kg/s) = flux divergence + ! = actmassflux/(cs(i,k)*dz(i,k)) + ! so need factor of csbot_cscen = csbot(k)/cs(i,k) + ! dum=1./(dz(i,k)) dum=csbot_cscen(k)/(dz(i,k)) - ! rce-comment 2 - ! code for k=pver was changed to use the following conceptual model - ! in k=pver, there can be no cloud-base activation unless one considers - ! a scenario such as the layer being partially cloudy, - ! with clear air at bottom and cloudy air at top - ! assume this scenario, and that the clear/cloudy portions mix with - ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) - ! in the absence of other sources/sinks, qact (the activated particle - ! mixratio) attains a steady state value given by - ! qact_ss = fcloud*fact*qtot - ! where fcloud is cloud fraction, fact is activation fraction, - ! qtot=qact+qint, qint is interstitial particle mixratio - ! the activation rate (from mixing within the layer) can now be - ! written as - ! d(qact)/dt = (qact_ss - qact)/taumix_internal - ! = qtot*(fcloud*fact*wtke/dz) - qact*(wtke/dz) - ! note that (fcloud*fact*wtke/dz) is equal to the nact/mact - ! also, d(qact)/dt can be negative. in the code below - ! it is forced to be >= 0 + ! code for k=pver was changed to use the following conceptual model + ! in k=pver, there can be no cloud-base activation unless one considers + ! a scenario such as the layer being partially cloudy, + ! with clear air at bottom and cloudy air at top + ! assume this scenario, and that the clear/cloudy portions mix with + ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) + ! in the absence of other sources/sinks, qact (the activated particle + ! mixratio) attains a steady state value given by + ! qact_ss = fcloud*fact*qtot + ! where fcloud is cloud fraction, fact is activation fraction, + ! qtot=qact+qint, qint is interstitial particle mixratio + ! the activation rate (from mixing within the layer) can now be + ! written as + ! d(qact)/dt = (qact_ss - qact)/taumix_internal + ! = qtot*(fcloud*fact*wtke/dz) - qact*(wtke/dz) + ! note that (fcloud*fact*wtke/dz) is equal to the nact/mact + ! also, d(qact)/dt can be negative. in the code below + ! it is forced to be >= 0 ! ! steve -- ! you will likely want to change this. i did not really understand @@ -1077,7 +1068,6 @@ subroutine dropmixnuc( & else ! i.e: cldn(i,k) < 0.01_r8 ! no liquid cloud - nsource(i,k) = nsource(i,k) - qcld(k)*dtinv qcld(k) = 0.0_r8 @@ -1109,8 +1099,8 @@ subroutine dropmixnuc( & ! load new droplets in layers above, below clouds - dtmin = dtmicro - ekk(top_lev-1) = 0.0_r8 + dtmin = dtmicro + ekk(top_lev-1) = 0.0_r8 ekk(pver) = 0.0_r8 do k = top_lev, pver-1 ! rce-comment -- ekd(k) is eddy-diffusivity at k/k+1 interface @@ -1170,8 +1160,6 @@ subroutine dropmixnuc( & end if end do - - ! rce-comment ! the activation source(k) = mact(k,m)*raercol(kp1,lmass) ! should not exceed the rate of transfer of unactivated particles ! from kp1 to k which = ekkp(k)*raercol(kp1,lmass) @@ -1209,8 +1197,7 @@ subroutine dropmixnuc( & end do !m do lptr2=1,n_aerosol_tracers - mact_tracer(:,lptr2) = mact_tracer(:,lptr2) & - /(mfullact_tracer(:,lptr2) + smallNumber) + mact_tracer(:,lptr2) = mact_tracer(:,lptr2) /(mfullact_tracer(:,lptr2) + smallNumber) end do ! old_cloud_nsubmix_loop @@ -1239,10 +1226,8 @@ subroutine dropmixnuc( & end do !mixing of cloud droplets - call explmix( & - qcld, srcn, ekkp, ekkm, overlapp, & - overlapm, qncld, zero, zero, pver, & - dtmix, .false.) + call explmix_oslo(qcld, srcn, ekkp, ekkm, overlapp, & + overlapm, qncld, zero, zero, pver, dtmix, .false.) !Mix number concentrations consistently!! do m = 1, ntot_amode @@ -1257,15 +1242,11 @@ subroutine dropmixnuc( & source(pver) = max(0.0_r8, tmpa) flxconv = 0._r8 - call explmix( & - raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, & - dtmix, .false.) + call explmix_oslo( raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, dtmix, .false.) - call explmix( & - raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol(:,mm,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw(:,mm,nsav)) + call explmix_oslo( raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol(:,mm,nsav), zero, flxconv, pver, dtmix, .true., raercol_cw(:,mm,nsav)) end do do lptr2=1,n_aerosol_tracers @@ -1278,15 +1259,12 @@ subroutine dropmixnuc( & source(pver) = max(0.0_r8, tmpa) flxconv = 0.0_r8 - call explmix( & - raercol_cw_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw_tracer(:,lptr2,nsav), zero, zero, pver, & - dtmix, .false.) + call explmix_oslo(raercol_cw_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_cw_tracer(:,lptr2,nsav), zero, zero, pver, dtmix, .false.) - call explmix( & - raercol_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_tracer(:,lptr2,nsav), zero, flxconv, pver, & - dtmix, .true., raercol_cw_tracer(:,lptr2,nsav)) + call explmix_oslo(raercol_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & + overlapm, raercol_tracer(:,lptr2,nsav), zero, flxconv, pver, dtmix, .true., & + raercol_cw_tracer(:,lptr2,nsav)) end do !Number of aerosol tracers end do ! old_cloud_nsubmix_loop @@ -1476,40 +1454,37 @@ subroutine dropmixnuc( & deallocate(mact_tracer) deallocate(mfullact_tracer) - end subroutine dropmixnuc + end subroutine dropmixnuc_oslo !=============================================================================== - subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & + subroutine explmix_oslo( q, src, ekkp, ekkm, overlapp, overlapm, & qold, surfrate, flxconv, pver, dt, is_unact, qactold ) - ! explicit integration of droplet/aerosol mixing - ! with source due to activation/nucleation + ! explicit integration of droplet/aerosol mixing with source due to activation/nucleation - - integer, intent(in) :: pver ! number of levels - real(r8), intent(out) :: q(pver) ! mixing ratio to be updated - real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step - real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) - real(r8), intent(in) :: ekkp(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! below layer k (k,k+1 interface) - real(r8), intent(in) :: ekkm(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! above layer k (k,k+1 interface) + integer, intent(in) :: pver ! number of levels + real(r8), intent(out):: q(pver) ! mixing ratio to be updated + real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step + real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) + real(r8), intent(in) :: ekkp(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! below layer k (k,k+1 interface) + real(r8), intent(in) :: ekkm(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface + ! above layer k (k,k+1 interface) real(r8), intent(in) :: overlapp(pver) ! cloud overlap below real(r8), intent(in) :: overlapm(pver) ! cloud overlap above - real(r8), intent(in) :: surfrate ! surface exchange rate (/s) - real(r8), intent(in) :: flxconv ! convergence of flux from surface - real(r8), intent(in) :: dt ! time step (s) - logical, intent(in) :: is_unact ! true if this is an unactivated species - real(r8), intent(in),optional :: qactold(pver) - ! mixing ratio of ACTIVATED species from previous step - ! *** this should only be present - ! if the current species is unactivated number/sfc/mass + real(r8), intent(in) :: surfrate ! surface exchange rate (/s) + real(r8), intent(in) :: flxconv ! convergence of flux from surface + real(r8), intent(in) :: dt ! time step (s) + logical, intent(in) :: is_unact ! true if this is an unactivated species + real(r8), intent(in),optional :: qactold(pver) ! mixing ratio of ACTIVATED species from previous step + ! *** this should only be present if the current species + ! is unactivated number/sfc/mass integer k,kp1,km1 if ( is_unact ) then - ! the qactold*(1-overlap) terms are resuspension of activated material + ! the qactold*(1-overlap) terms are resuspension of activated material do k=top_lev,pver kp1=min(k+1,pver) km1=max(k-1,top_lev) @@ -1517,81 +1492,60 @@ subroutine explmix( q, src, ekkp, ekkm, overlapp, overlapm, & qactold(kp1)*(1.0_r8-overlapp(k))) & + ekkm(k)*(qold(km1) - qold(k) + & qactold(km1)*(1.0_r8-overlapm(k))) ) - ! force to non-negative - ! if(q(k)<-1.e-30)then - ! write(iulog,*)'q=',q(k),' in explmix' q(k)=max(q(k),0._r8) - ! endif end do - ! diffusion loss at base of lowest layer + ! diffusion loss at base of lowest layer q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt - ! force to non-negative - ! if(q(pver)<-1.e-30)then - ! write(iulog,*)'q=',q(pver),' in explmix' q(pver)=max(q(pver),0._r8) - ! endif else do k=top_lev,pver kp1=min(k+1,pver) km1=max(k-1,top_lev) q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) - ! force to non-negative - ! if(q(k)<-1.e-30)then - ! write(iulog,*)'q=',q(k),' in explmix' - q(k)=max(q(k),0._r8) - ! endif + q(k) = max(q(k),0._r8) ! force to non-negative if (q(k)<-1.e-30) then end do - ! diffusion loss at base of lowest layer - q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt - ! force to non-negative - ! if(q(pver)<-1.e-30)then - ! write(iulog,*)'q=',q(pver),' in explmix' - q(pver)=max(q(pver),0._r8) - + q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt ! diffusion loss at base of lowest layer + q(pver)=max(q(pver),0._r8) ! force to non-negative if(q(pver)<-1.e-30)then end if - end subroutine explmix + end subroutine explmix_oslo !=============================================================================== - subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & + subroutine activate_modal_oslo(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & na, nmode, volume, hygro, fn, fm, fluxn, fluxm, flux_fullact, lnsigman ) - ! calculates number, surface, and mass fraction of aerosols activated as CCN - ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud - ! assumes an internal mixture within each of up to nmode multiple aerosol modes - ! a gaussiam spectrum of updrafts can be treated. - - ! mks units - - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. + ! calculates number, surface, and mass fraction of aerosols activated as CCN + ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud + ! assumes an internal mixture within each of up to nmode multiple aerosol modes + ! a gaussiam spectrum of updrafts can be treated. + ! mks units - ! input + ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. + ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) - real(r8), intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) - real(r8), intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) - real(r8), intent(in) :: wminf ! minimum updraft velocity for integration (m/s) - real(r8), intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) - real(r8), intent(in) :: tair ! air temperature (K) - real(r8), intent(in) :: rhoair ! air density (kg/m3) - real(r8), intent(in) :: na(:) ! aerosol number concentration (/m3) - integer, intent(in) :: nmode ! number of aerosol modes - real(r8), intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) - real(r8), intent(in) :: hygro(:) ! hygroscopicity of aerosol mode - real(r8), intent(in), optional :: lnsigman(:) - ! output - - real(r8), intent(out) :: fn(:) ! number fraction of aerosols activated - real(r8), intent(out) :: fm(:) ! mass fraction of aerosols activated - real(r8), intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8), intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8), intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) + ! arguments + real(r8) , intent(in) :: wbar ! grid cell mean vertical velocity (m/s) + real(r8) , intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) + real(r8) , intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) + real(r8) , intent(in) :: wminf ! minimum updraft velocity for integration (m/s) + real(r8) , intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) + real(r8) , intent(in) :: tair ! air temperature (K) + real(r8) , intent(in) :: rhoair ! air density (kg/m3) + real(r8) , intent(in) :: na(:) ! aerosol number concentration (/m3) + integer , intent(in) :: nmode ! number of aerosol modes + real(r8) , intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) + real(r8) , intent(in) :: hygro(:) ! hygroscopicity of aerosol mode + real(r8) , intent(in) :: lnsigman(:) + real(r8) , intent(out) :: fn(:) ! number fraction of aerosols activated + real(r8) , intent(out) :: fm(:) ! mass fraction of aerosols activated + real(r8) , intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) + real(r8) , intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) + real(r8) , intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) ! used for consistency check -- this should match (ekd(k)*zs(k)) ! also, fluxm/flux_fullact gives fraction of aerosol mass flux!that is activated @@ -1648,7 +1602,7 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & real(r8) grow character(len=*), parameter :: subname='activate_modal' integer m,n - ! numerical integration parameters + ! numerical integration parameters real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) @@ -1667,83 +1621,76 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return - pres=rair*rhoair*tair - diff0=0.211e-4_r8*(p0/pres)*(tair/t0)**1.94_r8 - conduct0=(5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg + pres = rair*rhoair*tair + diff0 = 0.211e-4_r8*(p0/pres)*(tair/t0)**1.94_r8 + conduct0 = (5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg + call qsat(tair, pres, es, qs) - dqsdt=latvap/(rh2o*tair*tair)*qs - alpha=gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) - gamma=(1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) - etafactor2max=1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. - grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) & - + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) + dqsdt = latvap/(rh2o*tair*tair)*qs + alpha = gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) + gamma = (1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) + etafactor2max = 1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. + + grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) sqrtg = sqrt(grow) beta = 2._r8*pi*rhoh2o*grow*gamma do m=1,nmode if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then - ! number mode radius (m) - ! write(iulog,*)'alogsig,volc,na=',alogsig(m),volc(m),na(m) - if(present(lnsigman))then - exp45logsig_var(m) = exp(4.5_r8*lnsigman(m)*lnsigman(m)) - amcube(m)=(3._r8*volume(m)/(4._r8*pi*exp45logsig_var(m)*na(m))) ! only if variable size dist - f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) - f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) - else - call endrun("Problem with variable std. dev") - endif - ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 - ! should depend on mean radius of mode to account for gas kinetic effects - ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 - ! for approriate size to use for effective diffusivity. - etafactor2(m)=1._r8/(na(m)*beta*sqrtg) + ! number mode radius (m) + exp45logsig_var(m) = exp(4.5_r8*lnsigman(m)*lnsigman(m)) + amcube(m) = (3._r8*volume(m)/(4._r8*pi*exp45logsig_var(m)*na(m))) ! only if variable size dist + f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) + f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) + + ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 + ! should depend on mean radius of mode to account for gas kinetic effects + ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 + ! for approriate size to use for effective diffusivity. + etafactor2(m) = 1._r8/(na(m)*beta*sqrtg) if(hygro(m).gt.1.e-10_r8)then - smc(m)=2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist + smc(m) = 2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist else - smc(m)=100._r8 + smc(m) = 100._r8 endif - ! write(iulog,*)'sm,hygro,amcube=',smcrit(m),hygro(m),amcube(m) else - smc(m)=1._r8 - etafactor2(m)=etafactor2max ! this should make eta big if na is very small. + smc(m) = 1._r8 + etafactor2(m) = etafactor2max ! this should make eta big if na is very small. endif - lnsm(m)=log(smc(m)) ! only if variable size dist - ! write(iulog,'(a,i4,4g12.2)')'m,na,amcube,hygro,sm,lnsm=', & - ! m,na(m),amcube(m),hygro(m),sm(m),lnsm(m) + lnsm(m) = log(smc(m)) ! only if variable size dist enddo if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts - wmax=min(wmaxf,wbar+sds*sigw) - wmin=max(wminf,-wdiab) - wmin=max(wmin,wbar-sds*sigw) - w=wmin - dwmax=eps*sigw - dw=dwmax - dfmax=0.2_r8 - dfmin=0.1_r8 + wmax = min(wmaxf,wbar+sds*sigw) + wmin = max(wminf,-wdiab) + wmin = max(wmin,wbar-sds*sigw) + w = wmin + dwmax = eps*sigw + dw = dwmax + dfmax = 0.2_r8 + dfmin = 0.1_r8 if (wmax <= w) return do m=1,nmode - sumflxn(m)=0._r8 - sumfn(m)=0._r8 - fnold(m)=0._r8 - sumflxm(m)=0._r8 - sumfm(m)=0._r8 - fmold(m)=0._r8 + sumflxn(m) = 0._r8 + sumfn(m) = 0._r8 + fnold(m) = 0._r8 + sumflxm(m) = 0._r8 + sumfm(m) = 0._r8 + fmold(m) = 0._r8 enddo - sumflx_fullact=0._r8 + sumflx_fullact = 0._r8 - fold=0._r8 - wold=0._r8 - gold=0._r8 + fold = 0._r8 + wold = 0._r8 + gold = 0._r8 dwmin = min( dwmax, 0.01_r8 ) do n = 1, nx 100 wnuc=w+wdiab - ! write(iulog,*)'wnuc=',wnuc alw=alpha*wnuc sqrtalw=sqrt(alw) etafactor1=alw*sqrtalw @@ -1753,7 +1700,7 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & zeta(m)=twothird*sqrtalw*aten/sqrtg enddo - call maxsat(zeta, eta, nmode, smc, smax, f1_var, f2_var) + call maxsat_oslo(zeta,eta,nmode,smc,smax,f1_var,f2_var) lnsmax=log(smax) @@ -1763,7 +1710,7 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & dwnew = dw if(fnew-fold.gt.dfmax.and.n.gt.1)then - ! reduce updraft increment for greater accuracy in integration + ! reduce updraft increment for greater accuracy in integration if (dw .gt. 1.01_r8*dwmin) then dw=0.7_r8*dw dw=max(dw,dwmin) @@ -1775,7 +1722,7 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & endif if(fnew-fold.lt.dfmin)then - ! increase updraft increment to accelerate integration + ! increase updraft increment to accelerate integration dwnew=min(1.5_r8*dw,dwmax) endif fold=fnew @@ -1786,12 +1733,12 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 do m=1,nmode - ! modal + ! modal x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) fn(m)=0.5_r8*(1._r8-erf(x)) fnmin=min(fn(m),fnmin) - ! integration is second order accurate - ! assumes linear variation of f*g with w + ! integration is second order accurate + ! assumes linear variation of f*g with w fnbar=(fn(m)*g+fnold(m)*gold) arg=x-1.5_r8*sq2*lnsigman(m) fm(m)=0.5_r8*(1._r8-erf(arg)) @@ -1804,15 +1751,14 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & +(fm(m)*g*w+fmold(m)*gold*wold))*dw endif sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw - ! write(iulog,'(a,9g10.2)')'lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw=',lnsmax,lnsm(m),x,fn(m),fnold(m),g,gold,fnbar,dw fnold(m)=fn(m) sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw fmold(m)=fm(m) enddo - ! same form as sumflxm but replace the fm with 1.0 + ! same form as sumflxm but replace the fm with 1.0 sumflx_fullact = sumflx_fullact & + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw - ! sumg=sumg+0.5_r8*(g+gold)*dw + ! sumg=sumg+0.5_r8*(g+gold)*dw gold=g wold=w dw=dwnew @@ -1825,8 +1771,8 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & write(iulog,*)'wnuc=',wnuc write(iulog,*)'na=',(na(m),m=1,nmode) write(iulog,*)'fn=',(fn(m),m=1,nmode) - ! dump all subr parameters to allow testing with standalone code - ! (build a driver that will read input and call activate) + ! dump all subr parameters to allow testing with standalone code + ! (build a driver that will read input and call activate) write(iulog,*)'wbar,sigw,wdiab,tair,rhoair,nmode=' write(iulog,*) wbar,sigw,wdiab,tair,rhoair,nmode write(iulog,*)'na=',na @@ -1841,15 +1787,15 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & ndist(n)=ndist(n)+1 if(w.lt.wmaxf)then - ! contribution from all updrafts stronger than wmax - ! assuming constant f (close to fmax) + ! contribution from all updrafts stronger than wmax + ! assuming constant f (close to fmax) wnuc=w+wdiab z1=(w-wbar)/(sigw*sq2) z2=(wmaxf-wbar)/(sigw*sq2) g=exp(-z1*z1) integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) - ! consider only upward flow into cloud base when estimating flux + ! consider only upward flow into cloud base when estimating flux wf1=max(w,zero) zf1=(wf1-wbar)/(sigw*sq2) gf1=exp(-zf1*zf1) @@ -1865,15 +1811,15 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & sumflxm(m)=sumflxm(m)+integf*fm(m) sumfm(m)=sumfm(m)+fm(m)*integ enddo - ! same form as sumflxm but replace the fm with 1.0 + ! same form as sumflxm but replace the fm with 1.0 sumflx_fullact = sumflx_fullact + integf - ! sumg=sumg+integ + ! sumg=sumg+integ endif do m=1,nmode fn(m)=sumfn(m)/(sq2*sqpi*sigw) - ! fn(m)=sumfn(m)/(sumg) + ! fn(m)=sumfn(m)/(sumg) if(fn(m).gt.1.01_r8)then write(iulog,*)'fn=',fn(m),' > 1 in activate' write(iulog,*)'w,m,na,amcube=',w,m,na(m),amcube(m) @@ -1882,52 +1828,45 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & endif fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) fm(m)=sumfm(m)/(sq2*sqpi*sigw) - ! fm(m)=sumfm(m)/(sumg) + ! fm(m)=sumfm(m)/(sumg) if(fm(m).gt.1.01_r8)then write(iulog,*)'fm=',fm(m),' > 1 in activate' endif fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) enddo - ! same form as fluxm + ! same form as fluxm flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) else - ! single updraft + ! single updraft wnuc=wbar+wdiab if(wnuc.gt.0._r8)then - w=wbar alw=alpha*wnuc sqrtalw=sqrt(alw) etafactor1=alw*sqrtalw - do m=1,nmode - eta(m)=etafactor1*etafactor2(m) - zeta(m)=twothird*sqrtalw*aten/sqrtg - if(present(lnsigman))then - f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) - f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) - else - call endrun("Problem with variable std. dev single updraft") - endif + do m = 1,nmode + eta(m) = etafactor1*etafactor2(m) + zeta(m) = twothird*sqrtalw*aten/sqrtg + f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) + f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) enddo - call maxsat(zeta, eta, nmode, smc, smax, f1_var, f2_var) + call maxsat_oslo(zeta,eta,nmode,smc,smax,f1_var, f2_var) lnsmax=log(smax) xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - - - do m=1,nmode - x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) - fn(m)=0.5_r8*(1._r8-erf(x)) - arg=x-1.5_r8*sq2*lnsigman(m) - fm(m)=0.5_r8*(1._r8-erf(arg)) - if(wbar.gt.0._r8)then - fluxn(m)=fn(m)*w - fluxm(m)=fm(m)*w + do m = 1,nmode + x = twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) + fn(m) = 0.5_r8*(1._r8-erf(x)) + arg = x-1.5_r8*sq2*lnsigman(m) + fm(m) = 0.5_r8*(1._r8-erf(arg)) + if (wbar.gt.0._r8)then + fluxn(m) = fn(m)*w + fluxm(m) = fm(m)*w endif enddo flux_fullact = w @@ -1935,26 +1874,25 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & endif - end subroutine activate_modal + end subroutine activate_modal_oslo !=============================================================================== + subroutine maxsat_oslo(zeta, eta, nmode, smc, smax, f1_in, f2_in) - subroutine maxsat(zeta,eta,nmode,smc,smax, f1_in, f2_in) + ! calculates maximum supersaturation for multiple competing aerosol modes. + ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. + ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - ! calculates maximum supersaturation for multiple - ! competing aerosol modes. - - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - integer, intent(in) :: nmode ! number of modes - real(r8), intent(in) :: smc(nmode) ! critical supersaturation for number mode radius + ! arguments real(r8), intent(in) :: zeta(nmode) real(r8), intent(in) :: eta(nmode) - real(r8), intent(in), optional, target :: f1_in(:) - real(r8), intent(in), optional, target :: f2_in(:) - + integer, intent(in) :: nmode ! number of modes + real(r8), intent(in) :: smc(nmode) ! critical supersaturation for number mode radius + real(r8), intent(in), target :: f1_in(:) + real(r8), intent(in), target :: f2_in(:) real(r8), intent(out) :: smax ! maximum supersaturation + + ! local variables integer :: m ! mode index real(r8) :: sum, g1, g2, g1sqrt, g2sqrt real(r8), pointer :: f1_used(:), f2_used(:) @@ -1964,52 +1902,42 @@ subroutine maxsat(zeta,eta,nmode,smc,smax, f1_in, f2_in) do m=1,nmode if(zeta(m).gt.1.e5_r8*eta(m).or.smc(m)*smc(m).gt.1.e5_r8*eta(m))then - ! weak forcing. essentially none activated + ! weak forcing. essentially none activated smax=1.e-20_r8 else - ! significant activation of this mode. calc activation all modes. + ! significant activation of this mode. calc activation all modes. exit endif ! No significant activation in any mode. Do nothing. if (m == nmode) return - enddo - sum=0.0_r8 - do m=1,nmode + sum = 0.0_r8 + do m = 1,nmode if(eta(m).gt.1.e-20_r8)then - g1=zeta(m)/eta(m) - g1sqrt=sqrt(g1) - g1=g1sqrt*g1 - g2=smc(m)/sqrt(eta(m)+3._r8*zeta(m)) - g2sqrt=sqrt(g2) - g2=g2sqrt*g2 - sum=sum+(f1_used(m)*g1+f2_used(m)*g2)/(smc(m)*smc(m)) + g1 = zeta(m)/eta(m) + g1sqrt = sqrt(g1) + g1 = g1sqrt*g1 + g2 = smc(m)/sqrt(eta(m)+3._r8*zeta(m)) + g2sqrt = sqrt(g2) + g2 = g2sqrt*g2 + sum = sum+(f1_used(m)*g1+f2_used(m)*g2)/(smc(m)*smc(m)) else - sum=1.e20_r8 + sum = 1.e20_r8 endif enddo + smax = 1._r8/sqrt(sum) - smax=1._r8/sqrt(sum) - - end subroutine maxsat + end subroutine maxsat_oslo !=============================================================================== - subroutine ccncalc_oslo(state & - , pbuf & - , cs & - , hasAerosol & - , numberConcentration & - , volumeConcentration & - , hygroscopicity & - , lnSigma & - , ccn ) + subroutine ccncalc_oslo(state, pbuf, cs, hasAerosol, numberConcentration, volumeConcentration, & + hygroscopicity, lnSigma, ccn) ! calculates number concentration of aerosols activated as CCN at ! supersaturation supersat. - ! assumes an internal mixture of a multiple externally-mixed aerosol modes - ! cgs units + ! assumes an internal mixture of a multiple externally-mixed aerosol modes cgs units ! This was used in the BACCHUS-project where it was agreed that ! CCN would not include cloud-borne aerosols. It is possible to @@ -2017,101 +1945,81 @@ subroutine ccncalc_oslo(state & ! not needed when this code was made. ! arguments - type(physics_state), target, intent(in) :: state type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), intent(in) :: cs(pcols,pver) ! air density (kg/m3) - real(r8), intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) - !+tht - logical, intent(in) :: hasAerosol(pcols, pver, nmodes) - !-tht - !akc6 real(r8), intent(in) :: numberConcentration(pcols,pver, nmodes) ! interstit+activated aerosol number conc (/m3) - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ! interstit+activated aerosol number conc (/m3) - !akc6- - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ! interstit+activated aerosol volume conc (m3/m3) - real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) - real(r8), intent(in) :: lnSigma(pcols,pver,nmodes) + real(r8) , intent(in) :: cs(pcols,pver) ! air density (kg/m3) + logical , intent(in) :: hasAerosol(pcols, pver, nmodes) + real(r8) , intent(in) :: numberConcentration(pcols,pver,0:nmodes) ! interstit+activated aerosol number conc (/m3) + real(r8) , intent(in) :: volumeConcentration(pcols,pver,nmodes) ! interstit+activated aerosol volume conc (m3/m3) + real(r8) , intent(in) :: hygroscopicity(pcols,pver,nmodes) + real(r8) , intent(in) :: lnSigma(pcols,pver,nmodes) + real(r8) , intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) ! local - integer :: lchnk ! chunk index - integer :: ncol ! number of columns - real(r8), pointer :: tair(:,:) ! air temperature (K) - - - real(r8) super(psat) ! supersaturation - real(r8) surften_coef !Coefficient in ARGI / ARGII - real(r8) amcube !number median radius qubed - real(r8) a ! surface tension parameter - real(r8) sm ! critical supersaturation at mode radius - real(r8) arg ! factor in eqn 15 ARGII - real(r8) argfactor !Coefficient in ARGI/ARGII - ! mathematical constants - real(r8), parameter:: twothird=2.0_r8/3.0_r8 - real(r8), parameter:: sq2=sqrt(2.0_r8) + integer :: lchnk ! chunk index + integer :: ncol ! number of columns + real(r8) :: super(psat) ! supersaturation + real(r8) :: surften_coef ! Coefficient in ARGI / ARGII + real(r8) :: amcube ! number median radius qubed + real(r8) :: a ! surface tension parameter + real(r8) :: sm ! critical supersaturation at mode radius + real(r8) :: arg ! factor in eqn 15 ARGII + real(r8) :: argfactor ! Coefficient in ARGI/ARGII + real(r8) :: exp45logsig_var ! mathematical constants + integer :: lsat,m,i,k ! mathematical constants + real(r8) :: smcoefcoef,smcoef ! mathematical constants + real(r8), pointer :: tair(:,:) ! air temperature (K) + real(r8), parameter :: twothird=2.0_r8/3.0_r8 + real(r8), parameter :: sq2=sqrt(2.0_r8) real(r8), parameter :: surften=0.076_r8 !surface tension of water (J/m2) - real(r8) exp45logsig_var - integer lsat,m,i,k - real(r8) smcoefcoef,smcoef !------------------------------------------------------------------------------- lchnk = state%lchnk ncol = state%ncol tair => state%t - super(:)=supersat(:)*0.01_r8 + super(:) = supersat(:)*0.01_r8 - !This is curvature effect (A) in ARGI - !eqn 5 in ARG1 (missing division by temperature, see below) - surften_coef=2._r8*mwh2o*surften/(r_universal*rhoh2o) + !This is curvature effect (A) in ARGI eqn 5 in ARG1 (missing division by temperature, see below) + surften_coef = 2._r8*mwh2o*surften/(r_universal*rhoh2o) - !This is part of eqn 9 in ARGII - !where A smcoefcoef is 2/3^(3/2) - smcoefcoef=2._r8/sqrt(27._r8) + !This is part of eqn 9 in ARGII where A smcoefcoef is 2/3^(3/2) + smcoefcoef = 2._r8/sqrt(27._r8) ccn(:,:,:) = 0._r8 do m=1,nmodes do k=top_lev,pver - do i=1,ncol if (hasAerosol(i,k,m)) then + !Curvature-parameter "A" in ARGI (eqn 5) a = surften_coef/tair(i,k) - !standard factor for transforming size distr - !volume ==> number (google psd.pdf by zender) - exp45logsig_var = & - exp(4.5_r8*lnsigma(i,k,m)*lnsigma(i,k,m)) - - !Numbe rmedian radius (power of three) - !By definition of lognormal distribution - amcube =(3._r8*volumeConcentration(i,k,m) & - /(4._r8*pi*exp45logsig_var*numberConcentration(i,k,m))) ! only if variable size dist + !standard factor for transforming size distr, volume ==> number (google psd.pdf by zender) + exp45logsig_var = exp(4.5_r8*lnsigma(i,k,m)*lnsigma(i,k,m)) + ! Numbe rmedian radius (power of three) + ! By definition of lognormal distribution only if variable size dist + amcube =(3._r8*volumeConcentration(i,k,m) /(4._r8*pi*exp45logsig_var*numberConcentration(i,k,m))) - !This is part of eqn 9 in ARGII - !where A smcoefcoef is 2/3^(3/2) + !This is part of eqn 9 in ARGII where A smcoefcoef is 2/3^(3/2) smcoef = smcoefcoef * a * sqrt(a) - !This is finally solving eqn 9 - !(solve for critical supersat of mode) - sm=smcoef & - / sqrt(hygroscopicity(i,k,m)*amcube) ! critical supersaturation + !This is finally solving eqn 9 (solve for critical supersat of mode) + sm = smcoef / sqrt(hygroscopicity(i,k,m)*amcube) ! critical supersaturation !Solve eqn 13 in ARGII do lsat = 1,psat !eqn 15 in ARGII - argfactor=twothird/(sq2*lnSigma(i,k,m)) + argfactor = twothird/(sq2*lnSigma(i,k,m)) !eqn 15 in ARGII - arg=argfactor*log(sm/super(lsat)) + arg = argfactor*log(sm/super(lsat)) !eqn 13 i ARGII - ccn(i,k,lsat)=ccn(i,k,lsat) & - +numberConcentration(i,k,m)& - *0.5_r8*(1._r8-erf(arg)) + ccn(i,k,lsat) = ccn(i,k,lsat) + numberConcentration(i,k,m)*0.5_r8*(1._r8-erf(arg)) end do end if @@ -2119,8 +2027,8 @@ subroutine ccncalc_oslo(state & end do end do - ccn(:ncol,:,:) = ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 + ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 end subroutine ccncalc_oslo -end module ndrop +end module oslo_aero_ndrop diff --git a/src/physics/cam_oslo/microp_aero.F90 b/src/physics/cam_oslo/microp_aero.F90 index 95b5640d52..fecdb4f69f 100644 --- a/src/physics/cam_oslo/microp_aero.F90 +++ b/src/physics/cam_oslo/microp_aero.F90 @@ -32,7 +32,7 @@ module microp_aero use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field use phys_control, only: phys_getopts, use_hetfrz_classnuc use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, rad_cnst_get_mode_num - use ndrop, only: ndrop_init, dropmixnuc + use oslo_aero_ndrop, only: ndrop_init_oslo, dropmixnuc_oslo use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn use cam_history, only: addfld, add_default, outfld use cam_logfile, only: iulog @@ -187,7 +187,7 @@ subroutine microp_aero_init cldo_idx = pbuf_get_index('CLDO') clim_modal_aero = .true. !Needed to avoid ending up in BAM routines - call ndrop_init() + call ndrop_init_oslo() call addfld('LCLOUD', (/ 'lev' /), 'A', ' ', 'Liquid cloud fraction used in stratus activation') call addfld('WSUB', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity' ) @@ -485,7 +485,7 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) ! If not using preexsiting ice, then only use cloudbourne aerosol for the ! liquid clouds. This is the same behavior as CAM5. if (use_preexisting_ice) then - call dropmixnuc( & + call dropmixnuc_oslo( & state1, ptend_loc, deltatin, pbuf, wsub, & ! Input cldn, cldo, cldliqf, & hasAerosol, & @@ -500,7 +500,7 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) else ! Note difference in arguments lcldn, lcldo cldliqf = 1._r8 - call dropmixnuc( & + call dropmixnuc_oslo( & state1, ptend_loc, deltatin, pbuf, wsub, & ! Input lcldn, lcldo, cldliqf, & hasAerosol, & From ac2a141c2c69b23085da1999ff57f43cb27086ad Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 31 Aug 2023 11:15:33 +0200 Subject: [PATCH 32/71] introduced oslo_aero_dust_sediment.F90 as a refactored copy of dust_sediment.F90 --- src/chemistry/oslo_aero/oslo_aero_depos.F90 | 84 ++- .../oslo_aero/oslo_aero_dust_sediment.F90 | 424 +++++++++++++++ src/physics/cam_oslo/dust_sediment_mod.F90 | 506 ------------------ 3 files changed, 461 insertions(+), 553 deletions(-) create mode 100644 src/chemistry/oslo_aero/oslo_aero_dust_sediment.F90 delete mode 100644 src/physics/cam_oslo/dust_sediment_mod.F90 diff --git a/src/chemistry/oslo_aero/oslo_aero_depos.F90 b/src/chemistry/oslo_aero/oslo_aero_depos.F90 index 8987c1551c..21201d4d88 100644 --- a/src/chemistry/oslo_aero/oslo_aero_depos.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_depos.F90 @@ -5,26 +5,26 @@ module oslo_aero_depos ! deposition at the surface into the fields passed to the coupler. !------------------------------------------------------------------------------------------------ - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver, pverp, begchunk, endchunk - use constituents, only: pcnst, cnst_name - use phys_control, only: phys_getopts - use cam_abortutils, only: endrun - use camsrfexch, only: cam_in_t, cam_out_t - use time_manager, only: is_first_step - use aerodep_flx, only: aerodep_flx_prescribed - use mo_drydep, only: n_land_type, fraction_landuse - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_get_field, pbuf_get_index - use physconst, only: gravit, rair, rhoh2o, boltz, pi - use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only - use ref_pres, only: top_lev => clim_modal_aero_top_lev - use drydep_mod, only: d3ddflux, calcram - use wetdep, only: wetdepa_v2, wetdep_inputs_set, wetdep_inputs_t - use dust_sediment_mod, only: dust_sediment_tend, dust_sediment_vel + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols, pver, pverp, begchunk, endchunk + use constituents, only: pcnst, cnst_name + use phys_control, only: phys_getopts + use cam_abortutils, only: endrun + use camsrfexch, only: cam_in_t, cam_out_t + use time_manager, only: is_first_step + use aerodep_flx, only: aerodep_flx_prescribed + use mo_drydep, only: n_land_type, fraction_landuse + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_get_field, pbuf_get_index + use physconst, only: gravit, rair, rhoh2o, boltz, pi + use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only + use ref_pres, only: top_lev => clim_modal_aero_top_lev + use drydep_mod, only: calcram + use wetdep, only: wetdepa_v2, wetdep_inputs_set, wetdep_inputs_t ! - ! use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac - ! use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 + ! use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac + ! use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 + use oslo_aero_dust_sediment, only: oslo_aero_dust_sediment_tend, oslo_aero_dust_sediment_vel use aerosoldef use commondefinitions @@ -276,8 +276,8 @@ subroutine oslo_aero_depos_dry ( state, pbuf, obklen, ustar, cam_in, dt, cam_ou aerdepdrycw(:,:)=0._r8 ! calc ram and fv over ocean and sea ice ... - call calcram( ncol,landfrac,icefrac,ocnfrac,obklen,& - ustar,ram1in,ram1,state%t(:,pver),state%pmid(:,pver),& + call calcram( ncol,landfrac,icefrac,ocnfrac,obklen, & + ustar,ram1in,ram1,state%t(:,pver),state%pmid(:,pver), & state%pdel(:,pver),fvin,fv) call outfld( 'airFV', fv(:), pcols, lchnk ) @@ -388,19 +388,14 @@ subroutine oslo_aero_depos_dry ( state, pbuf, obklen, ustar, cam_in, dt, cam_ou call outfld( trim(cnst_name(mm))//'DDV', pvmzaer(:,2:pverp), pcols, lchnk ) - if(.true.) then ! use phil's method - ! convert from meters/sec to pascals/sec, use density from layer above in conversion - pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit - - ! calculate the tendencies and sfc fluxes from the above velocities - call dust_sediment_tend( & - ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, interfaceTendToLowestLayer ) - else - ! use charlie's method - call d3ddflux( ncol, vlc_dry(:,:,jvlc), state%q(:,:,mm), state%pmid, & - state%pdel, tvs, sflx, ptend%q(:,:,mm), dt ) - endif + ! use phil's method + ! convert from meters/sec to pascals/sec, use density from layer above in conversion + pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit + + ! calculate the tendencies and sfc fluxes from the above velocities + call oslo_aero_dust_sediment_tend(ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & + state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, & + dusttend_to_ll_out=interfaceTendToLowestLayer) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%%%%% FIX FOR SHORT DRYDEP LIFE-TIMES @@ -474,19 +469,14 @@ subroutine oslo_aero_depos_dry ( state, pbuf, obklen, ustar, cam_in, dt, cam_ou pvmzaer(:ncol,1)=0._r8 pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) - if(.true.) then ! use phil's method - ! convert from meters/sec to pascals/sec - ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion - pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit - - ! calculate the tendencies and sfc fluxes from the above velocities - call dust_sediment_tend( & - ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - fldcw(:,:), pvmzaer, dqdt_tmp(:,:), sflx ) - else !use charlie's method - call d3ddflux( ncol, vlc_dry(:,:,jvlc), fldcw(:,:), state%pmid, & - state%pdel, tvs, sflx, dqdt_tmp(:,:), dt ) - endif + ! Hardwire the method from Phil + ! convert from meters/sec to pascals/sec + ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion + pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit + + ! calculate the tendencies and sfc fluxes from the above velocities + call oslo_aero_dust_sediment_tend(ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t, & + fldcw(:,:), pvmzaer, dqdt_tmp(:,:), sflx) ! apportion dry deposition into turb and gravitational settling for tapes dep_trb = 0._r8 diff --git a/src/chemistry/oslo_aero/oslo_aero_dust_sediment.F90 b/src/chemistry/oslo_aero/oslo_aero_dust_sediment.F90 new file mode 100644 index 0000000000..a2e305109c --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_aero_dust_sediment.F90 @@ -0,0 +1,424 @@ +module oslo_aero_dust_sediment + + !--------------------------------------------------------------------------------- + ! Routines to compute tendencies from sedimentation of dust + ! Author: Phil Rasch + !--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8=>shr_kind_r8 + use ppgrid, only: pcols, pver, pverp + use physconst, only: gravit, rair + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + + implicit none + private + + ! public routines + public :: oslo_aero_dust_sediment_vel + public :: oslo_aero_dust_sediment_tend + + ! private routines + private :: getflx + private :: cfint2 + private :: cfdotmc_pro + + real (r8), parameter :: vland = 2.8_r8 ! dust fall velocity over land (cm/s) + real (r8), parameter :: vocean = 1.5_r8 ! dust fall velocity over ocean (cm/s) + real (r8), parameter :: mxsedfac = 0.99_r8 ! maximum sedimentation flux factor + +!=============================================================================== +contains +!=============================================================================== + + subroutine oslo_aero_dust_sediment_vel(ncol, icefrac, landfrac, ocnfrac, pmid, pdel, t, dustmr, pvdust) + + ! Compute gravitational sedimentation velocities for dust + ! note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) + + ! Arguments + integer, intent(in) :: ncol ! number of colums to process + real(r8), intent(in) :: icefrac (pcols) ! sea ice fraction (fraction) + real(r8), intent(in) :: landfrac(pcols) ! land fraction (fraction) + real(r8), intent(in) :: ocnfrac (pcols) ! ocean fraction (fraction) + real(r8), intent(in) :: pmid(pcols,pver) ! pressure of midpoint levels (Pa) + real(r8), intent(in) :: pdel(pcols,pver) ! pressure diff across layer (Pa) + real(r8), intent(in) :: t(pcols,pver) ! temperature (K) + real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) + real(r8), intent(out) :: pvdust (pcols,pverp) ! vertical velocity of dust (Pa/s) + + ! Local variables + real (r8) :: rho(pcols,pver) ! air density in kg/m3 + real (r8) :: vfall(pcols) ! settling velocity of dust particles (m/s) + integer :: i,k + real (r8) :: lbound, ac, bc, cc + + ! dust fall velocity + do k = 1,pver + do i = 1,ncol + ! merge the dust fall velocities for land and ocean (cm/s) SHOULD ALSO ACCOUNT FOR ICEFRAC + vfall(i) = vland*landfrac(i) + vocean*(1._r8-landfrac(i)) + + ! fall velocity (assume positive downward) + pvdust(i,k+1) = vfall(i) + end do + end do + end subroutine oslo_aero_dust_sediment_vel + + !=============================================================================== + subroutine oslo_aero_dust_sediment_tend ( ncol, dtime, pint, pmid, pdel, t, & + dustmr, pvdust, dusttend, sfdust, dusttend_to_ll_out ) + + !---------------------------------------------------------------------- + ! Apply Particle Gravitational Sedimentation + ! -> note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) + !---------------------------------------------------------------------- + + ! Arguments + integer, intent(in) :: ncol ! number of colums to process + real(r8), intent(in) :: dtime ! time step + real(r8), intent(in) :: pint(pcols,pverp) ! interfaces pressure (Pa) + real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressures (Pa) + real(r8), intent(in) :: pdel(pcols,pver) ! pressure diff across layer (Pa) + real(r8), intent(in) :: t(pcols,pver) ! temperature (K) + real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) + real(r8), intent(in) :: pvdust (pcols,pverp) ! vertical velocity of dust drops (Pa/s) + real(r8), intent(out) :: dusttend(pcols,pver) ! dust tend + real(r8), intent(out) :: sfdust(pcols) ! surface flux of dust (rain, kg/m/s) + real(r8),intent(out),optional :: dusttend_to_ll_out(pcols) ! fluxes at the interfaces, dust (positive = down + + ! Local variables + integer :: i,k + real(r8) :: fxdust(pcols,pverp) ! fluxes at the interfaces, dust (positive = down) + !---------------------------------------------------------------------- + + ! initialize variables + fxdust (:ncol,:) = 0._r8 ! flux at interfaces (dust) + dusttend(:ncol,:) = 0._r8 ! tend (dust) + sfdust(:ncol) = 0._r8 ! sedimentation flux out bot of column (dust) + + ! fluxes at interior points + call getflx(ncol, pint, dustmr, pvdust, dtime, fxdust) + + ! calculate fluxes at boundaries + do i = 1,ncol + fxdust(i,1) = 0 + ! surface flux by upstream scheme + fxdust(i,pverp) = dustmr(i,pver) * pvdust(i,pverp) * dtime + end do + + ! filter out any negative fluxes from the getflx routine + do k = 2,pver + fxdust(:ncol,k) = max(0._r8, fxdust(:ncol,k)) + end do + + ! Limit the flux out of the bottom of each cell to the water content in each phase. + ! Apply mxsedfac to prevent generating very small negative cloud water/ice + ! NOTE, REMOVED CLOUD FACTOR FROM AVAILABLE WATER. ALL CLOUD WATER IS IN CLOUDS. + ! ***Should we include the flux in the top, to allow for thin surface layers? + ! ***Requires simple treatment of cloud overlap, already included below. + do k = 1,pver + do i = 1,ncol + fxdust(i,k+1) = min( fxdust(i,k+1), mxsedfac * dustmr(i,k) * pdel(i,k) ) + end do + end do + + ! Now calculate the tendencies + do k = 1,pver + do i = 1,ncol + ! net flux into cloud changes cloud dust/ice (all flux is out of cloud) + dusttend(i,k) = (fxdust(i,k) - fxdust(i,k+1)) / (dtime * pdel(i,k)) + end do + end do + + ! convert flux out the bottom to mass units Pa -> kg/m2/s + sfdust(:ncol) = fxdust(:ncol,pverp) / (dtime*gravit) + + ! fluxes at the interface + if(present(dusttend_to_ll_out))then + dusttend_to_ll_out(1:ncol) = fxdust(:ncol,pver)/(dtime*pdel(:ncol,pver)) + end if + + end subroutine oslo_aero_dust_sediment_tend + + !=============================================================================== + subroutine getflx(ncol, xw, phi, vel, deltat, flux) + + !.....xw1.......xw2.......xw3.......xw4.......xw5.......xw6 + !....psiw1.....psiw2.....psiw3.....psiw4.....psiw5.....psiw6 + !....velw1.....velw2.....velw3.....velw4.....velw5.....velw6 + !.........phi1......phi2.......phi3.....phi4.......phi5....... + + ! arguments + integer , intent(in) :: ncol ! number of colums to process + real(r8), intent(out) :: flux(pcols,pverp) + real(r8), intent(in) :: xw(pcols,pverp) + real(r8), intent(in) :: vel(pcols,pverp) + real(r8), intent(in) :: deltat + + ! local variables + integer :: i + integer :: k + real (r8) :: psi(pcols,pverp) + real (r8) :: phi(pcols,pverp-1) + real (r8) :: fdot(pcols,pverp) + real (r8) :: xx(pcols) + real (r8) :: fxdot(pcols) + real (r8) :: fxdd(pcols) + real (r8) :: psistar(pcols) + real (r8) :: xxk(pcols,pver) + + do i = 1,ncol + ! integral of phi + psi(i,1) = 0._r8 + ! fluxes at boundaries + flux(i,1) = 0 + flux(i,pverp) = 0._r8 + end do + + ! integral function + do k = 2,pverp + do i = 1,ncol + psi(i,k) = phi(i,k-1)*(xw(i,k)-xw(i,k-1)) + psi(i,k-1) + end do + end do + + ! calculate the derivatives for the interpolating polynomial + call cfdotmc_pro (ncol, xw, psi, fdot) + + ! calculate fluxes at interior pts + do k = 2,pver + do i = 1,ncol + xxk(i,k) = xw(i,k)-vel(i,k)*deltat + end do + end do + do k = 2,pver + call cfint2(ncol, xw, psi, fdot, xxk(1,k), fxdot, fxdd, psistar) + do i = 1,ncol + flux(i,k) = (psi(i,k)-psistar(i)) + end do + end do + + end subroutine getflx + + !=============================================================================== + subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) + + ! arguments + integer , intent(in) :: ncol ! number of colums to process + real (r8) , intent(in) :: x(pcols, pverp) + real (r8) , intent(in) :: f(pcols, pverp) + real (r8) , intent(out) :: fdot(pcols, pverp) + real (r8) , intent(in) :: xin(pcols) + real (r8) , intent(out) :: fxdot(pcols) + real (r8) , intent(out) :: fxdd(pcols) + real (r8) , intent(out) :: psistar(pcols) + + ! local variables + integer :: i + integer :: k + integer :: intz(pcols) + real (r8) :: dx + real (r8) :: s + real (r8) :: c2 + real (r8) :: c3 + real (r8) :: xx + real (r8) :: xinf + real (r8) :: psi1, psi2, psi3, psim + real (r8) :: cfint + real (r8) :: cfnew + real (r8) :: xins(pcols) + real (r8) :: a, b, c ! the minmod function + real (r8) :: minmod ! the minmod function + real (r8) :: medan ! the minmod function + + minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) + medan(a,b,c) = a + minmod(b-a,c-a) + + do i = 1,ncol + xins(i) = medan(x(i,1), xin(i), x(i,pverp)) + intz(i) = 0 + end do + + ! first find the interval + do k = 1,pverp-1 + do i = 1,ncol + if ((xins(i)-x(i,k))*(x(i,k+1)-xins(i)).ge.0._r8) then + intz(i) = k + endif + end do + end do + + do i = 1,ncol + if (intz(i).eq.0) then + write(iulog,*) ' interval was not found for col i ', i + call endrun('DUST_SEDIMENT_MOD:cfint2 -- interval was not found ') + endif + end do + + ! now interpolate + do i = 1,ncol + k = intz(i) + dx = (x(i,k+1)-x(i,k)) + s = (f(i,k+1)-f(i,k))/dx + c2 = (3*s-2*fdot(i,k)-fdot(i,k+1))/dx + c3 = (fdot(i,k)+fdot(i,k+1)-2*s)/dx**2 + xx = (xins(i)-x(i,k)) + fxdot(i) = (3*c3*xx + 2*c2)*xx + fdot(i,k) + fxdd(i) = 6*c3*xx + 2*c2 + cfint = ((c3*xx + c2)*xx + fdot(i,k))*xx + f(i,k) + + ! limit the interpolant + psi1 = f(i,k)+(f(i,k+1)-f(i,k))*xx/dx + if (k.eq.1) then + psi2 = f(i,1) + else + psi2 = f(i,k) + (f(i,k)-f(i,k-1))*xx/(x(i,k)-x(i,k-1)) + endif + if (k+1.eq.pverp) then + psi3 = f(i,pverp) + else + psi3 = f(i,k+1) - (f(i,k+2)-f(i,k+1))*(dx-xx)/(x(i,k+2)-x(i,k+1)) + endif + psim = medan(psi1, psi2, psi3) + cfnew = medan(cfint, psi1, psim) + if (abs(cfnew-cfint)/(abs(cfnew)+abs(cfint)+1.e-36_r8) .gt..03_r8) then + endif + psistar(i) = cfnew + end do + + end subroutine cfint2 + + !=============================================================================== + subroutine cfdotmc_pro (ncol, x, f, fdot) + + ! prototype version; eventually replace with final SPITFIRE scheme + ! calculate the derivative for the interpolating polynomial multi column version + ! assumed variable distribution + + ! x1.......x2.......x3.......x4.......x5.......x6 1,pverp points + ! f1.......f2.......f3.......f4.......f5.......f6 1,pverp points + ! ...sh1.......sh2......sh3......sh4......sh5.... 1,pver points + ! .........d2.......d3.......d4.......d5......... 2,pver points + ! .........s2.......s3.......s4.......s5......... 2,pver points + ! .............dh2......dh3......dh4............. 2,pver-1 points + ! .............eh2......eh3......eh4............. 2,pver-1 points + ! ..................e3.......e4.................. 3,pver-1 points + ! .................ppl3......ppl4................ 3,pver-1 points + ! .................ppr3......ppr4................ 3,pver-1 points + ! .................t3........t4.................. 3,pver-1 points + ! ................fdot3.....fdot4................ 3,pver-1 points + + + ! arguments + integer , intent(in) :: ncol ! number of colums to process + real (r8) , intent(in) :: x(pcols, pverp) + real (r8) , intent(in) :: f(pcols, pverp) + real (r8) , intent(out) :: fdot(pcols, pverp) ! derivative at nodes + + ! local variables + integer :: i,k + real(r8) :: a,b,c ! work vars + real(r8) :: s(pcols,pverp) ! first divided differences at nodes + real(r8) :: sh(pcols,pverp) ! first divided differences between nodes + real(r8) :: d(pcols,pverp) ! second divided differences at nodes + real(r8) :: dh(pcols,pverp) ! second divided differences between nodes + real(r8) :: e(pcols,pverp) ! third divided differences at nodes + real(r8) :: eh(pcols,pverp) ! third divided differences between nodes + real(r8) :: pp ! p prime + real(r8) :: ppl(pcols,pverp) ! p prime on left + real(r8) :: ppr(pcols,pverp) ! p prime on right + real(r8) :: qpl + real(r8) :: qpr + real(r8) :: ttt + real(r8) :: t + real(r8) :: tmin + real(r8) :: tmax + real(r8) :: delxh(pcols,pverp) + real(r8) :: minmod ! the minmod function + real(r8) :: medan ! the minmod function + + minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) + medan(a,b,c) = a + minmod(b-a,c-a) + + do k = 1,pver + ! first divided differences between nodes + do i = 1, ncol + delxh(i,k) = (x(i,k+1)-x(i,k)) + sh(i,k) = (f(i,k+1)-f(i,k))/delxh(i,k) + end do + + ! first and second divided differences at nodes + if (k.ge.2) then + do i = 1,ncol + d(i,k) = (sh(i,k)-sh(i,k-1))/(x(i,k+1)-x(i,k-1)) + s(i,k) = minmod(sh(i,k),sh(i,k-1)) + end do + endif + end do + + ! second and third divided diffs between nodes + do k = 2,pver-1 + do i = 1, ncol + eh(i,k) = (d(i,k+1)-d(i,k))/(x(i,k+2)-x(i,k-1)) + dh(i,k) = minmod(d(i,k),d(i,k+1)) + end do + end do + + ! treat the boundaries + do i = 1,ncol + e(i,2) = eh(i,2) + e(i,pver) = eh(i,pver-1) + ! outside level + fdot(i,1) = sh(i,1) - d(i,2)*delxh(i,1) - eh(i,2)*delxh(i,1)*(x(i,1)-x(i,3)) + fdot(i,1) = minmod(fdot(i,1),3*sh(i,1)) + fdot(i,pverp) = sh(i,pver) + d(i,pver)*delxh(i,pver) + eh(i,pver-1)*delxh(i,pver)*(x(i,pverp)-x(i,pver-1)) + fdot(i,pverp) = minmod(fdot(i,pverp),3*sh(i,pver)) + + ! one in from boundary + fdot(i,2) = sh(i,1) + d(i,2)*delxh(i,1) - eh(i,2)*delxh(i,1)*delxh(i,2) + fdot(i,2) = minmod(fdot(i,2),3*s(i,2)) + fdot(i,pver) = sh(i,pver) - d(i,pver)*delxh(i,pver) - eh(i,pver-1)*delxh(i,pver)*delxh(i,pver-1) + fdot(i,pver) = minmod(fdot(i,pver),3*s(i,pver)) + end do + + do k = 3,pver-1 + do i = 1,ncol + e(i,k) = minmod(eh(i,k),eh(i,k-1)) + end do + end do + + do k = 3,pver-1 + do i = 1,ncol + ! p prime at k-0.5 + ppl(i,k)=sh(i,k-1) + dh(i,k-1)*delxh(i,k-1) + + ! p prime at k+0.5 + ppr(i,k)=sh(i,k) - dh(i,k) *delxh(i,k) + t = minmod(ppl(i,k),ppr(i,k)) + + ! derivate from parabola thru f(i,k-1), f(i,k), and f(i,k+1) + pp = sh(i,k-1) + d(i,k)*delxh(i,k-1) + + ! quartic estimate of fdot + fdot(i,k) = pp - delxh(i,k-1)*delxh(i,k)*(eh(i,k-1)*(x(i,k+2)-x(i,k)) & + + eh(i,k )*(x(i,k )-x(i,k-2)))/(x(i,k+2)-x(i,k-2)) + + ! now limit it + qpl = sh(i,k-1) + delxh(i,k-1)*minmod(d(i,k-1)+ e(i,k-1)*(x(i,k)-x(i,k-2)), & + d(i,k) - e(i,k)*delxh(i,k)) + qpr = sh(i,k) + delxh(i,k )*minmod(d(i,k) + e(i,k)*delxh(i,k-1), & + d(i,k+1)+e(i,k+1)*(x(i,k)-x(i,k+2))) + + fdot(i,k) = medan(fdot(i,k), qpl, qpr) + + ttt = minmod(qpl, qpr) + tmin = min(0._r8,3*s(i,k),1.5_r8*t,ttt) + tmax = max(0._r8,3*s(i,k),1.5_r8*t,ttt) + fdot(i,k) = fdot(i,k) + minmod(tmin-fdot(i,k), tmax-fdot(i,k)) + end do + end do + + end subroutine cfdotmc_pro + +end module oslo_aero_dust_sediment diff --git a/src/physics/cam_oslo/dust_sediment_mod.F90 b/src/physics/cam_oslo/dust_sediment_mod.F90 deleted file mode 100644 index 09bd7dcefa..0000000000 --- a/src/physics/cam_oslo/dust_sediment_mod.F90 +++ /dev/null @@ -1,506 +0,0 @@ -module dust_sediment_mod - -!--------------------------------------------------------------------------------- -! Purpose: -! -! Contains routines to compute tendencies from sedimentation of dust -! -! Author: Phil Rasch -! -!--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8=>shr_kind_r8 - use ppgrid, only: pcols, pver, pverp - use physconst, only: gravit, rair - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - - private - public :: dust_sediment_vel, dust_sediment_tend - - - real (r8), parameter :: vland = 2.8_r8 ! dust fall velocity over land (cm/s) - real (r8), parameter :: vocean = 1.5_r8 ! dust fall velocity over ocean (cm/s) - real (r8), parameter :: mxsedfac = 0.99_r8 ! maximum sedimentation flux factor - -contains - -!=============================================================================== - subroutine dust_sediment_vel (ncol, & - icefrac , landfrac, ocnfrac , pmid , pdel , t , & - dustmr , pvdust ) - -!---------------------------------------------------------------------- - -! Compute gravitational sedimentation velocities for dust - - implicit none - -! Arguments - integer, intent(in) :: ncol ! number of colums to process - - real(r8), intent(in) :: icefrac (pcols) ! sea ice fraction (fraction) - real(r8), intent(in) :: landfrac(pcols) ! land fraction (fraction) - real(r8), intent(in) :: ocnfrac (pcols) ! ocean fraction (fraction) - real(r8), intent(in) :: pmid (pcols,pver) ! pressure of midpoint levels (Pa) - real(r8), intent(in) :: pdel (pcols,pver) ! pressure diff across layer (Pa) - real(r8), intent(in) :: t (pcols,pver) ! temperature (K) - real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) - - real(r8), intent(out) :: pvdust (pcols,pverp) ! vertical velocity of dust (Pa/s) -! -> note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) - -! Local variables - real (r8) :: rho(pcols,pver) ! air density in kg/m3 - real (r8) :: vfall(pcols) ! settling velocity of dust particles (m/s) - - integer i,k - - real (r8) :: lbound, ac, bc, cc - -!----------------------------------------------------------------------- -!--------------------- dust fall velocity ---------------------------- -!----------------------------------------------------------------------- - - do k = 1,pver - do i = 1,ncol - - ! merge the dust fall velocities for land and ocean (cm/s) - ! SHOULD ALSO ACCOUNT FOR ICEFRAC - vfall(i) = vland*landfrac(i) + vocean*(1._r8-landfrac(i)) - !! vfall(i) = vland*landfrac(i) + vocean*ocnfrac(i) + vseaice*icefrac(i) - - ! fall velocity (assume positive downward) - pvdust(i,k+1) = vfall(i) - end do - end do - - return - end subroutine dust_sediment_vel - - -!=============================================================================== - subroutine dust_sediment_tend ( & - ncol, dtime, pint, pmid, pdel, t, & - dustmr ,pvdust, dusttend, sfdust, dusttend_to_ll_out ) - -!---------------------------------------------------------------------- -! Apply Particle Gravitational Sedimentation -!---------------------------------------------------------------------- - - implicit none - -! Arguments - integer, intent(in) :: ncol ! number of colums to process - - real(r8), intent(in) :: dtime ! time step - real(r8), intent(in) :: pint (pcols,pverp) ! interfaces pressure (Pa) - real(r8), intent(in) :: pmid (pcols,pver) ! midpoint pressures (Pa) - real(r8), intent(in) :: pdel (pcols,pver) ! pressure diff across layer (Pa) - real(r8), intent(in) :: t (pcols,pver) ! temperature (K) - real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) - real(r8), intent(in) :: pvdust (pcols,pverp) ! vertical velocity of dust drops (Pa/s) -! -> note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) - - real(r8), intent(out) :: dusttend(pcols,pver) ! dust tend - real(r8), intent(out) :: sfdust (pcols) ! surface flux of dust (rain, kg/m/s) - - real(r8),intent(out),optional :: dusttend_to_ll_out(pcols) ! fluxes at the interfaces, dust (positive = down) -! Local variables - real(r8) :: fxdust(pcols,pverp) ! fluxes at the interfaces, dust (positive = down) - - integer :: i,k -!---------------------------------------------------------------------- - -! initialize variables - fxdust (:ncol,:) = 0._r8 ! flux at interfaces (dust) - dusttend(:ncol,:) = 0._r8 ! tend (dust) - sfdust(:ncol) = 0._r8 ! sedimentation flux out bot of column (dust) - -! fluxes at interior points - call getflx(ncol, pint, dustmr, pvdust, dtime, fxdust) - -! calculate fluxes at boundaries - do i = 1,ncol - fxdust(i,1) = 0 -! surface flux by upstream scheme - fxdust(i,pverp) = dustmr(i,pver) * pvdust(i,pverp) * dtime - end do - -! filter out any negative fluxes from the getflx routine - do k = 2,pver - fxdust(:ncol,k) = max(0._r8, fxdust(:ncol,k)) - end do - -! Limit the flux out of the bottom of each cell to the water content in each phase. -! Apply mxsedfac to prevent generating very small negative cloud water/ice -! NOTE, REMOVED CLOUD FACTOR FROM AVAILABLE WATER. ALL CLOUD WATER IS IN CLOUDS. -! ***Should we include the flux in the top, to allow for thin surface layers? -! ***Requires simple treatment of cloud overlap, already included below. - do k = 1,pver - do i = 1,ncol - fxdust(i,k+1) = min( fxdust(i,k+1), mxsedfac * dustmr(i,k) * pdel(i,k) ) -!!$ fxdust(i,k+1) = min( fxdust(i,k+1), dustmr(i,k) * pdel(i,k) + fxdust(i,k)) - end do - end do - -! Now calculate the tendencies - do k = 1,pver - do i = 1,ncol -! net flux into cloud changes cloud dust/ice (all flux is out of cloud) - dusttend(i,k) = (fxdust(i,k) - fxdust(i,k+1)) / (dtime * pdel(i,k)) - end do - end do - -! convert flux out the bottom to mass units Pa -> kg/m2/s - sfdust(:ncol) = fxdust(:ncol,pverp) / (dtime*gravit) - - if(present(dusttend_to_ll_out))then - dusttend_to_ll_out(1:ncol) = fxdust(:ncol,pver)/(dtime*pdel(:ncol,pver)) - endif - - return - end subroutine dust_sediment_tend - -!=============================================================================== - subroutine getflx(ncol, xw, phi, vel, deltat, flux) - -!.....xw1.......xw2.......xw3.......xw4.......xw5.......xw6 -!....psiw1.....psiw2.....psiw3.....psiw4.....psiw5.....psiw6 -!....velw1.....velw2.....velw3.....velw4.....velw5.....velw6 -!.........phi1......phi2.......phi3.....phi4.......phi5....... - - - implicit none - - integer ncol ! number of colums to process - - integer i - integer k - - real (r8) vel(pcols,pverp) - real (r8) flux(pcols,pverp) - real (r8) xw(pcols,pverp) - real (r8) psi(pcols,pverp) - real (r8) phi(pcols,pverp-1) - real (r8) fdot(pcols,pverp) - real (r8) xx(pcols) - real (r8) fxdot(pcols) - real (r8) fxdd(pcols) - - real (r8) psistar(pcols) - real (r8) deltat - - real (r8) xxk(pcols,pver) - - do i = 1,ncol -! integral of phi - psi(i,1) = 0._r8 -! fluxes at boundaries - flux(i,1) = 0 - flux(i,pverp) = 0._r8 - end do - -! integral function - do k = 2,pverp - do i = 1,ncol - psi(i,k) = phi(i,k-1)*(xw(i,k)-xw(i,k-1)) + psi(i,k-1) - end do - end do - - -! calculate the derivatives for the interpolating polynomial - call cfdotmc_pro (ncol, xw, psi, fdot) - -! NEW WAY -! calculate fluxes at interior pts - do k = 2,pver - do i = 1,ncol - xxk(i,k) = xw(i,k)-vel(i,k)*deltat - end do - end do - do k = 2,pver - call cfint2(ncol, xw, psi, fdot, xxk(1,k), fxdot, fxdd, psistar) - do i = 1,ncol - flux(i,k) = (psi(i,k)-psistar(i)) - end do - end do - - - return - end subroutine getflx - - - -!############################################################################## - - subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) - - - implicit none - -! input - integer ncol ! number of colums to process - - real (r8) x(pcols, pverp) - real (r8) f(pcols, pverp) - real (r8) fdot(pcols, pverp) - real (r8) xin(pcols) - -! output - real (r8) fxdot(pcols) - real (r8) fxdd(pcols) - real (r8) psistar(pcols) - - integer i - integer k - integer intz(pcols) - real (r8) dx - real (r8) s - real (r8) c2 - real (r8) c3 - real (r8) xx - real (r8) xinf - real (r8) psi1, psi2, psi3, psim - real (r8) cfint - real (r8) cfnew - real (r8) xins(pcols) - -! the minmod function - real (r8) a, b, c - real (r8) minmod - real (r8) medan - minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) - medan(a,b,c) = a + minmod(b-a,c-a) - - do i = 1,ncol - xins(i) = medan(x(i,1), xin(i), x(i,pverp)) - intz(i) = 0 - end do - -! first find the interval - do k = 1,pverp-1 - do i = 1,ncol - if ((xins(i)-x(i,k))*(x(i,k+1)-xins(i)).ge.0._r8) then - intz(i) = k - endif - end do - end do - - do i = 1,ncol - if (intz(i).eq.0) then - write(iulog,*) ' interval was not found for col i ', i - call endrun('DUST_SEDIMENT_MOD:cfint2 -- interval was not found ') - endif - end do - -! now interpolate - do i = 1,ncol - k = intz(i) - dx = (x(i,k+1)-x(i,k)) - s = (f(i,k+1)-f(i,k))/dx - c2 = (3*s-2*fdot(i,k)-fdot(i,k+1))/dx - c3 = (fdot(i,k)+fdot(i,k+1)-2*s)/dx**2 - xx = (xins(i)-x(i,k)) - fxdot(i) = (3*c3*xx + 2*c2)*xx + fdot(i,k) - fxdd(i) = 6*c3*xx + 2*c2 - cfint = ((c3*xx + c2)*xx + fdot(i,k))*xx + f(i,k) - -! limit the interpolant - psi1 = f(i,k)+(f(i,k+1)-f(i,k))*xx/dx - if (k.eq.1) then - psi2 = f(i,1) - else - psi2 = f(i,k) + (f(i,k)-f(i,k-1))*xx/(x(i,k)-x(i,k-1)) - endif - if (k+1.eq.pverp) then - psi3 = f(i,pverp) - else - psi3 = f(i,k+1) - (f(i,k+2)-f(i,k+1))*(dx-xx)/(x(i,k+2)-x(i,k+1)) - endif - psim = medan(psi1, psi2, psi3) - cfnew = medan(cfint, psi1, psim) - if (abs(cfnew-cfint)/(abs(cfnew)+abs(cfint)+1.e-36_r8) .gt..03_r8) then -! CHANGE THIS BACK LATER!!! -! $ .gt..1) then - - -! UNCOMMENT THIS LATER!!! -! write(iulog,*) ' cfint2 limiting important ', cfint, cfnew - - - endif - psistar(i) = cfnew - end do - - return - end subroutine cfint2 - - - -!############################################################################## - - subroutine cfdotmc_pro (ncol, x, f, fdot) - -! prototype version; eventually replace with final SPITFIRE scheme - -! calculate the derivative for the interpolating polynomial -! multi column version - - - implicit none - -! input - integer ncol ! number of colums to process - - real (r8) x(pcols, pverp) - real (r8) f(pcols, pverp) -! output - real (r8) fdot(pcols, pverp) ! derivative at nodes - -! assumed variable distribution -! x1.......x2.......x3.......x4.......x5.......x6 1,pverp points -! f1.......f2.......f3.......f4.......f5.......f6 1,pverp points -! ...sh1.......sh2......sh3......sh4......sh5.... 1,pver points -! .........d2.......d3.......d4.......d5......... 2,pver points -! .........s2.......s3.......s4.......s5......... 2,pver points -! .............dh2......dh3......dh4............. 2,pver-1 points -! .............eh2......eh3......eh4............. 2,pver-1 points -! ..................e3.......e4.................. 3,pver-1 points -! .................ppl3......ppl4................ 3,pver-1 points -! .................ppr3......ppr4................ 3,pver-1 points -! .................t3........t4.................. 3,pver-1 points -! ................fdot3.....fdot4................ 3,pver-1 points - - -! work variables - - - integer i - integer k - - real (r8) a ! work var - real (r8) b ! work var - real (r8) c ! work var - real (r8) s(pcols,pverp) ! first divided differences at nodes - real (r8) sh(pcols,pverp) ! first divided differences between nodes - real (r8) d(pcols,pverp) ! second divided differences at nodes - real (r8) dh(pcols,pverp) ! second divided differences between nodes - real (r8) e(pcols,pverp) ! third divided differences at nodes - real (r8) eh(pcols,pverp) ! third divided differences between nodes - real (r8) pp ! p prime - real (r8) ppl(pcols,pverp) ! p prime on left - real (r8) ppr(pcols,pverp) ! p prime on right - real (r8) qpl - real (r8) qpr - real (r8) ttt - real (r8) t - real (r8) tmin - real (r8) tmax - real (r8) delxh(pcols,pverp) - - -! the minmod function - real (r8) minmod - real (r8) medan - minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) - medan(a,b,c) = a + minmod(b-a,c-a) - - do k = 1,pver - - -! first divided differences between nodes - do i = 1, ncol - delxh(i,k) = (x(i,k+1)-x(i,k)) - sh(i,k) = (f(i,k+1)-f(i,k))/delxh(i,k) - end do - -! first and second divided differences at nodes - if (k.ge.2) then - do i = 1,ncol - d(i,k) = (sh(i,k)-sh(i,k-1))/(x(i,k+1)-x(i,k-1)) - s(i,k) = minmod(sh(i,k),sh(i,k-1)) - end do - endif - end do - -! second and third divided diffs between nodes - do k = 2,pver-1 - do i = 1, ncol - eh(i,k) = (d(i,k+1)-d(i,k))/(x(i,k+2)-x(i,k-1)) - dh(i,k) = minmod(d(i,k),d(i,k+1)) - end do - end do - -! treat the boundaries - do i = 1,ncol - e(i,2) = eh(i,2) - e(i,pver) = eh(i,pver-1) -! outside level - fdot(i,1) = sh(i,1) - d(i,2)*delxh(i,1) & - - eh(i,2)*delxh(i,1)*(x(i,1)-x(i,3)) - fdot(i,1) = minmod(fdot(i,1),3*sh(i,1)) - fdot(i,pverp) = sh(i,pver) + d(i,pver)*delxh(i,pver) & - + eh(i,pver-1)*delxh(i,pver)*(x(i,pverp)-x(i,pver-1)) - fdot(i,pverp) = minmod(fdot(i,pverp),3*sh(i,pver)) -! one in from boundary - fdot(i,2) = sh(i,1) + d(i,2)*delxh(i,1) - eh(i,2)*delxh(i,1)*delxh(i,2) - fdot(i,2) = minmod(fdot(i,2),3*s(i,2)) - fdot(i,pver) = sh(i,pver) - d(i,pver)*delxh(i,pver) & - - eh(i,pver-1)*delxh(i,pver)*delxh(i,pver-1) - fdot(i,pver) = minmod(fdot(i,pver),3*s(i,pver)) - end do - - - do k = 3,pver-1 - do i = 1,ncol - e(i,k) = minmod(eh(i,k),eh(i,k-1)) - end do - end do - - - - do k = 3,pver-1 - - do i = 1,ncol - -! p prime at k-0.5 - ppl(i,k)=sh(i,k-1) + dh(i,k-1)*delxh(i,k-1) -! p prime at k+0.5 - ppr(i,k)=sh(i,k) - dh(i,k) *delxh(i,k) - - t = minmod(ppl(i,k),ppr(i,k)) - -! derivate from parabola thru f(i,k-1), f(i,k), and f(i,k+1) - pp = sh(i,k-1) + d(i,k)*delxh(i,k-1) - -! quartic estimate of fdot - fdot(i,k) = pp & - - delxh(i,k-1)*delxh(i,k) & - *( eh(i,k-1)*(x(i,k+2)-x(i,k )) & - + eh(i,k )*(x(i,k )-x(i,k-2)) & - )/(x(i,k+2)-x(i,k-2)) - -! now limit it - qpl = sh(i,k-1) & - + delxh(i,k-1)*minmod(d(i,k-1)+e(i,k-1)*(x(i,k)-x(i,k-2)), & - d(i,k) -e(i,k)*delxh(i,k)) - qpr = sh(i,k) & - + delxh(i,k )*minmod(d(i,k) +e(i,k)*delxh(i,k-1), & - d(i,k+1)+e(i,k+1)*(x(i,k)-x(i,k+2))) - - fdot(i,k) = medan(fdot(i,k), qpl, qpr) - - ttt = minmod(qpl, qpr) - tmin = min(0._r8,3*s(i,k),1.5_r8*t,ttt) - tmax = max(0._r8,3*s(i,k),1.5_r8*t,ttt) - - fdot(i,k) = fdot(i,k) + minmod(tmin-fdot(i,k), tmax-fdot(i,k)) - - end do - - end do - - return - end subroutine cfdotmc_pro -end module dust_sediment_mod From cd4b998033806edcd52145d148a5ac8f4b9e9e2c Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 31 Aug 2023 12:59:17 +0200 Subject: [PATCH 33/71] rename condtend to oslo_aero_condtend --- src/chemistry/oslo_aero/aero_model.F90 | 4 +- src/chemistry/oslo_aero/oslo_aero_conc.F90 | 39 +++++--------- .../{condtend.F90 => oslo_aero_condtend.F90} | 51 ++++++++----------- 3 files changed, 36 insertions(+), 58 deletions(-) rename src/chemistry/oslo_aero/{condtend.F90 => oslo_aero_condtend.F90} (97%) diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index b0400dd99b..ef8406b603 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -36,8 +36,8 @@ module aero_model use aerosoldef, only: lifeCycleNumberMedianRadius use aerosoldef, only: getCloudTracerName use aerosoldef, only: aero_register - use condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub - use condtend, only: registerCondensation, initializeCondensation, condtend_sub + use oslo_aero_condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub + use oslo_aero_condtend, only: registerCondensation, initializeCondensation, condtend_sub use sox_cldaero_mod, only: sox_cldaero_init use intlog, only: initlogn use seasalt_model, only: seasalt_init, seasalt_emis, seasalt_active diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 index f02431b929..df46bd47a9 100644 --- a/src/chemistry/oslo_aero/oslo_aero_conc.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_conc.F90 @@ -1,17 +1,15 @@ module oslo_aero_conc - use const , only : volumeToNumber,smallNumber - use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o - use ppgrid , only : pcols, pver - use shr_kind_mod , only: r8 => shr_kind_r8 - use physconst , only: pi - use constituents , only: pcnst, cnst_name + use shr_kind_mod , only: r8 => shr_kind_r8 + use ppgrid , only: pcols, pver + use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o, pi + use constituents , only: pcnst, cnst_name ! - use intlog, only: intlog1to3_sub, intlog4_sub, intlog5to10_sub - use oslo_utils, only: calculateNumberConcentration - use const, only: smallNumber - use oslo_aero_coag, only: normalizedCoagulationSink - use condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV + use intlog, only: intlog1to3_sub, intlog4_sub, intlog5to10_sub + use oslo_utils, only: calculateNumberConcentration + use const, only: smallNumber, volumeToNumber,smallNumber + use oslo_aero_coag, only: normalizedCoagulationSink + use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV use commondefinitions use aerosoldef @@ -99,21 +97,8 @@ subroutine oslo_aero_conc_calc(ncol, mmr, rho_air, CProcessModes, & end subroutine oslo_aero_conc_calc !****************************************************************** - subroutine calculateBulkProperties( & - ncol & - ,qm & !I [kg/kg] transported tracers - ,rho_air & !I [kg/m3] air density - ,numberConcentration & !O [#/m3] - ,CProcessModes & !O [kg/m3] total added material - ,f_c & !O [-] fraction of aerosol which is carbon - ,f_bc & !O [-] fraction of carbon which is bc - ,f_aq & !O [-] fraction of sulfate which is aq. - ,f_so4_cond & !O [-] fraction of non-aq so4 which is condensate - ,f_soa & !O [-] fraction of OM which is SOA - ,f_aitbc & !O [-] fraction of bc in the background tracer mode - ,f_nbc & !O [-] fraction of bc in the background tracer mode 14 - ,f_soana & !O [-] fraction of soa in background int-mix mode (1) - ) + subroutine calculateBulkProperties( ncol, qm, rho_air, numberConcentration, CProcessModes, & + f_c, f_bc, f_aq, f_so4_cond, f_soa, f_aitbc, f_nbc, f_soana) !---------------------------------------------- ! Create bulk properties (dependent on tracers, not size modes) @@ -688,7 +673,7 @@ end subroutine doLognormalInterpolation subroutine modalapp2d(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm,fbcm,faqm,fso4condm,fsoam) ! Calculation of the apportionment of internally mixed SO4, BC and OC - ! mass between the various background mineral and sea-salt modes. + ! mass between the various background mineral and sea-salt modes. ! Now also Aitken-modes are subject to condensation of H2SO4, and both n and ! Aitken modes may coagulate onto the mineral/sea-salt background aerosol. !SOA diff --git a/src/chemistry/oslo_aero/condtend.F90 b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 similarity index 97% rename from src/chemistry/oslo_aero/condtend.F90 rename to src/chemistry/oslo_aero/oslo_aero_condtend.F90 index f0fd96a43f..d9a1575a29 100644 --- a/src/chemistry/oslo_aero/condtend.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 @@ -1,18 +1,25 @@ -module condtend - - use shr_kind_mod, only: r8 => shr_kind_r8 - use phys_control, only: phys_getopts - use chem_mods, only: gas_pcnst - use mo_tracname, only: solsym - use ppgrid, only: pcols, pver, pverp - use const - use cam_history, only: outfld - use aerosoldef - use physconst, only: rair, gravit, pi, avogad - use commondefinitions - use chem_mods, only: adv_mass !molecular weights from mozart +module oslo_aero_condtend + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only : pcols, pver, pverp + use phys_control, only: phys_getopts + use chem_mods, only: gas_pcnst + use mo_tracname, only: solsym + use cam_history, only: addfld, add_default, fieldname_len, horiz_only, outfld + use physconst, only: rair, gravit, pi, avogad + use chem_mods, only: adv_mass !molecular weights from mozart + use wv_saturation, only : qsat_water + use m_spc_id, only : id_H2SO4, id_soa_lv + ! + use oslo_aero_coag, only: normalizedCoagulationSink, receiverMode,numberOfCoagulationReceivers + use oslo_aero_coag, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd + use constituents, only: pcnst ! h2so4 and soa nucleation (cka) + use aerosoldef ! only: MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na + use commondefinitions ! only: originalNumberMedianRadius + use const ! only: volumeToNumber implicit none + private integer, parameter :: N_COND_VAP = 3 integer, parameter :: COND_VAP_H2SO4 = 1 @@ -20,6 +27,7 @@ module condtend integer, parameter :: COND_VAP_ORG_SV = 3 real(r8) , public :: normalizedCondensationSink(0:nmodes,N_COND_VAP) ! [m3/#/s] condensation sink per particle in mode i + integer , private :: lifeCycleReceiver(gas_pcnst) ! [-] array of transformation of life cycle tracers real(r8) , private :: stickingCoefficient(0:nmodes,N_COND_VAP) ! [-] stickingCoefficient for H2SO4 on a mode integer , private :: cond_vap_map(N_COND_VAP) @@ -78,8 +86,6 @@ subroutine initializeCondensation() !Theory: Poling et al, "The properties of gases and liquids" !5th edition, eqn 11-4-4 - use cam_history, only: addfld, add_default, fieldname_len, horiz_only - real(r8), parameter :: aunit = 1.6606e-27_r8 ![kg] Atomic mass unit real(r8), parameter :: boltz = 1.3806e-23_r8 ![J/K/molec] real(r8), parameter :: t0 = 273.15_r8 ![K] standard temperature @@ -250,11 +256,6 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & ! increase in particle radius. Will be improved in future versions of the model ! Added input for h2so4 and soa nucleation: soa_lv_gasprod, soa_sv_gasprod, pblh,zm,qh20 (cka) - use cam_history, only: outfld,fieldname_len - use oslo_aero_coag, only: normalizedCoagulationSink, receiverMode,numberOfCoagulationReceivers - use oslo_aero_coag, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd - use constituents, only: pcnst ! h2so4 and soa nucleation (cka) - ! arguments integer, intent(in) :: lchnk ! chunk identifier integer, intent(in) :: ncol ! number of columns @@ -616,14 +617,6 @@ subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuc ! ACP, vol 14, no 10, pp 5127 http://www.atmos-chem-phys.net/14/5127/2014/acp-14-5127-2014.html ! Modified Spring 2015, cka - use wv_saturation, only : qsat_water - use ppgrid, only : pcols, pver, pverp - use aerosoldef, only : MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na - use commondefinitions, only : originalNumberMedianRadius - use phys_control, only : phys_getopts - use m_spc_id, only : id_H2SO4, id_soa_lv - use const, only : volumeToNumber - !-- Arguments integer, intent(in) :: lchnk ! chunk identifier integer, intent(in) :: ncol ! number of atmospheric column @@ -1021,4 +1014,4 @@ subroutine appformrate(d1, dx, j1, jx, CoagS_dx, gr) end subroutine appformrate -end module condtend +end module oslo_aero_condtend From 06261a35f80131b9cb9bfc1a1ecec24730818893 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 31 Aug 2023 13:42:29 +0200 Subject: [PATCH 34/71] moved condtend.F90 to oslo_aero_condtend and implemented private statements --- src/chemistry/oslo_aero/aero_model.F90 | 96 ++++----- src/chemistry/oslo_aero/intlog.F90 | 4 +- src/chemistry/oslo_aero/oslo_aero_conc.F90 | 18 +- .../oslo_aero/oslo_aero_condtend.F90 | 189 +++++++++--------- 4 files changed, 157 insertions(+), 150 deletions(-) diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index ef8406b603..268bba3dfe 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -3,54 +3,54 @@ !=============================================================================== module aero_model - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst, cnst_name, cnst_get_ind - use ppgrid, only: pcols, pver, pverp - use phys_control, only: phys_getopts, cam_physpkg_is - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use perf_mod, only: t_startf, t_stopf - use camsrfexch, only: cam_in_t, cam_out_t - use aerodep_flx, only: aerodep_flx_prescribed - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc - use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field - use physconst, only: gravit, rair, rhoh2o - use spmd_utils, only: masterproc - use time_manager, only: get_nstep - use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only - use chem_mods, only: gas_pcnst, adv_mass - use mo_tracname, only: solsym - use mo_setsox, only: setsox - use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri - use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx - use ref_pres, only: top_lev => clim_modal_aero_top_lev - use drydep_mod, only: inidrydep - use wetdep, only: wetdep_init + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, cnst_name, cnst_get_ind + use ppgrid, only: pcols, pver, pverp + use phys_control, only: phys_getopts, cam_physpkg_is + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use perf_mod, only: t_startf, t_stopf + use camsrfexch, only: cam_in_t, cam_out_t + use aerodep_flx, only: aerodep_flx_prescribed + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc + use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field + use physconst, only: gravit, rair, rhoh2o + use spmd_utils, only: masterproc + use time_manager, only: get_nstep + use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only + use chem_mods, only: gas_pcnst, adv_mass + use mo_tracname, only: solsym + use mo_setsox, only: setsox + use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri + use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx + use ref_pres, only: top_lev => clim_modal_aero_top_lev + use drydep_mod, only: inidrydep + use wetdep, only: wetdep_init ! - use oslo_aero_depos, only: oslo_aero_depos_init, oslo_aero_depos_dry, oslo_aero_depos_wet - use oslo_aero_coag, only: coagtend, clcoag - use oslo_utils, only: calculateNumberConcentration - use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName - use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers - use aerosoldef, only: lifeCycleNumberMedianRadius - use aerosoldef, only: getCloudTracerName - use aerosoldef, only: aero_register - use oslo_aero_condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4, condtend_sub - use oslo_aero_condtend, only: registerCondensation, initializeCondensation, condtend_sub - use sox_cldaero_mod, only: sox_cldaero_init - use intlog, only: initlogn - use seasalt_model, only: seasalt_init, seasalt_emis, seasalt_active - use dust_model, only: dust_init, dust_emis, dust_active - use oslo_ocean_intr, only: oslo_ocean_init, oslo_dms_emis_intr - use oslo_aero_sw_tables, only: initopt, initopt_lw - use commondefinitions, only: originalSigma, originalNumberMedianRadius - use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes - use const, only: numberToSurface + use oslo_aero_depos, only: oslo_aero_depos_init, oslo_aero_depos_dry, oslo_aero_depos_wet + use oslo_aero_coag, only: coagtend, clcoag + use oslo_utils, only: calculateNumberConcentration + use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName + use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers + use aerosoldef, only: lifeCycleNumberMedianRadius + use aerosoldef, only: getCloudTracerName + use aerosoldef, only: aero_register + use oslo_aero_condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4 + use oslo_aero_condtend, only: registerCondensation, initializeCondensation, condtend + use sox_cldaero_mod, only: sox_cldaero_init + use oslo_aero_interp_log, only: initlogn + use seasalt_model, only: seasalt_init, seasalt_emis, seasalt_active + use dust_model, only: dust_init, dust_emis, dust_active + use oslo_ocean_intr, only: oslo_ocean_init, oslo_dms_emis_intr + use oslo_aero_sw_tables, only: initopt, initopt_lw + use commondefinitions, only: originalSigma, originalNumberMedianRadius + use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes + use const, only: numberToSurface use calcaersize #ifdef AEROCOM - use aerocom_opt_mod, only: initaeropt - use aerocom_dry_mod, only: initdryp + use aerocom_opt_mod, only: initaeropt + use aerocom_dry_mod, only: initdryp #endif implicit none @@ -593,17 +593,17 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ ! Rest of microphysics have pcols dimension mmr_tend_pcols(:ncol,:,:) = mmr_tend_ncols(:ncol,:,:) + ! Condensation ! Note use of "zm" here. In CAM5.3-implementation "zi" was used.. ! zm is passed through the generic interface, and it should not change much ! to check if "zm" is below boundary layer height instead of zi - call condtend_sub( lchnk, mmr_tend_pcols, mmr_cond_vap_gasprod,tfld, pmid, & + call condtend( lchnk, mmr_tend_pcols, mmr_cond_vap_gasprod,tfld, pmid, & pdel, delt, ncol, pblh, zm, qh2o) ! cka - ! coagulation + ! Coagulation ! OS 280415 Concentratiions in cloud water is in vmr space and as a ! temporary variable (vmrcw) Coagulation between aerosol and cloud ! droplets moved to after vmrcw is moved into qqcw (in mmr spac) - call coagtend( mmr_tend_pcols, pmid, pdel, tfld, delt_inverse, ncol, lchnk) ! Convert cloud water to mmr again ==> values in buffer diff --git a/src/chemistry/oslo_aero/intlog.F90 b/src/chemistry/oslo_aero/intlog.F90 index 5534c30a35..008a7f9968 100644 --- a/src/chemistry/oslo_aero/intlog.F90 +++ b/src/chemistry/oslo_aero/intlog.F90 @@ -1,4 +1,4 @@ -module intlog +module oslo_aero_interp_log use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols @@ -737,5 +737,5 @@ subroutine checkTableHeader (ifil) enddo end subroutine checkTableHeader -end module intlog +end module oslo_aero_interp_log diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 index df46bd47a9..6a095793c3 100644 --- a/src/chemistry/oslo_aero/oslo_aero_conc.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_conc.F90 @@ -1,15 +1,15 @@ module oslo_aero_conc - use shr_kind_mod , only: r8 => shr_kind_r8 - use ppgrid , only: pcols, pver - use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o, pi - use constituents , only: pcnst, cnst_name + use shr_kind_mod , only: r8 => shr_kind_r8 + use ppgrid , only: pcols, pver + use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o, pi + use constituents , only: pcnst, cnst_name ! - use intlog, only: intlog1to3_sub, intlog4_sub, intlog5to10_sub - use oslo_utils, only: calculateNumberConcentration - use const, only: smallNumber, volumeToNumber,smallNumber - use oslo_aero_coag, only: normalizedCoagulationSink - use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV + use oslo_aero_interp_log, only: intlog1to3_sub, intlog4_sub, intlog5to10_sub + use oslo_utils, only: calculateNumberConcentration + use const, only: smallNumber, volumeToNumber,smallNumber + use oslo_aero_coag, only: normalizedCoagulationSink + use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV use commondefinitions use aerosoldef diff --git a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 index d9a1575a29..66e6ef2421 100644 --- a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 @@ -1,15 +1,22 @@ module oslo_aero_condtend + ! Calculate the sulphate nucleation rate, and condensation rate of + ! aerosols used for parameterising the transfer of externally mixed + ! aitken mode particles into an internal mixture. + ! Note the parameterisation for conversion of externally mixed particles + ! used the h2so4 lifetime onto the particles, and not a given + ! increase in particle radius. Will be improved in future versions of the model + use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only : pcols, pver, pverp + use ppgrid, only: pcols, pver, pverp use phys_control, only: phys_getopts use chem_mods, only: gas_pcnst use mo_tracname, only: solsym use cam_history, only: addfld, add_default, fieldname_len, horiz_only, outfld use physconst, only: rair, gravit, pi, avogad use chem_mods, only: adv_mass !molecular weights from mozart - use wv_saturation, only : qsat_water - use m_spc_id, only : id_H2SO4, id_soa_lv + use wv_saturation, only: qsat_water + use m_spc_id, only: id_H2SO4, id_soa_lv ! use oslo_aero_coag, only: normalizedCoagulationSink, receiverMode,numberOfCoagulationReceivers use oslo_aero_coag, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd @@ -21,16 +28,25 @@ module oslo_aero_condtend implicit none private - integer, parameter :: N_COND_VAP = 3 - integer, parameter :: COND_VAP_H2SO4 = 1 - integer, parameter :: COND_VAP_ORG_LV = 2 - integer, parameter :: COND_VAP_ORG_SV = 3 + ! public routines + public :: registerCondensation + public :: initializeCondensation + public :: condtend - real(r8) , public :: normalizedCondensationSink(0:nmodes,N_COND_VAP) ! [m3/#/s] condensation sink per particle in mode i + ! private routines + private :: aeronucl + private :: appformrate - integer , private :: lifeCycleReceiver(gas_pcnst) ! [-] array of transformation of life cycle tracers - real(r8) , private :: stickingCoefficient(0:nmodes,N_COND_VAP) ! [-] stickingCoefficient for H2SO4 on a mode - integer , private :: cond_vap_map(N_COND_VAP) + integer, parameter, public :: N_COND_VAP = 3 + integer, parameter, public :: COND_VAP_H2SO4 = 1 + integer, parameter, public :: COND_VAP_ORG_LV = 2 + integer, parameter, public :: COND_VAP_ORG_SV = 3 + + real(r8), public :: normalizedCondensationSink(0:nmodes,N_COND_VAP) ! [m3/#/s] condensation sink per particle in mode i + + integer , private :: lifeCycleReceiver(gas_pcnst) ! [-] array of transformation of life cycle tracers + real(r8), private :: stickingCoefficient(0:nmodes,N_COND_VAP) ! [-] stickingCoefficient for H2SO4 on a mode + integer , private :: cond_vap_map(N_COND_VAP) ! Assumed number of monolayers real(r8), parameter, private :: n_so4_monolayers_age = 3.0_r8 @@ -39,10 +55,13 @@ module oslo_aero_condtend ! for so4(+nh4), use bi-sulfate mw and 1.77 g/cm3 as in MAM real(r8), parameter, public :: dr_so4_monolayers_age = n_so4_monolayers_age * 4.76e-10_r8 +!=============================================================================== contains +!=============================================================================== subroutine registerCondensation() + ! local variables integer :: iDonor integer :: l_donor integer :: tracerIndex @@ -55,6 +74,7 @@ subroutine registerCondensation() lifeCycleReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_a) !create bc int mix from bc in mode 12 lifeCycleReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ai) !create bc int mix from bc in mode 14 lifeCycleReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ai) + !!create om int mix from om in mode 14 lifeCycleReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ai) !!create bc int mix from bc in mode 0. Note Mass is conserved but not number @@ -86,6 +106,7 @@ subroutine initializeCondensation() !Theory: Poling et al, "The properties of gases and liquids" !5th edition, eqn 11-4-4 + ! local variables real(r8), parameter :: aunit = 1.6606e-27_r8 ![kg] Atomic mass unit real(r8), parameter :: boltz = 1.3806e-23_r8 ![J/K/molec] real(r8), parameter :: t0 = 273.15_r8 ![K] standard temperature @@ -133,34 +154,23 @@ subroutine initializeCondensation() molecularWeight=adv_mass(cond_vap_map(cond_vap_idx)) !pick up molecular weights from mozart - !https://en.wikipedia.org/wiki/Thermal_velocity + ! https://en.wikipedia.org/wiki/Thermal_velocity th(cond_vap_idx) = sqrt(8.0_r8*boltz*t0/(pi*molecularweight*aunit)) ! thermal velocity for H2SO4 in air (m/s) - !Radius of molecul (straight forward assuming spherical) + ! Radius of molecul (straight forward assuming spherical) radmol=(3.0_r8*molecularWeight*aunit/(4.0_r8*pi*rho))**aThird ! molecule radius Mdual=2.0_r8/(1.0_r8/Mair+1.0_r8/molecularWeight) !factor of [1/m_1 + 1_m2] - !calculating microphysical parameters from equations in Ch. 8 of Seinfeld & Pandis (1998): - mfv(cond_vap_idx)=1.0_r8/(pi*sqrt(1.0_r8+MolecularWeight/Mair)*(radair+radmol)**2*p0/(boltz*t0)) ! mean free path for molec in air (m) + ! calculating microphysical parameters from equations in Ch. 8 of Seinfeld & Pandis (1998): + ! mean free path for molec in air (m) + mfv(cond_vap_idx)=1.0_r8/(pi*sqrt(1.0_r8+MolecularWeight/Mair)*(radair+radmol)**2*p0/(boltz*t0)) - !Solve eqn 11-4.4 in Poling et al - !(A bit hard to follow units here, but result in the book is in cm2/s).. - !so scale by "cm2Tom2" to get m2/sec - diff(cond_vap_idx) = cm2Tom2 & - *0.00143_r8*t0**1.75_r8 & - /((p0/1.0e5_r8)*sqrt(Mdual) & + ! Solve eqn 11-4.4 in Poling et al + ! (A bit hard to follow units here, but result in the book is in cm2/s).. + ! so scale by "cm2Tom2" to get m2/sec + diff(cond_vap_idx) = cm2Tom2*0.00143_r8*t0**1.75_r8/((p0/1.0e5_r8)*sqrt(Mdual) & *(((Vad(cond_vap_idx))**aThird+(Vadair)**aThird)**2)) - - !Values used in noresm1: - !real(r8), parameter :: diff = 9.5e-6 !m2/s diffusion coefficient (H2SO4) - !real(r8), parameter :: th = 243.0_r8 !m/s thermal velocity (H2SO4) - !real(r8), parameter :: mfv = 1.65e-8 !m mean free path (H2SO4) - - !Check values obtained here (H2SO4 / SOA) - !write(*,*) 'mfv = ', mfv(cond_vap_idx) !2.800830854409093E-008 / 1.633546464678737E-008 - !write(*,*) ' diff = ', diff(cond_vap_idx) !-> 9.360361706957621E-006 / !-> 4.185923463242946E-006 - !write(*,*) ' th = ', th !-> 242.818542922924 / 185.421069430852 end do do cond_vap_idx = 1, N_COND_VAP @@ -186,12 +196,12 @@ subroutine initializeCondensation() do cond_vap_idx =1, N_COND_VAP do imode = 0, nmodes do nsiz = 1, nBinsTab - normalizedCondensationSink(imode,cond_vap_idx) = & + normalizedCondensationSink(imode,cond_vap_idx) = & normalizedCondensationSink(imode,cond_vap_idx) & - + 4.0_r8*pi & + + 4.0_r8*pi & * DiffusionCoefficient(nsiz,imode,cond_vap_idx) & ![m2/s] diffusion coefficient - * rBinMidPoint(nsiz) & ![m] look up table radius - * normnk(imode,nsiz) ![frc] + * rBinMidPoint(nsiz) & ![m] look up table radius + * normnk(imode,nsiz) ![frc] end do end do end do @@ -217,36 +227,38 @@ subroutine initializeCondensation() end if end if end do + !Need to add so4_a1, soa_na, so4_na, soa_a1 also (which are not parts of the donor-receiver stuff) fieldname_receiver = trim(solsym(chemistryIndex(l_so4_a1)))//"condTend" call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency") if(history_aerosol)then call add_default( fieldname_receiver, 1, ' ' ) end if + fieldname_receiver = trim(solsym(chemistryIndex(l_soa_a1)))//"condTend" call addfld( fieldname_receiver, horiz_only, "A", unit, "condensation tendency" ) if(history_aerosol)then call add_default( fieldname_receiver, 1, ' ' ) end if + fieldname_receiver = trim(solsym(chemistryIndex(l_so4_na)))//"condTend" call addfld( fieldname_receiver, horiz_only, 'A', unit , "condensation tendency" ) if(history_aerosol)then call add_default( fieldname_receiver, 1, ' ' ) end if + fieldname_receiver = trim(solsym(chemistryIndex(l_soa_na)))//"condTend" call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency" ) if(history_aerosol)then call add_default( fieldname_receiver, 1, ' ' ) end if - - end subroutine initializeCondensation + !=============================================================================== - - subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & - pmid, pdel, dt, ncol, pblh,zm,qh20) + subroutine condtend(lchnk, q, cond_vap_gasprod, temperature, & + pmid, pdel, dt, ncol, pblh, zm, qh20) ! Calculate the sulphate nucleation rate, and condensation rate of ! aerosols used for parameterising the transfer of externally mixed @@ -258,18 +270,17 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & ! arguments integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of columns + real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture + real(r8), intent(in) :: cond_vap_gasprod(pcols,pver,N_COND_VAP) ! TMR [kg/kg/sec]] production rate of H2SO4 (gas prod - aq phase uptake) real(r8), intent(in) :: temperature(pcols,pver) ! Temperature (K) real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] pressure at mid point real(r8), intent(in) :: pdel(pcols,pver) ! [Pa] difference in grid cell - real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8), intent(in) :: cond_vap_gasprod(pcols,pver,N_COND_VAP) ! TMR [kg/kg/sec]] production rate of H2SO4 (gas prod - aq phase uptake) real(r8), intent(in) :: dt ! Time step - + integer, intent(in) :: ncol ! number of columns ! Needed for soa nucleation treatment - real(r8), intent(in) :: pblh(pcols) ! pbl height (m) - real(r8), intent(in) :: zm(pcols,pverp) ! midlayer geopotential height above the surface (m) (pver+1) - real(r8), intent(in) :: qh20(pcols,pver) ! specific humidity (kg/kg) + real(r8), intent(in) :: pblh(pcols) ! pbl height (m) + real(r8), intent(in) :: zm(pcols,pverp) ! midlayer geopotential height above the surface (m) (pver+1) + real(r8), intent(in) :: qh20(pcols,pver) ! specific humidity (kg/kg) ! local character(len=fieldname_len+3) :: fieldname @@ -279,12 +290,12 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & integer :: tracerIndex integer :: l_donor integer :: l_receiver - integer :: iDonor ![idx] counter for externally mixed modes - real(r8) :: condensationSink(0:nmodes, N_COND_VAP)![1/s] loss rate per mode (mixture) + integer :: iDonor ![idx] counter for externally mixed modes + real(r8) :: condensationSink(0:nmodes, N_COND_VAP) ![1/s] loss rate per mode (mixture) real(r8) :: condensationSinkFraction(pcols,pver,numberOfExternallyMixedModes,N_COND_VAP) ![frc] - real(r8) :: sumCondensationSink(pcols,pver, N_COND_VAP) ![1/s] sum of condensation sink - real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost - real(r8) :: numberConcentration(0:nmodes) ![#/m3] number concentration + real(r8) :: sumCondensationSink(pcols,pver, N_COND_VAP) ![1/s] sum of condensation sink + real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost + real(r8) :: numberConcentration(0:nmodes) ![#/m3] number concentration real(r8) :: numberConcentrationExtMix(pcols,pver,numberOfExternallyMixedModes) real(r8) :: coltend(pcols, gas_pcnst) real(r8) :: tracer_coltend(pcols) @@ -293,23 +304,23 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & ! Volume of added material from condensate; surface area of core particle; real(r8) :: volume_shell, area_core,vol_monolayer - real (r8) :: frac_transfer ! Fraction of hydrophobic material converted to an internally mixed mode + real (r8) :: frac_transfer ! Fraction of hydrophobic material converted to an internally mixed mode logical :: history_aerosol - character(128) :: long_name ![-] needed for diagnostics + character(128) :: long_name ! [-] needed for diagnostics ! needed for h2so4 and soa nucleation treatment - integer :: modeIndexReceiverCoag !Index of modes receiving coagulate - integer :: iCoagReceiver !counter for species receiving coagulate - real(r8) :: coagulationSink(pcols,pver) ![1/s] coaglation loss for SO4_n and soa_n - real(r8), parameter :: lvocfrac=0.5 !Fraction of organic oxidation products with low enough + integer :: modeIndexReceiverCoag ! Index of modes receiving coagulate + integer :: iCoagReceiver ! counter for species receiving coagulate + real(r8) :: coagulationSink(pcols,pver) ! [1/s] coaglation loss for SO4_n and soa_n + real(r8), parameter :: lvocfrac=0.5 ! Fraction of organic oxidation products with low enough !volatility to enter nucleation mode particles (1-24 nm) - real(r8) :: soa_lv_forNucleation(pcols,pver) ![kg/kg] soa gas available for nucleation - real(r8) :: gasLost(pcols,pver,N_COND_VAP) ![kg/kg] budget terms on H2SO4 (gas) - real(r8) :: fracNucl(pcols,pver,N_COND_VAP) ![frc] fraction of gas nucleated + real(r8) :: soa_lv_forNucleation(pcols,pver) ![kg/kg] soa gas available for nucleation + real(r8) :: gasLost(pcols,pver,N_COND_VAP) ![kg/kg] budget terms on H2SO4 (gas) + real(r8) :: fracNucl(pcols,pver,N_COND_VAP) ![frc] fraction of gas nucleated real(r8) :: firstOrderLossRateNucl(pcols,pver,N_COND_VAP) ![1/s] first order loss rate due to nucleation - real(r8) :: nuclso4(pcols,pver) ![kg/kg/s] Nucleated so4 mass tendency from RM's parameterization - real(r8) :: nuclsoa(pcols,pver) ![kg/kg/s] Nucleated soa mass tendency from RM's parameterization + real(r8) :: nuclso4(pcols,pver) ![kg/kg/s] Nucleated so4 mass tendency from RM's parameterization + real(r8) :: nuclsoa(pcols,pver) ![kg/kg/s] Nucleated soa mass tendency from RM's parameterization integer :: cond_vap_idx !Initialize h2so4 and soa nucl variables @@ -354,20 +365,19 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & do mode_index_receiver = 0, nmodes !This is the loss rate a gas molecule will see due to aerosol surface area - condensationSink(mode_index_receiver,cond_vap_idx) = normalizedCondensationSink(mode_index_receiver,cond_vap_idx) & ![m3/#/s] - * numberConcentration(mode_index_receiver) ![#/m3] - !==> [1/s] + condensationSink(mode_index_receiver,cond_vap_idx) = & !==> [1/s] + normalizedCondensationSink(mode_index_receiver,cond_vap_idx) & ![m3/#/s] + * numberConcentration(mode_index_receiver) ![#/m3] + end do !Loop over receivers end do - !Find concentration after condensation of all - !condenseable vapours + !Find concentration after condensation of all condenseable vapours do cond_vap_idx=1,N_COND_VAP !sum of cond. sink for this vapour [1/s] sumCondensationSink(i,k,cond_vap_idx) = sum(condensationSink(:,cond_vap_idx)) - !Solve the intermediate (end of timestep) concentration using !euler backward solution C_{old} + P *dt - L*C_{new}*dt = C_{new} ==> !Cnew -Cold = prod - loss ==> @@ -382,34 +392,32 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & do iDonor = 1,numberOfExternallyMixedModes !Find the mode in question - mode_index_donor = externallyMixedMode(iDonor) + mode_index_donor = externallyMixedMode(iDonor) !Remember fraction of cond sink for this mode condensationSinkFraction(i,k,iDonor,cond_vap_idx) = & - condensationSink(mode_index_donor,cond_vap_idx) & - / sumCondensationSink(i,k,cond_vap_idx) + condensationSink(mode_index_donor,cond_vap_idx) / sumCondensationSink(i,k,cond_vap_idx) !Remember number concentration in this mode - numberConcentrationExtMix(i,k,iDonor) = & - numberConcentration(mode_index_donor) + numberConcentrationExtMix(i,k,iDonor) = numberConcentration(mode_index_donor) end do end do - !Assume only a fraction of ORG_LV left can contribute to nucleation - soa_lv_forNucleation(i,k) = lvocfrac*intermediateConcentration(i,k,COND_VAP_ORG_LV) !fraction of soa_lv left that is assumend to have low enough - !volatility to nucleate. - - modeIndexReceiverCoag = 0 + ! Assume only a fraction of ORG_LV left can contribute to nucleation + ! fraction of soa_lv left that is assumend to have low enough volatility to nucleate. + soa_lv_forNucleation(i,k) = lvocfrac*intermediateConcentration(i,k,COND_VAP_ORG_LV) + !Sum coagulation sink for nucleated so4 and soa particles over all receivers of coagulate. Needed for RM's nucleation code !OBS - looks like RM's coagulation sink is multiplied by 10^-12?? + modeIndexReceiverCoag = 0 do iCoagReceiver = 1, numberOfCoagulationReceivers modeIndexReceiverCoag = receiverMode(iCoagReceiver) - coagulationSink(i,k) = & ![1/s] + coagulationSink(i,k) = & ![1/s] coagulationSink(i,k) + & ![1/] previous value normalizedCoagulationSink(modeIndexReceiverCoag,MODE_IDX_SO4SOA_AIT) & ![m3/#/s] - * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) + * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) end do !coagulation sink !Sum coagulation sink for nucleated so4 and soa particles over all additional @@ -418,10 +426,10 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & modeIndexReceiverCoag = addReceiverMode(iCoagReceiver) - coagulationSink(i,k) = & ![1/s] - coagulationSink(i,k) + & ![1/] previous value - normCoagSinkAdd(iCoagReceiver) & ![m3/#/s] - * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) + coagulationSink(i,k) = & ![1/s] + coagulationSink(i,k) + & ![1/] previous value + normCoagSinkAdd(iCoagReceiver) & ![m3/#/s] + * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) end do !coagulation sink end do !index i @@ -603,7 +611,9 @@ subroutine condtend_sub(lchnk, q, cond_vap_gasprod, temperature, & endif - end subroutine condtend_sub + end subroutine condtend + + !=============================================================================== subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuclso4, nuclorg, zm, pblht) @@ -968,6 +978,8 @@ subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuc return end subroutine aeronucl + !=============================================================================== + subroutine appformrate(d1, dx, j1, jx, CoagS_dx, gr) !-- appformrate calculates the formation rate jx of dx sized particles from the nucleation rate j1 (d1 sized particles) !-- Formation rate is parameterized according to Lehtinen et al. (2007), JAS 38:988-994 @@ -1004,14 +1016,9 @@ subroutine appformrate(d1, dx, j1, jx, CoagS_dx, gr) gamma=(1._r8/(m+1._r8))*((dx/d1)**(m+1._r8)-1._r8) gamma=MAX(MIN(gamma,1.E2_r8),1.E-10_r8) - !gr=MAX(MIN(gr,1.E3_r8),1.E-5_r8) - !-- (Eq. 7) CoagS_d1 is multiplied with 3600 to get units h-1 - !WRITE(*,*) 'gammaym:',gamma,exp(-gamma*d1*CoagS_d1*3600/gr) jx=j1*exp(-gamma*d1*CoagS_d1*3600._r8/gr) - return - end subroutine appformrate end module oslo_aero_condtend From 9e5b2480fe07d1f62a8f3d00305a6f3c79f65f23 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 31 Aug 2023 14:07:41 +0200 Subject: [PATCH 35/71] moved oslo_utils to oslo_aero_utils --- src/chemistry/oslo_aero/aero_model.F90 | 31 ++++++------ src/chemistry/oslo_aero/oslo_aero_conc.F90 | 4 +- src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_ndrop.F90 | 2 +- .../oslo_aero/oslo_aero_optical_params.F90 | 36 ++++++------- .../oslo_aero/oslo_aero_sw_tables.F90 | 1 - .../{oslo_utils.F90 => oslo_aero_utils.F90} | 17 ++++--- src/physics/cam_oslo/microp_aero.F90 | 50 ++++++++++--------- 8 files changed, 71 insertions(+), 72 deletions(-) rename src/chemistry/oslo_aero/{oslo_utils.F90 => oslo_aero_utils.F90} (92%) diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 268bba3dfe..9e788a6726 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -15,7 +15,7 @@ module aero_model use physics_types, only: physics_state, physics_ptend, physics_ptend_init use physics_buffer, only: physics_buffer_desc use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field - use physconst, only: gravit, rair, rhoh2o + use physconst, only: gravit, rair, rhoh2o, pi use spmd_utils, only: masterproc use time_manager, only: get_nstep use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only @@ -30,14 +30,17 @@ module aero_model ! use oslo_aero_depos, only: oslo_aero_depos_init, oslo_aero_depos_dry, oslo_aero_depos_wet use oslo_aero_coag, only: coagtend, clcoag - use oslo_utils, only: calculateNumberConcentration + use oslo_aero_coag, only: initializeCoagulationReceivers + use oslo_aero_coag, only: initializeCoagulationCoefficients + use oslo_aero_coag, only: initializeCoagulationOutput + use oslo_aero_utils, only: calculateNumberConcentration + use oslo_aero_condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4 + use oslo_aero_condtend, only: registerCondensation, initializeCondensation, condtend use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers use aerosoldef, only: lifeCycleNumberMedianRadius use aerosoldef, only: getCloudTracerName use aerosoldef, only: aero_register - use oslo_aero_condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4 - use oslo_aero_condtend, only: registerCondensation, initializeCondensation, condtend use sox_cldaero_mod, only: sox_cldaero_init use oslo_aero_interp_log, only: initlogn use seasalt_model, only: seasalt_init, seasalt_emis, seasalt_active @@ -66,7 +69,7 @@ module aero_model public :: aero_model_surfarea ! tropopspheric aerosol wet surface area for chemistry public :: aero_model_strat_surfarea ! stratospheric aerosol wet surface area for chemistry - private :: constants + private :: aero_model_constants ! Misc private data integer :: nmodes ! number of modes @@ -157,7 +160,7 @@ subroutine aero_model_init( pbuf2d ) call phys_getopts(history_aerosol_out=history_aerosol, convproc_do_aer_out=convproc_do_aer) - call constants + call aero_model_constants call initopt call initlogn call initopt_lw @@ -714,21 +717,17 @@ subroutine vmr2qqcw( lchnk, vmr, mbar, ncol, im, pbuf ) end subroutine vmr2qqcw !============================================================================= - subroutine constants + subroutine aero_model_constants() ! ! A number of constants used in the emission and size-calculation in CAM-Oslo Jan 2011. ! Updated by Alf Kirkev May 2013 ! Updated by Alf Grini February 2014 - ! - use shr_kind_mod, only: r8 => shr_kind_r8 - use physconst, only: pi + use const use aerosoldef - use oslo_aero_coag, only : initializeCoagulationReceivers - use oslo_aero_coag, only : initializeCoagulationCoefficients - use oslo_aero_coag, only : initializeCoagulationOutput - use oslo_utils + use oslo_aero_utils + ! local variables integer :: kcomp,i real(r8) :: rhob(0:nmodes) !density of background aerosol in mode real(r8) :: rhorbc !This has to do with fractal dimensions of bc, come back to this!! @@ -760,7 +759,6 @@ subroutine constants end if end do - !Find radius in edges and midpoints of bin rBinEdge(1) = rTabMin totalLogDelta = log(rTabMax/rTabMin) @@ -828,6 +826,7 @@ subroutine constants call initializeCoagulationCoefficients(rhob, lifeCycleNumberMedianRadius) call initializeCoagulationOutput() - end subroutine constants + + end subroutine aero_model_constants end module aero_model diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 index 6a095793c3..b2420b4260 100644 --- a/src/chemistry/oslo_aero/oslo_aero_conc.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_conc.F90 @@ -6,10 +6,10 @@ module oslo_aero_conc use constituents , only: pcnst, cnst_name ! use oslo_aero_interp_log, only: intlog1to3_sub, intlog4_sub, intlog5to10_sub - use oslo_utils, only: calculateNumberConcentration - use const, only: smallNumber, volumeToNumber,smallNumber + use oslo_aero_utils, only: calculateNumberConcentration use oslo_aero_coag, only: normalizedCoagulationSink use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV + use const, only: smallNumber, volumeToNumber,smallNumber use commondefinitions use aerosoldef diff --git a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 index 88f3beb3b3..66dc578a3a 100644 --- a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 @@ -30,8 +30,8 @@ module oslo_aero_hetfrz use error_messages, only: handle_errmsg, alloc_err use cam_abortutils, only: endrun ! + use oslo_aero_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius use commondefinitions, only: nmodes_oslo => nmodes - use oslo_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex use aerosoldef, only: qqcw_get_field diff --git a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 index 31a0f5fa20..e456fcedd4 100644 --- a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 @@ -21,7 +21,7 @@ module oslo_aero_ndrop use cam_abortutils, only: endrun use cam_logfile, only: iulog ! - use oslo_utils, only: calculateNumberMedianRadius + use oslo_aero_utils, only: calculateNumberMedianRadius use aerosoldef, only: getNumberOfTracersInMode, getNumberOfAerosolTracers, getTracerIndex use aerosoldef, only: getCloudTracerName, getCloudTracerIndex, getConstituentFraction use aerosoldef, only: fillAerosolTracerList, fillInverseAerosolTracerList diff --git a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 index 26f7e9b43a..35cf14b619 100644 --- a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 @@ -3,20 +3,20 @@ module oslo_aero_optical_params ! Optical parameters for a composite aerosol is calculated by interpolation ! from the tables kcomp1.out-kcomp14.out. - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_history, only: outfld - use constituents, only: pcnst - use physconst, only: rair,pi - use physics_types, only: physics_state - use wv_saturation, only: qsat_water + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols, pver, pverp + use constituents, only: pcnst + use cam_history, only: outfld + use physconst, only: rair,pi + use physics_types, only: physics_state + use wv_saturation, only: qsat_water ! - use oslo_utils, only: calculateNumberConcentration - use oslo_aero_conc, only: calculateBulkProperties, partitionMass + use oslo_aero_utils, only: calculateNumberConcentration + use oslo_aero_conc, only: calculateBulkProperties, partitionMass + use oslo_aero_sw_tables use commondefinitions use const use aerosoldef - use oslo_aero_sw_tables implicit none private @@ -188,12 +188,12 @@ subroutine oslo_aero_optical_params_calc(lchnk, ncol, pint, pmid, ! Avoid very small numbers do k=1,pver do icol=1,ncol - Ca(icol,k) = max(eps,Ca(icol,k)) - f_c(icol,k) = max(eps,f_c(icol,k)) - f_bc(icol,k) = max(eps,f_bc(icol,k)) - f_aq(icol,k) = max(eps,f_aq(icol,k)) - fnbc(icol,k) = max(eps,fnbc(icol,k)) - faitbc(icol,k) = max(eps,faitbc(icol,k)) + Ca(icol,k) = max(eps,Ca(icol,k)) + f_c(icol,k) = max(eps,f_c(icol,k)) + f_bc(icol,k) = max(eps,f_bc(icol,k)) + f_aq(icol,k) = max(eps,f_aq(icol,k)) + fnbc(icol,k) = max(eps,fnbc(icol,k)) + faitbc(icol,k) = max(eps,faitbc(icol,k)) end do end do @@ -230,7 +230,6 @@ subroutine oslo_aero_optical_params_calc(lchnk, ncol, pint, pmid, focm, fcm, xfac, ifac1, fbcm, xfbc, ifbc1, faqm, xfaq, ifaq1) ! (Wet) Optical properties for each of the aerosol modes: - lw_on = .true. ! No LW optics needed for RH=0 (interpol returns 0-values) ! BC(ax) mode (dry only): @@ -524,7 +523,4 @@ subroutine oslo_aero_optical_params_calc(lchnk, ncol, pint, pmid, end subroutine oslo_aero_optical_params_calc - - - end module oslo_aero_optical_params diff --git a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 index 218e2e0662..98fefc6a94 100644 --- a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 @@ -44,7 +44,6 @@ module oslo_aero_sw_tables use lininterpol_mod , only: lininterpol3dim, lininterpol4dim, lininterpol5dim implicit none - private ! Interfaces diff --git a/src/chemistry/oslo_aero/oslo_utils.F90 b/src/chemistry/oslo_aero/oslo_aero_utils.F90 similarity index 92% rename from src/chemistry/oslo_aero/oslo_utils.F90 rename to src/chemistry/oslo_aero/oslo_aero_utils.F90 index af2fffae1d..12b0ca7f83 100644 --- a/src/chemistry/oslo_aero/oslo_utils.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_utils.F90 @@ -1,12 +1,13 @@ -module oslo_utils +module oslo_aero_utils use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols, pver + use physconst, only: pi use constituents, only: pcnst + ! use aerosoldef, only: getDryDensity, getNumberOfBackgroundTracersInMode, getTracerIndex use const, only: volumeToNumber, rbinMidPoint, rbinEdge, nBinsTab, nmodes use commondefinitions, only: originalNumberMedianRadius - use physconst, only: pi implicit none private @@ -23,11 +24,13 @@ module oslo_utils subroutine calculateNumberConcentration(ncol, q, rho_air, numberConcentration) - integer, intent(in) :: ncol !number of columns used - real(r8), intent(in) :: q(pcols,pver,pcnst) ![kg/kg] mass mixing ratios - real(r8), intent(in) :: rho_air(pcols,pver) ![kg/m3] air density - real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration + ! arguments + integer , intent(in) :: ncol !number of columns used + real(r8) , intent(in) :: q(pcols,pver,pcnst) ![kg/kg] mass mixing ratios + real(r8) , intent(in) :: rho_air(pcols,pver) ![kg/m3] air density + real(r8) , intent(out) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration + ! local variables integer :: m, l, mm, k numberConcentration(:,:,:) = 0.0_r8 @@ -164,4 +167,4 @@ function calculateLognormalCDF(actualRadius, numberMedianRadius, sigma) result(C end function calculateLognormalCDF -end module oslo_utils +end module oslo_aero_utils diff --git a/src/physics/cam_oslo/microp_aero.F90 b/src/physics/cam_oslo/microp_aero.F90 index fecdb4f69f..52e421f599 100644 --- a/src/physics/cam_oslo/microp_aero.F90 +++ b/src/physics/cam_oslo/microp_aero.F90 @@ -21,30 +21,32 @@ module microp_aero ! !--------------------------------------------------------------------------------- - use shr_kind_mod, only: r8=>shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, pverp - use ref_pres, only: top_lev => trop_cloud_top_lev - use physconst, only: rair - use constituents, only: cnst_get_ind, pcnst - use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum - use physics_types, only: physics_state_copy, physics_update - use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field - use phys_control, only: phys_getopts, use_hetfrz_classnuc - use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, rad_cnst_get_mode_num - use oslo_aero_ndrop, only: ndrop_init_oslo, dropmixnuc_oslo - use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn - use cam_history, only: addfld, add_default, outfld - use cam_logfile, only: iulog + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp + use ref_pres, only: top_lev => trop_cloud_top_lev + use physconst, only: rair + use constituents, only: cnst_get_ind, pcnst + use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum + use physics_types, only: physics_state_copy, physics_update + use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field + use phys_control, only: phys_getopts, use_hetfrz_classnuc + use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, rad_cnst_get_mode_num + use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn + use cam_history, only: addfld, add_default, outfld + use cam_logfile, only: iulog ! - use commondefinitions, only: nmodes_oslo => nmodes - use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC, MODE_IDX_OMBC_INTMIX_COAT_AIT - use aerosoldef, only: lifeCycleNumberMedianRadius, l_dst_a2, l_dst_a3, l_bc_ai - use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex, getCloudTracerIndex - use oslo_utils, only: CalculateNumberConcentration - use oslo_aero_conc - use oslo_aero_hetfrz - use oslo_aero_nucleate_ice + use oslo_aero_utils, only: CalculateNumberConcentration + use oslo_aero_ndrop, only: ndrop_init_oslo, dropmixnuc_oslo + use oslo_aero_conc, only: oslo_aero_conc_calc + use oslo_aero_hetfrz, only: hetfrz_classnuc_oslo_register, hetfrz_classnuc_oslo_init, hetfrz_classnuc_oslo_readnl + use oslo_aero_hetfrz, only: hetfrz_classnuc_oslo_calc, hetfrz_classnuc_oslo_save_cbaero + use oslo_aero_nucleate_ice, only: nucleate_ice_oslo_register, nucleate_ice_oslo_init, nucleate_ice_oslo_readnl + use oslo_aero_nucleate_ice, only: nucleate_ice_oslo_calc, use_preexisting_ice + use commondefinitions, only: nmodes_oslo => nmodes + use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC, MODE_IDX_OMBC_INTMIX_COAT_AIT + use aerosoldef, only: lifeCycleNumberMedianRadius, l_dst_a2, l_dst_a3, l_bc_ai + use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex, getCloudTracerIndex implicit none private @@ -106,7 +108,7 @@ module microp_aero integer :: npccn_idx, rndst_idx, nacon_idx - logical :: separate_dust = .false. + logical :: separate_dust = .false. !========================================================================================= contains From bdd06d59333901e48ee619052b85457f13ef0e87 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Thu, 31 Aug 2023 20:00:53 +0200 Subject: [PATCH 36/71] more extensive consolidation --- src/chemistry/aerosol/mo_setsox.F90 | 85 +- src/chemistry/mozart/chemistry.F90 | 8 + src/chemistry/mozart/mo_chm_diags.F90 | 197 ++- src/chemistry/mozart/mo_gas_phase_chemdr.F90 | 4 + src/chemistry/mozart/mo_photo.F90 | 8 + src/chemistry/mozart/mo_setaer.F90 | 5 + src/chemistry/mozart/mo_usrrxt.F90 | 10 +- src/chemistry/oslo_aero/aero_model.F90 | 264 ++- src/chemistry/oslo_aero/dust_model.F90 | 147 -- src/chemistry/oslo_aero/oslo_aero_depos.F90 | 903 +++++++++- src/chemistry/oslo_aero/oslo_aero_dust.F90 | 251 +++ ...easalt_model.F90 => oslo_aero_seasalt.F90} | 16 +- .../oslo_aero/oslo_aero_sox_cldaero.F90 | 473 +++++ src/chemistry/oslo_aero/sox_cldaero_mod.F90 | 386 ---- src/physics/cam_oslo/mo_chm_diags.F90 | 1019 ----------- src/physics/cam_oslo/mo_drydep.F90 | 7 + src/physics/cam_oslo/mo_gas_phase_chemdr.F90 | 31 +- src/physics/cam_oslo/mo_neu_wetdep.F90 | 8 + src/physics/cam_oslo/mo_setsox.F90 | 873 --------- src/physics/cam_oslo/mo_usrrxt.F90 | 1569 ----------------- 20 files changed, 2037 insertions(+), 4227 deletions(-) delete mode 100644 src/chemistry/oslo_aero/dust_model.F90 create mode 100644 src/chemistry/oslo_aero/oslo_aero_dust.F90 rename src/chemistry/oslo_aero/{seasalt_model.F90 => oslo_aero_seasalt.F90} (95%) create mode 100644 src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 delete mode 100644 src/chemistry/oslo_aero/sox_cldaero_mod.F90 delete mode 100644 src/physics/cam_oslo/mo_chm_diags.F90 delete mode 100644 src/physics/cam_oslo/mo_setsox.F90 delete mode 100644 src/physics/cam_oslo/mo_usrrxt.F90 diff --git a/src/chemistry/aerosol/mo_setsox.F90 b/src/chemistry/aerosol/mo_setsox.F90 index b994e32dd2..eb53483dce 100644 --- a/src/chemistry/aerosol/mo_setsox.F90 +++ b/src/chemistry/aerosol/mo_setsox.F90 @@ -23,30 +23,38 @@ module MO_SETSOX contains -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- subroutine sox_inti - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... initialize the hetero sox routine - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- use mo_chem_utls, only : get_spc_ndx, get_inv_ndx use spmd_utils, only : masterproc use phys_control, only : phys_getopts +#ifdef OSLO_AERO + use oslo_aero_sox_cldaero, only : sox_cldaero_init +#else use sox_cldaero_mod, only : sox_cldaero_init - +#endif implicit none call phys_getopts( & prog_modal_aero_out=modal_aerosols ) - cloud_borne = modal_aerosols +#ifdef OSLO_AERO + cloud_borne = .true. + modal_aerosols = .true. +#else + cloud_borne = modal_aerosols +#endif !----------------------------------------------------------------- ! ... get species indicies !----------------------------------------------------------------- - + if (cloud_borne) then id_h2so4 = get_spc_ndx( 'H2SO4' ) else @@ -119,16 +127,16 @@ subroutine sox_inti write(iulog,*) 'mozart will do sox aerosols' write(iulog,*) '-----------------------------------------' endif - else + else return end if call sox_cldaero_init() end subroutine sox_inti - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- subroutine SETSOX( & ncol, & lchnk, & @@ -155,7 +163,7 @@ subroutine SETSOX( & aqso4_o3_3d & ) - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... Compute heterogeneous reactions of SOX ! ! (0) using initial PH to calculate PH @@ -168,22 +176,27 @@ subroutine SETSOX( & ! (b) PARTIONING ! (c) REACTION rates ! (d) PREDICTION - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! use ppgrid, only : pcols, pver use chem_mods, only : gas_pcnst, nfs use chem_mods, only : adv_mass use physconst, only : mwdry, gravit use mo_constants, only : pi +#ifdef OSLO_AERO + use oslo_aero_sox_cldaero, only : sox_cldaero_update, sox_cldaero_create_obj, sox_cldaero_destroy_obj + use oslo_aero_sox_cldaero, only : cldaero_conc_t +#else use sox_cldaero_mod, only : sox_cldaero_update, sox_cldaero_create_obj, sox_cldaero_destroy_obj use cldaero_mod, only : cldaero_conc_t +#endif ! implicit none ! - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... Dummy arguments - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- integer, intent(in) :: ncol ! num of columns in chunk integer, intent(in) :: lchnk ! chunk id integer, intent(in) :: loffset ! offset of chem tracers in the advected tracers array @@ -210,11 +223,11 @@ subroutine SETSOX( & real(r8), intent(out), optional :: aqso4_o3_3d(:, :) ! 3D SO4 aqueous phase chemistry due to O3 (kg/m2) - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... Local variables ! ! xhno3 ... in mixing ratio - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- integer, parameter :: itermax = 20 real(r8), parameter :: ph0 = 5.0_r8 ! INITIAL PH VALUES real(r8), parameter :: const0 = 1.e3_r8/6.023e23_r8 @@ -249,10 +262,10 @@ subroutine SETSOX( & real(r8) :: hno3g(ncol,pver), nh3g(ncol,pver) ! - !----------------------------------------------------------------------- - ! for Ho2(g) -> H2o2(a) formation + !----------------------------------------------------------------------- + ! for Ho2(g) -> H2o2(a) formation ! schwartz JGR, 1984, 11589 - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- real(r8) :: kh4 ! kh2+kh3 real(r8) :: xam ! air density /cm3 real(r8) :: ho2s ! ho2s = ho2(a)+o2- @@ -303,7 +316,7 @@ subroutine SETSOX( & xph0 = 10._r8**(-ph0) ! initial PH value do k = 1,pver - cfact(:,k) = xhnm(:,k) & ! /cm3(a) + cfact(:,k) = xhnm(:,k) & ! /cm3(a) * 1.e6_r8 & ! /m3(a) * 1.38e-23_r8/287._r8 & ! Kg(a)/m3(a) * 1.e-3_r8 ! Kg(a)/L(a) @@ -364,13 +377,13 @@ subroutine SETSOX( & if (id_msa > 0) xmsa (:,k) = qin(:,k,id_msa) end do - + !----------------------------------------------------------------- ! ... Temperature dependent Henry constants !----------------------------------------------------------------- ver_loop0: do k = 1,pver !! pver loop for STEP 0 col_loop0: do i = 1,ncol - + if (cloud_borne .and. cldfrc(i,k)>0._r8) then xso4(i,k) = xso4c(i,k) / cldfrc(i,k) xnh4(i,k) = xnh4c(i,k) / cldfrc(i,k) @@ -586,7 +599,7 @@ subroutine SETSOX( & xph(i,k) = 10.0_r8**(-yph) converged = .true. exit - else + else ! do another iteration converged = .false. end if @@ -637,9 +650,9 @@ subroutine SETSOX( & patm = press(i,k)/101300._r8 ! press is in pascal xam = press(i,k)/(1.38e-23_r8*tz) ! air density /M3 - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... hno3 - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- xk = 2.1e5_r8 *EXP( 8700._r8*work1(i) ) xe = 15.4_r8 hehno3(i,k) = xk*(1._r8 + xe/xph(i,k)) @@ -675,7 +688,7 @@ subroutine SETSOX( & heo3(i,k) = xk !------------------------------------------------------------------------ - ! ... for Ho2(g) -> H2o2(a) formation + ! ... for Ho2(g) -> H2o2(a) formation ! schwartz JGR, 1984, 11589 !------------------------------------------------------------------------ kh4 = (kh2 + kh3*kh1/xph(i,k)) / ((1._r8 + kh1/xph(i,k))**2) @@ -697,7 +710,7 @@ subroutine SETSOX( & endif !----------------------------------------------- - ! ... Partioning + ! ... Partioning !----------------------------------------------- !----------------------------------------------------------------- @@ -755,8 +768,8 @@ subroutine SETSOX( & !----------------------------------------------------------------- ! ... Prediction after aqueous phase ! so4 - ! When Cloud is present - ! + ! When Cloud is present + ! ! S(IV) + H2O2 = S(VI) ! S(IV) + O3 = S(VI) ! @@ -764,12 +777,12 @@ subroutine SETSOX( & ! (1) Seinfeld ! (2) Benkovitz !----------------------------------------------------------------- - + !............................ ! S(IV) + H2O2 = S(VI) !............................ - - IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED + + IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED if (cloud_borne) then patm_x = patm @@ -825,7 +838,7 @@ subroutine SETSOX( & xso2(i,k) = xso2(i,k) - ccc end if END IF - + if (modal_aerosols) then xdelso4hp(i,k) = xso4(i,k) - xso4_init(i,k) endif @@ -839,7 +852,7 @@ subroutine SETSOX( & * xl & ! [mole/L(a)/s] / const0 & ! [/L(a)/s] / xhnm(i,k) ! [mixing ratio/s] - + ccc = pso4*dtime ccc = max(ccc, 1.e-30_r8) @@ -862,7 +875,7 @@ subroutine SETSOX( & ncol, lchnk, loffset, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, cldconc%xlwc, & xdelso4hp, xh2so4, xso4, xso4_init, nh3g, hno3g, xnh3, xhno3, xnh4c, xno3c, xmsa, xso2, xh2o2, qcw, qin, & aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d=aqso4_h2o2_3d, aqso4_o3_3d=aqso4_o3_3d ) - + xphlwc(:,:) = 0._r8 do k = 1, pver do i = 1, ncol diff --git a/src/chemistry/mozart/chemistry.F90 b/src/chemistry/mozart/chemistry.F90 index 653698fd1a..4531a729e7 100644 --- a/src/chemistry/mozart/chemistry.F90 +++ b/src/chemistry/mozart/chemistry.F90 @@ -347,7 +347,11 @@ subroutine chem_readnl(nlfile) use tracer_cnst, only: tracer_cnst_defaultopts, tracer_cnst_setopts use tracer_srcs, only: tracer_srcs_defaultopts, tracer_srcs_setopts use aero_model, only: aero_model_readnl +#ifdef OSLO_AERO + use oslo_aero_dust, only: oslo_aero_dust_readnl +#else use dust_model, only: dust_readnl +#endif use gas_wetdep_opts, only: gas_wetdep_readnl use upper_bc, only: ubc_defaultopts, ubc_setopts use mo_drydep, only: drydep_srf_file @@ -666,7 +670,11 @@ subroutine chem_readnl(nlfile) tgcm_ubc_fixed_tod_in = tgcm_ubc_fixed_tod ) call aero_model_readnl(nlfile) +#ifdef OSLO_AERO + call oslo_aero_dust_readnl(nlfile) +#else call dust_readnl(nlfile) +#endif ! call gas_wetdep_readnl(nlfile) call gcr_ionization_readnl(nlfile) diff --git a/src/chemistry/mozart/mo_chm_diags.F90 b/src/chemistry/mozart/mo_chm_diags.F90 index daba95dfd1..db7e048d62 100644 --- a/src/chemistry/mozart/mo_chm_diags.F90 +++ b/src/chemistry/mozart/mo_chm_diags.F90 @@ -49,6 +49,9 @@ module mo_chm_diags character(len=fieldname_len) :: depflx_name(gas_pcnst) character(len=fieldname_len) :: wetdep_name(gas_pcnst) character(len=fieldname_len) :: wtrate_name(gas_pcnst) +#ifdef OSLO_AERO + character(len=fieldname_len) :: wetdep_name_area(gas_pcnst) +#endif real(r8), parameter :: N_molwgt = 14.00674_r8 real(r8), parameter :: S_molwgt = 32.066_r8 @@ -65,6 +68,10 @@ subroutine chm_diags_inti use phys_control, only : phys_getopts use mo_drydep, only : has_drydep use species_sums_diags, only : species_sums_init +#ifdef OSLO_AERO + use commondefinitions + use aerosoldef, only: getCloudTracerIndexDirect, getCloudTracerName, isAerosol +#endif integer :: j, k, m, n character(len=16) :: jname, spc_name, attr @@ -95,8 +102,12 @@ subroutine chm_diags_inti logical :: history_cesm_forcing logical :: history_scwaccm_forcing logical :: history_chemspecies_srf ! output the chemistry constituents species in the surface layer - logical :: history_dust integer :: bulkaero_species(20) + logical :: history_dust +#ifdef OSLO_AERO + integer :: cloudTracerIndex + character(len=20) :: cloudTracerName +#endif !----------------------------------------------------------------------- @@ -377,12 +388,40 @@ subroutine chm_diags_inti call addfld( wtrate_name(m), (/ 'lev' /), 'A', '/s', spc_name//' wet deposition rate' ) endif +#ifdef OSLO_AERO + wetdep_name_area(m)='WD_A_'//trim(spc_name) + call addfld( wetdep_name_area(m), horiz_only, 'A', 'kg/m2/s ', spc_name//' wet deposition' ) + + !Needed for budget term of gases! Aerosols have their own budget terms + if (n.gt.0) then + if(.NOT. isAerosol(n))then + if(history_chemistry)then + call add_default( wetdep_name_area(m), 1, ' ') + end if + endif + end if +#endif + if (spc_name(1:3) == 'num') then unit_basename = ' 1' else unit_basename = 'kg' endif +#ifdef OSLO_AERO + if (n.gt.0) then + if ( any( aer_species == m ) .or. isAerosol(n) ) then + call addfld( spc_name, (/ 'lev' /), 'A', unit_basename//'/kg ', trim(attr)//' concentration') + call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', unit_basename//'/kg', trim(attr)//" in bottom layer") + else + call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') + call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") + endif + else + call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') + call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") + endif +#else if ( any( aer_species == m ) ) then call addfld( spc_name, (/ 'lev' /), 'A', unit_basename//'/kg ', trim(attr)//' concentration') call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', unit_basename//'/kg', trim(attr)//" in bottom layer") @@ -390,6 +429,7 @@ subroutine chm_diags_inti call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") endif +#endif if ((m /= id_cly) .and. (m /= id_bry)) then if (history_aerosol.or.history_chemistry) then @@ -431,12 +471,61 @@ subroutine chm_diags_inti if (m==id_cfc12 ) call add_default( spc_name, 1, ' ') endif +#ifdef OSLO_AERO + call add_default( spc_name, 1, ' ' ) + + !output 3d-field of aersol tracer in cloud water + if(n > 0) then + cloudTracerIndex = getCloudTracerIndexDirect(n) + if(cloudTracerIndex > 0)then + cloudTracerName(1:len(CloudTracerName))=" " + cloudTracerName = getCloudTracerName(n) + call addfld( trim(cloudTracerName), (/'lev'/), 'A','kg/kg', & + trim(cloudTracerName)//' in cloud water') + call add_default( trim(cloudTracerName), 1, ' ' ) + + !Add column burden of cloud tracers + call addfld('cb_'//trim(cloudTracerName),horiz_only, 'A', 'kg/m2', & + 'cb_'//trim(cloudTracerName)//' column in cloud water') + call add_default('cb_'//trim(cloudTracerName),1,' ') + endif + !..and column burden in clean air + call addfld('cb_'//trim(spc_name),horiz_only, 'A', 'kg/m2', & + 'cb_'//trim(spc_name)//' in column') + call add_default('cb_'//trim(spc_name),1,' ' ) + + if (history_aerosol)then + if (cloudTracerIndex > 0)then + !Output budget-terms for cloud borne aerosols + call add_default (trim(cloudTracerName)//'GVF', 1, ' ') + call add_default (trim(cloudTracerName)//'SFWET', 1, ' ') + call add_default (trim(cloudTracerName)//'TBF', 1, ' ') + call add_default (trim(cloudTracerName)//'DDF', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSBS', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSIC', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSBC', 1, ' ') + call add_default (trim(cloudTracerName)//'SFSIS', 1, ' ') + endif + endif + end if +#else if (history_dust .and. (index(spc_name,'dst_') > 0)) call add_default( spc_name, 1, ' ') +#endif enddo call addfld( 'MASS', (/ 'lev' /), 'A', 'kg', 'mass of grid box' ) call addfld( 'AREA', horiz_only, 'A', 'm2', 'area of grid box' ) +#ifdef OSLO_AERO + do n=1,N_AEROSOL_TYPES + call addfld('cb_'//trim(aerosol_type_name(n)),horiz_only, 'A', 'kg/m2',& + 'cb_'//trim(aerosol_type_name(n))//' column of aerosol type') + call add_default('cb_'//trim(aerosol_type_name(n)), 1, ' ') + call addfld('mmr_'//trim(aerosol_type_name(n)),(/'lev'/),'A','kg/kg' ,& + 'mmr_'//trim(aerosol_type_name(n))//' mmr of aerosol type') + call add_default('mmr_'//trim(aerosol_type_name(n)), 1, ' ') + end do +#endif call addfld( 'dry_deposition_NOy_as_N', horiz_only, 'I', 'kg/m2/s', 'NOy dry deposition flux ' ) call addfld( 'DF_SOX', horiz_only, 'I', 'kg/m2/s', 'SOx dry deposition flux ' ) @@ -460,8 +549,14 @@ subroutine chm_diags_inti end subroutine chm_diags_inti +#ifdef OSLO_AERO + subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depflx, mmr_tend, pdel, pmid, ltrop, & + wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx, pbuf) +#else subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depflx, mmr_tend, pdel, pmid, ltrop, & - wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx ) + wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx) +#endif + !-------------------------------------------------------------------- ! ... utility routine to output chemistry diagnostic variables !-------------------------------------------------------------------- @@ -469,6 +564,14 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf use cam_history, only : outfld use phys_grid, only : get_area_all_p use species_sums_diags, only : species_sums_output +#ifdef OSLO_AERO + use constituents, only : cnst_get_ind + use phys_grid, only : pcols + use aerosoldef, only : getCloudTracerIndexDirect, getCloudTracerName, aerosolType, isAerosol + use physics_buffer, only : pbuf_get_field, pbuf_get_index + use physics_buffer, only : physics_buffer_desc + use commondefinitions +#endif ! ! CCMI ! @@ -492,11 +595,23 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf real(r8), intent(in) :: wetdepflx(ncol, gas_pcnst) real(r8), intent(out) :: nhx_nitrogen_flx(ncol) ! kgN/m2/sec real(r8), intent(out) :: noy_nitrogen_flx(ncol) ! kgN/m2/sec +#ifdef OSLO_AERO + type(physics_buffer_desc), pointer :: pbuf(:) +#endif !-------------------------------------------------------------------- ! ... local variables !-------------------------------------------------------------------- - integer :: i, k, m +#ifdef OSLO_AERO + real(r8), dimension(:,:), pointer :: cloudTracerField + integer :: cloudTracerIndex + character(len=20) :: cloudTracerName + real(r8) :: mass_tmp(pcols,pver) + real(r8) :: cb(pcols) + real(r8) :: cb_aerosol_type(pcols,N_AEROSOL_TYPES) !column burden aerosol types + real(r8) :: mmr_aerosol_type(pcols,pver,N_AEROSOL_TYPES) !concentration aerosol types +#endif + integer :: i, k, m, n real(r8) :: wrk(ncol,pver) ! real(r8) :: tmp(ncol,pver) ! real(r8) :: m(ncol,pver) @@ -511,6 +626,9 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf real(r8) :: area(ncol), mass(ncol,pver) real(r8) :: wgt +#ifdef OSLO_AERO + character(len=16) :: spc_name +#endif !-------------------------------------------------------------------- ! ... "diagnostic" groups @@ -547,6 +665,10 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf call outfld( 'AREA', area(:ncol), ncol, lchnk ) call outfld( 'MASS', mass(:ncol,:), ncol, lchnk ) +#ifdef OSLO_AERO + cb_aerosol_type(:,:) = 0.0_r8 + mmr_aerosol_type(:,:,:) = 0.0_r8 +#endif do m = 1,gas_pcnst !...FOY (counting Fluorines, not chlorines or bromines) @@ -626,7 +748,51 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf if ( any( hox_species == m ) ) then vmr_hox(:ncol,:) = vmr_hox(:ncol,:) + wgt * vmr(:ncol,:,m) endif - + +#ifdef OSLO_AERO + spc_name = trim(solsym(m)) + call cnst_get_ind(spc_name, n, abort=.false.) + + if (n.gt.0) then + if ( any( aer_species == m ) .or. isAerosol(n) ) then + call outfld( solsym(m), mmr(:ncol,:,m), ncol ,lchnk ) + call outfld( trim(solsym(m))//'_SRF', mmr(:ncol,pver,m), ncol ,lchnk ) + else + call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) + call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) + endif + else + call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) + call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) + end if + + if (n > 0) then + cloudTracerIndex = getCloudTracerIndexDirect(n) + if (cloudTracerIndex > 0)then + cloudTracerName = getCloudTracerName(n) + call pbuf_get_field(pbuf, cloudTracerIndex, cloudTracerField ) + call outfld ( trim(cloudTracerName),cloudTracerField,pcols,lchnk) + + !Treat column burden (cloud tracer) + mass_tmp(:ncol,:) = cloudTracerField(:ncol,:) *pdel(:ncol,:) * rgrav + cb(:ncol) = sum(mass_tmp(:ncol,:),2) + call outfld(trim('cb_'//trim(cloudTracerName)), cb, pcols, lchnk) + endif + + !Treat column burden (normal tracer) + mass_tmp(:ncol,:) = mmr(:ncol,:,m) * pdel(:ncol,:) * rgrav + cb(:ncol) = sum(mass_tmp(:ncol,:),2) + call outfld(trim('cb_'//trim(spc_name)), cb, pcols, lchnk) + + ! Sum column burden per aerosol type + if(aerosolType(n) .gt. 0)then + cb_aerosol_type(:ncol,aerosolType(n)) = cb_aerosol_type(:ncol,aerosolType(n)) + cb(:ncol) + + !Total mass mixing ratio of aerosol type + mmr_aerosol_type(:ncol,:,aerosolType(n)) = mmr_aerosol_type(:ncol,:,aerosolType(n)) + mmr(:ncol,:,m) + endif + end if !Check if this is a chemistry tracer +#else if ( any( aer_species == m ) ) then call outfld( solsym(m), mmr(:ncol,:,m), ncol ,lchnk ) call outfld( trim(solsym(m))//'_SRF', mmr(:ncol,pver,m), ncol ,lchnk ) @@ -634,6 +800,7 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) endif +#endif call outfld( depvel_name(m), depvel(:ncol,m), ncol ,lchnk ) call outfld( depflx_name(m), depflx(:ncol,m), ncol ,lchnk ) @@ -700,7 +867,12 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf ! enddo - +#ifdef OSLO_AERO + do n=1,N_AEROSOL_TYPES + call outfld("mmr_"//trim(aerosol_type_name(n)), mmr_aerosol_type(:ncol,:,n), ncol,lchnk) + call outfld("cb_"//trim(aerosol_type_name(n)), cb_aerosol_type(:ncol,n), ncol,lchnk) + enddo +#endif call outfld( 'NOX', vmr_nox (:ncol,:), ncol, lchnk ) call outfld( 'NOY', vmr_noy (:ncol,:), ncol, lchnk ) call outfld( 'HOX', vmr_hox (:ncol,:), ncol, lchnk ) @@ -830,7 +1002,11 @@ end subroutine chm_diags subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) use cam_history, only : outfld +#ifdef OSLO_AERO + use phys_grid, only : get_wght_all_p, get_area_all_p +#else use phys_grid, only : get_wght_all_p +#endif integer, intent(in) :: lchnk integer, intent(in) :: ncol @@ -839,6 +1015,9 @@ subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) real(r8), intent(in) :: pdel(ncol,pver) real(r8), dimension(ncol) :: noy_wk, sox_wk, nhx_wk, wrk_wd +#ifdef OSLO_AERO + real(r8), dimension(ncol) :: area +#endif integer :: m, k real(r8) :: wght(ncol) ! @@ -848,6 +1027,11 @@ subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) sox_wk(:) = 0._r8 nhx_wk(:) = 0._r8 +#ifdef OSLO_AERO + call get_area_all_p(lchnk, ncol, area) + area = area * rearth**2 +#endif + call get_wght_all_p(lchnk, ncol, wght) do m = 1,gas_pcnst @@ -863,6 +1047,9 @@ subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) ! if (gas_wetdep_method=='MOZ') then call outfld( wetdep_name(m), wrk_wd(:ncol), ncol, lchnk ) +#ifdef OSLO_AERO + call outfld( wetdep_name_area(m), wrk_wd(:ncol)/area(:ncol) ,ncol, lchnk ) +#endif call outfld( wtrate_name(m), het_rates(:ncol,:,m), ncol, lchnk ) if ( any(noy_species == m ) ) then diff --git a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 index 71a380f16b..de6464ff5f 100644 --- a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 +++ b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 @@ -6,7 +6,11 @@ module mo_gas_phase_chemdr use cam_history, only : fieldname_len use chem_mods, only : phtcnt, rxntot, gas_pcnst use chem_mods, only : rxt_tag_cnt, rxt_tag_lst, rxt_tag_map, extcnt, num_rnts +#ifdef OSLO_AERO + use oslo_aero_dust, only : dust_names, ndust => dust_nbin +#else use dust_model, only : dust_names, ndust => dust_nbin +#endif use ppgrid, only : pcols, pver use phys_control, only : phys_getopts use carma_flags_mod, only : carma_hetchem_feedback diff --git a/src/chemistry/mozart/mo_photo.F90 b/src/chemistry/mozart/mo_photo.F90 index d02570d5b0..6a090ca673 100644 --- a/src/chemistry/mozart/mo_photo.F90 +++ b/src/chemistry/mozart/mo_photo.F90 @@ -119,7 +119,11 @@ subroutine photo_inti( xs_coef_file, xs_short_file, xs_long_file, rsf_file, & use ioFileMod, only : getfil use mo_chem_utls, only : get_spc_ndx, get_rxt_ndx, get_inv_ndx use mo_jlong, only : jlong_init +#ifdef OSLO_AERO + use oslo_aero_seasalt, only : sslt_names=>seasalt_names, sslt_ncnst=>seasalt_nbin +#else use seasalt_model, only : sslt_names=>seasalt_names, sslt_ncnst=>seasalt_nbin +#endif use mo_jshort, only : jshort_init use mo_jeuv, only : jeuv_init, neuv use phys_grid, only : get_ncols_p, get_rlat_all_p @@ -976,7 +980,11 @@ subroutine xactive_photo( photos, vmr, temper, cwat, cldfr, & use mo_photoin, only : photoin use mo_tuv_inti, only : nlng use time_manager, only : get_curr_date +#ifdef OSLO_AERO + use oslo_aero_dust, only : dust_nbin +#else use dust_model, only : dust_nbin +#endif use phys_grid, only : get_rlat_all_p, get_rlon_all_p implicit none diff --git a/src/chemistry/mozart/mo_setaer.F90 b/src/chemistry/mozart/mo_setaer.F90 index 34442f5ae5..58b25414aa 100644 --- a/src/chemistry/mozart/mo_setaer.F90 +++ b/src/chemistry/mozart/mo_setaer.F90 @@ -655,8 +655,13 @@ subroutine setaer( z, airden, rh, aocs1, aocs2, acbs1, acbs2,& use chem_mods, only : adv_mass use mo_constants, only : avogadro use mo_chem_utls, only : get_spc_ndx +#ifdef OSLO_AERO + use oslo_aero_dust, only : dust_names + use oslo_aero_seasalt, only : sslt_names=>seasalt_names +#else use dust_model, only : dust_names use seasalt_model, only : sslt_names=>seasalt_names +#endif implicit none diff --git a/src/chemistry/mozart/mo_usrrxt.F90 b/src/chemistry/mozart/mo_usrrxt.F90 index e77d711f6c..6cb617b894 100644 --- a/src/chemistry/mozart/mo_usrrxt.F90 +++ b/src/chemistry/mozart/mo_usrrxt.F90 @@ -3,6 +3,9 @@ module mo_usrrxt use shr_kind_mod, only : r8 => shr_kind_r8 use cam_logfile, only : iulog use ppgrid, only : pver, pcols +#ifdef OSLO_AERO + use commondefinitions, only: nmodes_oslo=> nmodes +#endif implicit none @@ -570,10 +573,13 @@ subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, & real(r8), pointer :: sfc_array(:,:,:), dm_array(:,:,:) +#ifdef OSLO_AERO + ntot_amode = nmodes_oslo +#else ! get info about the modal aerosols ! get ntot_amode call rad_cnst_get_info(0, nmodes=ntot_amode) - +#endif if (ntot_amode>0) then allocate(sfc_array(pcols,pver,ntot_amode), dm_array(pcols,pver,ntot_amode) ) else @@ -1182,7 +1188,7 @@ subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, & where( tp(:ncol) < trlim3 ) rxt(:,k,ion3_ndx) = 1.4e-10_r8 * tp(:)**.44_r8 rxt(:,k,ion11_ndx) = 1.e-11_r8 * tp(:)**.23_r8 - elsewhere + elsewhere rxt(:,k,ion3_ndx) = 5.2e-11_r8 / tp(:)**.2_r8 rxt(:,k,ion11_ndx) = 3.6e-12_r8 / tp(:)**.41_r8 end where diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 9e788a6726..810d610d67 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -1,59 +1,59 @@ -!=============================================================================== -! Modal Aerosol Model -!=============================================================================== module aero_model - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst, cnst_name, cnst_get_ind - use ppgrid, only: pcols, pver, pverp - use phys_control, only: phys_getopts, cam_physpkg_is - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use perf_mod, only: t_startf, t_stopf - use camsrfexch, only: cam_in_t, cam_out_t - use aerodep_flx, only: aerodep_flx_prescribed - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc - use physics_buffer, only: pbuf_get_field, pbuf_get_index, pbuf_set_field - use physconst, only: gravit, rair, rhoh2o, pi - use spmd_utils, only: masterproc - use time_manager, only: get_nstep - use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only - use chem_mods, only: gas_pcnst, adv_mass - use mo_tracname, only: solsym - use mo_setsox, only: setsox - use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri - use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx - use ref_pres, only: top_lev => clim_modal_aero_top_lev - use drydep_mod, only: inidrydep - use wetdep, only: wetdep_init + !=============================================================================== + ! Oslo Aerosol Model + ! Note: SPCAM not supported here + !=============================================================================== + + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only: pcnst, cnst_name, cnst_get_ind + use ppgrid, only: pcols, pver, pverp + use phys_control, only: phys_getopts, cam_physpkg_is + use cam_abortutils, only: endrun + use cam_logfile, only: iulog + use perf_mod, only: t_startf, t_stopf + use camsrfexch, only: cam_in_t, cam_out_t + use aerodep_flx, only: aerodep_flx_prescribed + use physics_types, only: physics_state, physics_ptend, physics_ptend_init + use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index, pbuf_set_field + use physconst, only: gravit, rair, rhoh2o, pi + use spmd_utils, only: masterproc + use time_manager, only: get_nstep + use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only + use chem_mods, only: gas_pcnst, adv_mass + use mo_tracname, only: solsym + use mo_setsox, only: setsox + use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri + use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx + use ref_pres, only: top_lev => clim_modal_aero_top_lev ! - use oslo_aero_depos, only: oslo_aero_depos_init, oslo_aero_depos_dry, oslo_aero_depos_wet - use oslo_aero_coag, only: coagtend, clcoag - use oslo_aero_coag, only: initializeCoagulationReceivers - use oslo_aero_coag, only: initializeCoagulationCoefficients - use oslo_aero_coag, only: initializeCoagulationOutput - use oslo_aero_utils, only: calculateNumberConcentration - use oslo_aero_condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4 - use oslo_aero_condtend, only: registerCondensation, initializeCondensation, condtend - use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName - use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers - use aerosoldef, only: lifeCycleNumberMedianRadius - use aerosoldef, only: getCloudTracerName - use aerosoldef, only: aero_register - use sox_cldaero_mod, only: sox_cldaero_init - use oslo_aero_interp_log, only: initlogn - use seasalt_model, only: seasalt_init, seasalt_emis, seasalt_active - use dust_model, only: dust_init, dust_emis, dust_active - use oslo_ocean_intr, only: oslo_ocean_init, oslo_dms_emis_intr - use oslo_aero_sw_tables, only: initopt, initopt_lw - use commondefinitions, only: originalSigma, originalNumberMedianRadius - use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes - use const, only: numberToSurface + use oslo_aero_depos, only: oslo_aero_depos_init + use oslo_aero_depos, only: oslo_aero_depos_dry, oslo_aero_depos_wet, oslo_aero_wetdep_init + use oslo_aero_coag, only: coagtend, clcoag + use oslo_aero_coag, only: initializeCoagulationReceivers + use oslo_aero_coag, only: initializeCoagulationCoefficients + use oslo_aero_coag, only: initializeCoagulationOutput + use oslo_aero_utils, only: calculateNumberConcentration + use oslo_aero_condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4 + use oslo_aero_condtend, only: registerCondensation, initializeCondensation, condtend + use oslo_aero_interp_log, only: initlogn + use oslo_aero_seasalt, only: oslo_aero_seasalt_init, oslo_aero_seasalt_emis, seasalt_active + use oslo_aero_dust, only: oslo_aero_dust_init, oslo_aero_dust_emis, dust_active + use oslo_ocean_intr, only: oslo_ocean_init, oslo_dms_emis_intr + use oslo_aero_sw_tables, only: initopt, initopt_lw + use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName + use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers + use aerosoldef, only: lifeCycleNumberMedianRadius + use aerosoldef, only: getCloudTracerName + use aerosoldef, only: aero_register + use oslo_aero_sox_cldaero, only: sox_cldaero_init + use commondefinitions, only: originalSigma, originalNumberMedianRadius + use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes + use const, only: numberToSurface use calcaersize #ifdef AEROCOM - use aerocom_opt_mod, only: initaeropt - use aerocom_dry_mod, only: initdryp + use aerocom_opt_mod, only: initaeropt + use aerocom_dry_mod, only: initdryp #endif implicit none @@ -75,8 +75,6 @@ module aero_model integer :: nmodes ! number of modes integer :: pblh_idx= 0 integer :: ndx_h2so4, ndx_soa_lv, ndx_soa_sv ! for surf_area_dens - integer :: ndrydep = 0 - integer :: nwetdep = 0 logical :: convproc_do_aer ! Namelist variables @@ -87,12 +85,12 @@ module aero_model real(r8) :: sol_factic_interstitial = 0.4_r8 real(r8) :: seasalt_emis_scale +!============================================================================= contains +!============================================================================= - !============================================================================= - ! reads aerosol namelist options - !============================================================================= subroutine aero_model_readnl(nlfile) + ! read aerosol namelist options use namelist_utils, only: find_group_name use mpishorthand @@ -121,7 +119,6 @@ subroutine aero_model_readnl(nlfile) end if close(unitn) end if - #ifdef SPMD ! Broadcast namelist variables call mpibcast(aer_wetdep_list, len(aer_wetdep_list(1))*pcnst, mpichar, 0, mpicom) @@ -164,21 +161,17 @@ subroutine aero_model_init( pbuf2d ) call initopt call initlogn call initopt_lw + call initializeCondensation() + call oslo_ocean_init() + call oslo_aero_depos_init(pbuf2d) + call oslo_aero_dust_init() + call oslo_aero_seasalt_init() !seasalt_emis_scale) + call oslo_aero_wetdep_init() #ifdef AEROCOM call initaeropt() call initdryp() #endif - call initializeCondensation() - call oslo_ocean_init() - call oslo_aero_depos_init(pbuf2d) - call dust_init() - call seasalt_init() !seasalt_emis_scale) - call wetdep_init() - - nwetdep = 0 - ndrydep = 0 - call inidrydep(rair, gravit) dummy = 'RAM1' call addfld (dummy,horiz_only, 'A','frac','RAM1') if ( history_aerosol ) then @@ -452,15 +445,12 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ real(r8) :: delt_inverse ! 1 / timestep real(r8), pointer :: pblh(:) character(len=32) :: name - logical :: is_spcam_m2005 nstep = get_nstep() - is_spcam_m2005 = cam_physpkg_is('spcam_m2005') - delt_inverse = 1.0_r8 / delt - !Get height of boundary layer (needed for boundary layer nucleation) + ! Get height of boundary layer (needed for boundary layer nucleation) call pbuf_get_field(pbuf, pblh_idx, pblh) ! calculate tendency due to gas phase chemistry and processes @@ -474,14 +464,13 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ call outfld( name, wrk(:ncol), ncol, lchnk ) enddo - ! Get mass mixing ratios at start of time step + ! Get mass mixing ratios at start of time step call vmr2mmr( vmr0, mmr_tend_ncols, mbar, ncol ) mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_H2SO4) = mmr_tend_ncols(1:ncol,:,ndx_h2so4) mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) = mmr_tend_ncols(1:ncol,:,ndx_soa_lv) mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) = mmr_tend_ncols(1:ncol,:,ndx_soa_sv) ! ! Aerosol processes ... - ! call qqcw2vmr( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) ! save h2so4 change by gas phase chem (for later new particle nucleation) @@ -492,85 +481,54 @@ subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_ del_soa_lv_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_soa_lv) - vmr0(1:ncol,:,ndx_soa_lv) del_soa_sv_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_soa_sv) - vmr0(1:ncol,:,ndx_soa_sv) - if (.not. is_spcam_m2005) then ! regular CAM - dvmrdt(:ncol,:,:) = vmr(:ncol,:,:) - dvmrcwdt(:ncol,:,:) = vmrcw(:ncol,:,:) - - !Save intermediate concentrations - dvmrdt_sv1 = vmr - dvmrcwdt_sv1 = vmrcw - - ! aqueous chemistry ... - - call setsox( & - ncol, & - lchnk, & - loffset, & - delt, & - pmid, & - pdel, & - tfld, & - mbar, & - cwat, & - cldfr, & - cldnum, & - airdens, & - invariants, & - vmrcw, & - vmr, & - xphlwc, & - aqso4, & - aqh2so4, & - aqso4_h2o2, & - aqso4_o3 & - ) - - call outfld( 'AQSO4_H2O2', aqso4_h2o2(:ncol), ncol, lchnk) - call outfld( 'AQSO4_O3', aqso4_o3(:ncol), ncol, lchnk) - call outfld( 'XPH_LWC', xphlwc(:ncol,:), ncol, lchnk ) - - - ! vmr tendency from aqchem and soa routines - dvmrdt_sv1 = (vmr - dvmrdt_sv1)/delt - dvmrcwdt_sv1 = (vmrcw - dvmrcwdt_sv1)/delt - - if(ndx_h2so4 .gt. 0)then - del_h2so4_aqchem(:ncol,:) = dvmrdt_sv1(:ncol,:,ndx_h2so4)*delt !"production rate" of H2SO4 - else - del_h2so4_aqchem(:ncol,:) = 0.0_r8 - end if - - do m = 1,gas_pcnst - wrk(:ncol) = 0._r8 - do k = 1,pver - wrk(:ncol) = wrk(:ncol) + dvmrdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit - end do - name = 'AQ_'//trim(solsym(m)) - call outfld( name, wrk(:ncol), ncol, lchnk ) - - !In oslo aero also write out the tendencies for the - !cloud borne aerosols... - n = physicsIndex(m) - if (n.le.pcnst) then - if(getCloudTracerIndexDirect(n) .gt. 0)then - name = 'AQ_'//trim(getCloudTracerName(n)) - wrk(:ncol)=0.0_r8 - do k=1,pver - wrk(:ncol) = wrk(:ncol) + dvmrcwdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit - end do - call outfld( name, wrk(:ncol), ncol, lchnk ) - end if + dvmrdt(:ncol,:,:) = vmr(:ncol,:,:) + dvmrcwdt(:ncol,:,:) = vmrcw(:ncol,:,:) + + !Save intermediate concentrations + dvmrdt_sv1 = vmr + dvmrcwdt_sv1 = vmrcw + + ! aqueous chemistry ... + call setsox( ncol, lchnk, loffset, delt, pmid, pdel, tfld, mbar, cwat, & + cldfr, cldnum, airdens, invariants, vmrcw, vmr, xphlwc, & + aqso4, aqh2so4, aqso4_h2o2, aqso4_o3) + + call outfld( 'AQSO4_H2O2', aqso4_h2o2(:ncol), ncol, lchnk) + call outfld( 'AQSO4_O3', aqso4_o3(:ncol), ncol, lchnk) + call outfld( 'XPH_LWC', xphlwc(:ncol,:), ncol, lchnk ) + + ! vmr tendency from aqchem and soa routines + dvmrdt_sv1 = (vmr - dvmrdt_sv1)/delt + dvmrcwdt_sv1 = (vmrcw - dvmrcwdt_sv1)/delt + + if(ndx_h2so4 .gt. 0)then + del_h2so4_aqchem(:ncol,:) = dvmrdt_sv1(:ncol,:,ndx_h2so4)*delt !"production rate" of H2SO4 + else + del_h2so4_aqchem(:ncol,:) = 0.0_r8 + end if + + do m = 1,gas_pcnst + wrk(:ncol) = 0._r8 + do k = 1,pver + wrk(:ncol) = wrk(:ncol) + dvmrdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + end do + name = 'AQ_'//trim(solsym(m)) + call outfld( name, wrk(:ncol), ncol, lchnk ) + + !In oslo aero also write out the tendencies for the + !cloud borne aerosols... + n = physicsIndex(m) + if (n.le.pcnst) then + if(getCloudTracerIndexDirect(n) .gt. 0)then + name = 'AQ_'//trim(getCloudTracerName(n)) + wrk(:ncol)=0.0_r8 + do k=1,pver + wrk(:ncol) = wrk(:ncol) + dvmrcwdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit + end do + call outfld( name, wrk(:ncol), ncol, lchnk ) end if - enddo - - else if (is_spcam_m2005) then ! SPCAM ECPP - ! when ECPP is used, aqueous chemistry is done in ECPP, - ! and not updated here. - ! Minghuai Wang, 2010-02 (Minghuai.Wang@pnl.gov) - ! - dvmrdt = 0.0_r8 - dvmrcwdt = 0.0_r8 - endif + end if + enddo ! condensation call vmr2mmr( vmr, mmr_tend_ncols, mbar, ncol ) @@ -631,12 +589,12 @@ subroutine aero_model_emissions( state, cam_in ) type(cam_in_t), intent(inout) :: cam_in ! import state if (dust_active) then - call dust_emis( state, cam_in) + call oslo_aero_dust_emis( state, cam_in) ! some dust emis diagnostics ... endif if (seasalt_active) then - call seasalt_emis(state, cam_in) + call oslo_aero_seasalt_emis(state, cam_in) endif !Pick up correct DMS emissions (replace values from file if requested) diff --git a/src/chemistry/oslo_aero/dust_model.F90 b/src/chemistry/oslo_aero/dust_model.F90 deleted file mode 100644 index 68c72e03a7..0000000000 --- a/src/chemistry/oslo_aero/dust_model.F90 +++ /dev/null @@ -1,147 +0,0 @@ -module dust_model - - use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl - - implicit none - private - - integer, parameter :: numberOfDustModes = 2 !define in aerosoldef? - character(len=6), public, dimension(10) :: dust_names - - integer :: tracerMap(numberOfDustModes) = (/-99, -99/) !index of dust tracers in the modes - - real(r8), parameter :: emis_fraction_in_mode(numberOfDustModes) = (/0.13_r8, 0.87_r8 /) - integer, parameter, public :: dust_nbin = numberOfDustModes - - !Related to soil erodibility - real(r8) :: dust_emis_fact = -1.e36_r8 ! tuning parameter for dust emissions - character(len=cl) :: soil_erod_file = 'soil_erod_file' ! full pathname for soil erodibility dataset - - logical, parameter, public :: dust_active = .TRUE. - - ! public routines - public dust_readnl - public dust_init - public dust_emis - -!=============================================================================== -contains -!=============================================================================== - - subroutine dust_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use cam_abortutils, only: endrun - use spmd_utils, only: masterproc - use mpishorthand - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'dust_readnl' - - namelist /dust_nl/ dust_emis_fact, soil_erod_file - !----------------------------------------------------------------------------- - - ! Read namelist - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'dust_nl', status=ierr) - if (ierr == 0) then - read(unitn, dust_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if -#ifdef SPMD - ! Broadcast namelist variables - call mpibcast(dust_emis_fact, 1, mpir8, 0, mpicom) - call mpibcast(soil_erod_file, len(soil_erod_file), mpichar, 0, mpicom) -#endif - end subroutine dust_readnl - - !=============================================================================== - subroutine dust_init() - - use soil_erod_mod, only: soil_erod_init - use aerosoldef, only: l_dst_a2, l_dst_a3 - use constituents, only: cnst_name - - integer :: i - - call soil_erod_init( dust_emis_fact, soil_erod_file ) - - ! Set module variables - tracerMap(1) = l_dst_a2 - tracerMap(2) = l_dst_a3 - - dust_names(:)=" " - do i=1,numberOfDustModes - dust_names(i) = cnst_name(tracerMap(i)) - end do - - end subroutine dust_init - - !=============================================================================== - subroutine dust_emis(state, cam_in) - - !----------------------------------------------------------------------- - ! Purpose: Interface to emission of all dusts. - ! Notice that the mobilization is calculated in the land model and - ! the soil erodibility factor is applied here. - !----------------------------------------------------------------------- - - use ppgrid, only: pcols - use physics_types, only: physics_state - use camsrfexch, only: cam_in_t - use soil_erod_mod, only: soil_erod_fact, soil_erodibility - - ! Arguments: - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), target, intent(inout) :: cam_in ! import state - - ! Local variables - integer :: lchnk - integer :: ncol - integer :: i,n - real(r8) :: soil_erod_tmp(pcols) - real(r8) :: totalEmissionFlux(pcols) - real(r8), pointer :: cflx(:,:) - - lchnk = state%lchnk - ncol = state%ncol - - !Filter away unreasonable values for soil erodibility - !(using low values e.g. gives emissions in greenland..) - where(soil_erodibility(:,lchnk) .lt. 0.1_r8) - soil_erod_tmp(:)=0.0_r8 - elsewhere - soil_erod_tmp(:)=soil_erodibility(:,lchnk) - end where - - totalEmissionFlux(:)=0.0_r8 - do i=1,ncol - totalEmissionFlux(i) = totalEmissionFlux(i) + sum(cam_in%dstflx(i,:)) - end do - - !Note that following CESM use of "dust_emis_fact", the emissions are - !scaled by the INVERSE of the factor!! - !There is another random scale factor of 1.15 there. Adapting the exact - !same formulation as MAM now and tune later - !As of NE-380: Oslo dust emissions are 2/3 of CAM emissions - - cflx => cam_in%cflx - do n=1, numberOfDustModes - cflx(:ncol, tracerMap(n)) = -1.0_r8*emis_fraction_in_mode(n) & - *totalEmissionFlux(:ncol)*soil_erod_tmp(:ncol)/(dust_emis_fact)*1.15_r8 ! gives better AOD close to dust sources - end do - - end subroutine dust_emis - -end module dust_model diff --git a/src/chemistry/oslo_aero/oslo_aero_depos.F90 b/src/chemistry/oslo_aero/oslo_aero_depos.F90 index 21201d4d88..41e79f4a2b 100644 --- a/src/chemistry/oslo_aero/oslo_aero_depos.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_depos.F90 @@ -3,52 +3,91 @@ module oslo_aero_depos !------------------------------------------------------------------------------------------------ ! Compute the contributions from oslo aero modal components of wet and dry ! deposition at the surface into the fields passed to the coupler. + ! Wet deposition routines for both aerosols and gas phase constituents. !------------------------------------------------------------------------------------------------ use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols, pver, pverp, begchunk, endchunk - use constituents, only: pcnst, cnst_name - use phys_control, only: phys_getopts + use constituents, only: pcnst, cnst_name, cnst_get_ind + use phys_control, only: phys_getopts, cam_physpkg_is use cam_abortutils, only: endrun + use cam_logfile, only: iulog use camsrfexch, only: cam_in_t, cam_out_t use time_manager, only: is_first_step use aerodep_flx, only: aerodep_flx_prescribed use mo_drydep, only: n_land_type, fraction_landuse use physics_types, only: physics_state, physics_ptend, physics_ptend_init use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_get_field, pbuf_get_index - use physconst, only: gravit, rair, rhoh2o, boltz, pi + use physics_buffer, only: pbuf_old_tim_idx + use physconst, only: gravit, rair, rhoh2o, boltz, pi, tmelt use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only use ref_pres, only: top_lev => clim_modal_aero_top_lev - use drydep_mod, only: calcram - use wetdep, only: wetdepa_v2, wetdep_inputs_set, wetdep_inputs_t ! - ! use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac - ! use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 use oslo_aero_dust_sediment, only: oslo_aero_dust_sediment_tend, oslo_aero_dust_sediment_vel use aerosoldef use commondefinitions + ! use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac + ! use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 implicit none private ! Make default type private to the module ! Public interfaces public :: oslo_aero_depos_init - public :: oslo_aero_depos_dry ! dry deposition - public :: oslo_aero_depos_wet ! wet deposition + public :: oslo_aero_depos_dry ! dry deposition + public :: oslo_aero_depos_wet ! wet deposition + public :: oslo_aero_wetdep_init ! Private interfaces private :: oslo_aero_depvel_part private :: oslo_set_srf_drydep private :: oslo_set_srf_wetdep + private :: calcram + private :: wetdep_inputs_t + private :: wetdep_inputs_set + private :: wetdepa_v2 ! scavenging codes for very soluble aerosols -- CAM5 version + private :: wetdepg ! scavenging of gas phase constituents by henry's law + private :: clddiag ! calc of cloudy volume and rain mixing ratio real(r8), public :: sol_facti_cloud_borne - integer :: fracis_idx = 0 - integer :: prain_idx = 0 - integer :: nevapr_shcu_idx = 0 - logical :: convproc_do_aer = .FALSE. - logical :: drydep_lq(pcnst) - logical :: wetdep_lq(pcnst) + real(r8), parameter :: cmftau = 3600._r8 + real(r8), parameter :: rhoh2o = 1000._r8 ! density of water + real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole + + type wetdep_inputs_t + real(r8), pointer :: cldt(:,:) => null() ! cloud fraction + real(r8), pointer :: qme(:,:) => null() + real(r8), pointer :: prain(:,:) => null() + real(r8), pointer :: evapr(:,:) => null() + real(r8) :: cldcu(pcols,pver) ! convective cloud fraction, currently empty + real(r8) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation + real(r8) :: cmfdqr(pcols,pver) ! convective production of rain + real(r8) :: conicw(pcols,pver) ! convective in-cloud water + real(r8) :: totcond(pcols, pver) ! total condensate + real(r8) :: cldv(pcols,pver) ! cloudy volume undergoing wet chem and scavenging + real(r8) :: cldvcu(pcols,pver) ! Convective precipitation area at the top interface of current layer + real(r8) :: cldvst(pcols,pver) ! Stratiform precipitation area at the top interface of current layer + end type wetdep_inputs_t + + logical :: convproc_do_aer = .FALSE. + logical :: drydep_lq(pcnst) + logical :: wetdep_lq(pcnst) + + integer :: fracis_idx = 0 + integer :: prain_idx = 0 + integer :: cld_idx = 0 + integer :: qme_idx = 0 + integer :: nevapr_idx = 0 + integer :: icwmrdp_idx = 0 + integer :: icwmrsh_idx = 0 + integer :: rprddp_idx = 0 + integer :: rprdsh_idx = 0 + integer :: sh_frac_idx = 0 + integer :: dp_frac_idx = 0 + integer :: nevapr_shcu_idx = 0 + integer :: nevapr_dpcu_idx = 0 + integer :: ixcldice, ixcldliq !=============================================================================== contains @@ -143,7 +182,7 @@ subroutine oslo_aero_depos_init( pbuf2d ) call add_default (trim(aName)//'DDF', 1, ' ') call add_default (trim(aName)//'TBF', 1, ' ') call add_default (trim(aName)//'GVF', 1, ' ') - !call add_default (trim(aName)//'DDV', 1, ' ') + !call add_default (trim(aName)//'DDV', 1, ' ') endif ! some tracers are not in cloud water @@ -292,7 +331,6 @@ subroutine oslo_aero_depos_dry ( state, pbuf, obklen, ustar, cam_in, dt, cam_ou rho(:ncol,:)= state%pmid(:ncol,:)/(rair*state%t(:ncol,:)) is_done(:,:) = .false. - ! ! calc settling/deposition velocities for cloud droplets (and cloud-borne aerosols) ! *** mean drop radius should eventually be computed from ndrop and qcldwtr rad_drop(:,:) = 5.0e-6_r8 @@ -394,8 +432,8 @@ subroutine oslo_aero_depos_dry ( state, pbuf, obklen, ustar, cam_in, dt, cam_ou ! calculate the tendencies and sfc fluxes from the above velocities call oslo_aero_dust_sediment_tend(ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, & - dusttend_to_ll_out=interfaceTendToLowestLayer) + state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, & + dusttend_to_ll_out=interfaceTendToLowestLayer) !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% !%%%%%% FIX FOR SHORT DRYDEP LIFE-TIMES @@ -644,7 +682,7 @@ subroutine oslo_aero_depos_wet ( state, dt, dlf, cam_out, ptend, pbuf) sol_factb = 0.0_r8 ! all below-cloud scav OFF (anything cloud-borne is located "in-cloud") sol_facti = sol_facti_cloud_borne ! strat in-cloud scav cloud-borne tuning factor sol_factic = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean - ! that conv precip collects strat droplets) + ! that conv precip collects strat droplets) f_act_conv = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean end if @@ -896,7 +934,7 @@ subroutine oslo_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc real(r8) :: radius_moment(pcols,pver) ! median radius (m) for moment real(r8) :: lnsig ! ln(sig_part) real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity - ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) + ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) integer :: lt real(r8) :: lnd_frc real(r8) :: wrk1, wrk2, wrk3 @@ -1109,8 +1147,8 @@ subroutine oslo_set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) ! organic carbon fluxes ! djlo : skipped the bc_a contribution (was about om !) cam_out%ocphidry(i) = aerdepdryis(i,l_om_ni)+aerdepdrycw(i,l_om_ni)+ & - aerdepdryis(i,l_om_ai)+aerdepdrycw(i,l_om_ai)+ & - aerdepdryis(i,l_om_ac)+aerdepdrycw(i,l_om_ac) + aerdepdryis(i,l_om_ai)+aerdepdrycw(i,l_om_ai)+ & + aerdepdryis(i,l_om_ac)+aerdepdrycw(i,l_om_ac) cam_out%ocphidry(i) = 0._r8 cam_out%ocphodry(i) = 0._r8 @@ -1127,4 +1165,823 @@ subroutine oslo_set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) end subroutine oslo_set_srf_drydep + !=============================================================================== + subroutine calcram(ncol, landfrac, icefrac, ocnfrac, obklen, & + ustar, ram1in, ram1, t, pmid, pdel, fvin, fv) + + ! Calc aerodynamic resistance over oceans and sea ice (comes in from land model) + ! from Seinfeld and Pandis, p.963. Author: Natalie Mahowald + + integer , intent(in) :: ncol + real(r8) , intent(in) :: ram1in(pcols) ! aerodynamical resistance (s/m) + real(r8) , intent(in) :: fvin(pcols) ! sfc frc vel from land + real(r8) , intent(out) :: ram1(pcols) ! aerodynamical resistance (s/m) + real(r8) , intent(out) :: fv(pcols) ! sfc frc vel from land + real(r8) , intent(in) :: obklen(pcols) ! obklen + real(r8) , intent(in) :: ustar(pcols) ! sfc fric vel + real(r8) , intent(in) :: landfrac(pcols) ! land fraction + real(r8) , intent(in) :: icefrac(pcols) ! ice fraction + real(r8) , intent(in) :: ocnfrac(pcols) ! ocean fraction + real(r8) , intent(in) :: t(pcols) ! atm temperature (K) + real(r8) , intent(in) :: pmid(pcols) ! atm pressure (Pa) + real(r8) , intent(in) :: pdel(pcols) ! atm pressure (Pa) + + ! local variables + real(r8), parameter :: zzocen = 0.0001_r8 ! Ocean aerodynamic roughness length + real(r8), parameter :: zzsice = 0.0400_r8 ! Sea ice aerodynamic roughness length + real(r8), parameter :: xkar = 0.4_r8 ! Von Karman constant + real(r8) :: z,psi,psi0,nu,nu0,temp,ram + integer :: i + + do i = 1,ncol + z=pdel(i)*rair*t(i)/pmid(i)/gravit/2.0_r8 !use half the layer height like Ganzefeld and Lelieveld, 1995 + if(obklen(i).eq.0) then + psi=0._r8 + psi0=0._r8 + else + psi=min(max(z/obklen(i),-1.0_r8),1.0_r8) + psi0=min(max(zzocen/obklen(i),-1.0_r8),1.0_r8) + endif + temp=z/zzocen + if(icefrac(i) > 0.5_r8) then + if(obklen(i).gt.0) then + psi0=min(max(zzsice/obklen(i),-1.0_r8),1.0_r8) + else + psi0=0.0_r8 + endif + temp=z/zzsice + endif + if(psi> 0._r8) then + ram=1/xkar/ustar(i)*(log(temp)+4.7_r8*(psi-psi0)) + else + nu=(1.00_r8-15.000_r8*psi)**(.25_r8) + nu0=(1.000_r8-15.000_r8*psi0)**(.25_r8) + if(ustar(i).ne.0._r8) then + ram=1/xkar/ustar(i)*(log(temp) & + +log(((nu0**2+1.00_r8)*(nu0+1.0_r8)**2)/((nu**2+1.0_r8)*(nu+1.00_r8)**2)) & + +2.0_r8*(atan(nu)-atan(nu0))) + else + ram=0._r8 + endif + endif + if(landfrac(i) < 0.000000001_r8) then + fv(i)=ustar(i) + ram1(i)=ram + else + fv(i)=fvin(i) + ram1(i)=ram1in(i) + endif + enddo + + ! fvitt -- fv == 0 causes a floating point exception in dry dep of sea salts and dust + where ( fv(:ncol) == 0._r8 ) + fv(:ncol) = 1.e-12_r8 + endwhere + end subroutine calcram + + !============================================================================== + subroutine oslo_aero_wetdep_init() + + ! Initialize module variables for wet deposition + + cld_idx = pbuf_get_index('CLD') + qme_idx = pbuf_get_index('QME') + prain_idx = pbuf_get_index('PRAIN') + nevapr_idx = pbuf_get_index('NEVAPR') + + icwmrdp_idx = pbuf_get_index('ICWMRDP') + rprddp_idx = pbuf_get_index('RPRDDP') + icwmrsh_idx = pbuf_get_index('ICWMRSH') + rprdsh_idx = pbuf_get_index('RPRDSH') + sh_frac_idx = pbuf_get_index('SH_FRAC' ) + dp_frac_idx = pbuf_get_index('DP_FRAC') + nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') + nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') + + call cnst_get_ind('CLDICE', ixcldice) + call cnst_get_ind('CLDLIQ', ixcldliq) + + endsubroutine oslo_aero_wetdep_init + + !============================================================================== + subroutine wetdep_inputs_set( state, pbuf, inputs ) + + ! gather up the inputs needed for the wetdepa routines + + ! arguments + type(physics_state), intent(in ) :: state ! physics state + type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer + type(wetdep_inputs_t), intent(out) :: inputs ! collection of wetdepa inputs + + ! local variables + real(r8), pointer :: icwmrdp(:,:) ! in cloud water mixing ratio, deep convection + real(r8), pointer :: rprddp(:,:) ! rain production, deep convection + real(r8), pointer :: icwmrsh(:,:) ! in cloud water mixing ratio, deep convection + real(r8), pointer :: rprdsh(:,:) ! rain production, deep convection + real(r8), pointer :: sh_frac(:,:) ! Shallow convective cloud fraction + real(r8), pointer :: dp_frac(:,:) ! Deep convective cloud fraction + real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. + real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. + real(r8) :: rainmr(pcols,pver) ! mixing ratio of rain within cloud volume + real(r8) :: cldst(pcols,pver) ! Stratiform cloud fraction + integer :: itim, ncol + + ncol = state%ncol + itim = pbuf_old_tim_idx() + + call pbuf_get_field(pbuf, cld_idx, inputs%cldt, start=(/1,1,itim/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, qme_idx, inputs%qme ) + call pbuf_get_field(pbuf, prain_idx, inputs%prain ) + call pbuf_get_field(pbuf, nevapr_idx, inputs%evapr ) + call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp ) + call pbuf_get_field(pbuf, icwmrsh_idx, icwmrsh ) + call pbuf_get_field(pbuf, rprddp_idx, rprddp ) + call pbuf_get_field(pbuf, rprdsh_idx, rprdsh ) + call pbuf_get_field(pbuf, sh_frac_idx, sh_frac ) + call pbuf_get_field(pbuf, dp_frac_idx, dp_frac ) + call pbuf_get_field(pbuf, nevapr_shcu_idx, evapcsh ) + call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) + + inputs%cldcu(:ncol,:) = dp_frac(:ncol,:) + sh_frac(:ncol,:) + cldst(:ncol,:) = inputs%cldt(:ncol,:) - inputs%cldcu(:ncol,:) ! Stratiform cloud fraction + inputs%evapc(:ncol,:) = evapcsh(:ncol,:) + evapcdp(:ncol,:) + inputs%cmfdqr(:ncol,:) = rprddp(:ncol,:) + rprdsh(:ncol,:) + + ! sum deep and shallow convection contributions + if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then + inputs%conicw(:ncol,:) = (icwmrdp(:ncol,:)*dp_frac(:ncol,:) + icwmrsh(:ncol,:)*sh_frac(:ncol,:))/ & + max(0.01_r8, sh_frac(:ncol,:) + dp_frac(:ncol,:)) + else + inputs%conicw(:ncol,:) = icwmrdp(:ncol,:) + icwmrsh(:ncol,:) + end if + + inputs%totcond(:ncol,:) = state%q(:ncol,:,ixcldliq) + state%q(:ncol,:,ixcldice) + + call clddiag( state%t, state%pmid, state%pdel, inputs%cmfdqr, inputs%evapc, & + inputs%cldt, inputs%cldcu, cldst, inputs%qme, inputs%evapr, & + inputs%prain, inputs%cldv, inputs%cldvcu, inputs%cldvst, rainmr, state%ncol ) + + end subroutine wetdep_inputs_set + + !============================================================================== + subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & + cldt, cldcu, cldst, cme, evapr, & + prain, cldv, cldvcu, cldvst, rain, ncol) + + ! ------------------------------------------------------------------------------------ + ! Estimate the cloudy volume which is occupied by rain or cloud water as + ! the max between the local cloud amount or the + ! sum above of (cloud*positive precip production) sum total precip from above + ! ---------------------------------- x ------------------------ + ! sum above of (positive precip ) sum positive precip from above + ! Author: P. Rasch, Sungsu Park. Mar.2010 + ! ------------------------------------------------------------------------------------ + + ! Input arguments: + real(r8) , intent(in) :: t(pcols,pver) ! temperature (K) + real(r8) , intent(in) :: pmid(pcols,pver) ! pressure at layer midpoints + real(r8) , intent(in) :: pdel(pcols,pver) ! pressure difference across layers + real(r8) , intent(in) :: cmfdqr(pcols,pver) ! dq/dt due to convective rainout + real(r8) , intent(in) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation ( >= 0 ) + real(r8) , intent(in) :: cldt(pcols,pver) ! total cloud fraction + real(r8) , intent(in) :: cldcu(pcols,pver) ! Cumulus cloud fraction + real(r8) , intent(in) :: cldst(pcols,pver) ! Stratus cloud fraction + real(r8) , intent(in) :: cme(pcols,pver) ! rate of cond-evap within the cloud + real(r8) , intent(in) :: evapr(pcols,pver) ! rate of evaporation of falling precipitation (kg/kg/s) + real(r8) , intent(in) :: prain(pcols,pver) ! rate of conversion of condensate to precipitation (kg/kg/s) + integer , intent(in) :: ncol + + ! Output arguments: + real(r8), intent(out) :: cldv(pcols,pver) ! fraction occupied by rain or cloud water + real(r8), intent(out) :: cldvcu(pcols,pver) ! Convective precipitation volume + real(r8), intent(out) :: cldvst(pcols,pver) ! Stratiform precipitation volume + real(r8), intent(out) :: rain(pcols,pver) ! mixing ratio of rain (kg/kg) + + ! Local variables: + integer i, k + real(r8) convfw ! used in fallspeed calculation; taken from findmcnew + real(r8) sumppr(pcols) ! precipitation rate (kg/m2-s) + real(r8) sumpppr(pcols) ! sum of positive precips from above + real(r8) cldv1(pcols) ! precip weighted cloud fraction from above + real(r8) lprec ! local production rate of precip (kg/m2/s) + real(r8) lprecp ! local production rate of precip (kg/m2/s) if positive + real(r8) rho ! air density + real(r8) vfall + real(r8) sumppr_cu(pcols) ! Convective precipitation rate (kg/m2-s) + real(r8) sumpppr_cu(pcols) ! Sum of positive convective precips from above + real(r8) cldv1_cu(pcols) ! Convective precip weighted convective cloud fraction from above + real(r8) lprec_cu ! Local production rate of convective precip (kg/m2/s) + real(r8) lprecp_cu ! Local production rate of convective precip (kg/m2/s) if positive + real(r8) sumppr_st(pcols) ! Stratiform precipitation rate (kg/m2-s) + real(r8) sumpppr_st(pcols) ! Sum of positive stratiform precips from above + real(r8) cldv1_st(pcols) ! Stratiform precip weighted stratiform cloud fraction from above + real(r8) lprec_st ! Local production rate of stratiform precip (kg/m2/s) + real(r8) lprecp_st ! Local production rate of stratiform precip (kg/m2/s) if positive + ! ----------------------------------------------------------------------- + + convfw = 1.94_r8*2.13_r8*sqrt(rhoh2o*gravit*2.7e-4_r8) + do i=1,ncol + sumppr(i) = 0._r8 + cldv1(i) = 0._r8 + sumpppr(i) = 1.e-36_r8 + sumppr_cu(i) = 0._r8 + cldv1_cu(i) = 0._r8 + sumpppr_cu(i) = 1.e-36_r8 + sumppr_st(i) = 0._r8 + cldv1_st(i) = 0._r8 + sumpppr_st(i) = 1.e-36_r8 + end do + + do k = 1,pver + do i = 1,ncol + cldv(i,k) = & + max(min(1._r8, & + cldv1(i)/sumpppr(i) & + )*sumppr(i)/sumpppr(i), & + cldt(i,k) & + ) + lprec = pdel(i,k)/gravit * (prain(i,k)+cmfdqr(i,k)-evapr(i,k)) + lprecp = max(lprec,1.e-30_r8) + cldv1(i) = cldv1(i) + cldt(i,k)*lprecp + sumppr(i) = sumppr(i) + lprec + sumpppr(i) = sumpppr(i) + lprecp + + ! For convective precipitation volume at the top interface of each layer. Neglect the current layer. + cldvcu(i,k) = max(min(1._r8,cldv1_cu(i)/sumpppr_cu(i))*(sumppr_cu(i)/sumpppr_cu(i)),0._r8) + lprec_cu = (pdel(i,k)/gravit)*(cmfdqr(i,k)-evapc(i,k)) + lprecp_cu = max(lprec_cu,1.e-30_r8) + cldv1_cu(i) = cldv1_cu(i) + cldcu(i,k)*lprecp_cu + sumppr_cu(i) = sumppr_cu(i) + lprec_cu + sumpppr_cu(i) = sumpppr_cu(i) + lprecp_cu + + ! For stratiform precipitation volume at the top interface of each layer. Neglect the current layer. + cldvst(i,k) = max(min(1._r8,cldv1_st(i)/sumpppr_st(i))*(sumppr_st(i)/sumpppr_st(i)),0._r8) + lprec_st = (pdel(i,k)/gravit)*(prain(i,k)-evapr(i,k)) + lprecp_st = max(lprec_st,1.e-30_r8) + cldv1_st(i) = cldv1_st(i) + cldst(i,k)*lprecp_st + sumppr_st(i) = sumppr_st(i) + lprec_st + sumpppr_st(i) = sumpppr_st(i) + lprecp_st + + rain(i,k) = 0._r8 + if(t(i,k) .gt. tmelt) then + rho = pmid(i,k)/(rair*t(i,k)) + vfall = convfw/sqrt(rho) + rain(i,k) = sumppr(i)/(rho*vfall) + if (rain(i,k).lt.1.e-14_r8) rain(i,k) = 0._r8 + endif + end do + end do + + end subroutine clddiag + + !============================================================================== + subroutine wetdepa_v2( & + p, q, pdel, cldt, cldc, & + cmfdqr, evapc, conicw, precs, conds, & + evaps, cwat, tracer, deltat, scavt, & + iscavt, cldvcu, cldvst, dlf, fracis, & + sol_fact, ncol, scavcoef, is_strat_cloudborne, qqcw, & + f_act_conv, icscavt, isscavt, bcscavt, bsscavt, & + convproc_do_aer, rcscavt, rsscavt, & + sol_facti_in, sol_factic_in ) + + !----------------------------------------------------------------------- + ! scavenging code for very soluble aerosols + ! This is the CAM5 version of wetdepa. + !----------------------------------------------------------------------- + + real(r8), intent(in) ::& + p(pcols,pver), &! pressure + q(pcols,pver), &! moisture + pdel(pcols,pver), &! pressure thikness + cldt(pcols,pver), &! total cloud fraction + cldc(pcols,pver), &! convective cloud fraction + cmfdqr(pcols,pver), &! rate of production of convective precip + evapc(pcols,pver), &! Evaporation rate of convective precipitation + conicw(pcols,pver), &! convective cloud water + cwat(pcols,pver), &! cloud water amount + precs(pcols,pver), &! rate of production of stratiform precip + conds(pcols,pver), &! rate of production of condensate + evaps(pcols,pver), &! rate of evaporation of precip + cldvcu(pcols,pver), &! Convective precipitation area at the top interface of each layer + cldvst(pcols,pver), &! Stratiform precipitation area at the top interface of each layer + dlf(pcols,pver), &! Detrainment of convective condensate [kg/kg/s] + deltat, &! time step + tracer(pcols,pver) ! trace species + + ! If subroutine is called with just sol_fact: + ! sol_fact is used for both in- and below-cloud scavenging + ! If subroutine is called with optional argument sol_facti_in: + ! sol_fact is used for below cloud scavenging + ! sol_facti is used for in cloud scavenging + + real(r8), intent(in) :: sol_fact + integer, intent(in) :: ncol + real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) + real(r8), intent(out) :: scavt(pcols,pver) ! scavenging tend + real(r8), intent(out) :: iscavt(pcols,pver) ! incloud scavenging tends + real(r8), intent(out) :: fracis(pcols,pver) ! fraction of species not scavenged + + ! Setting is_strat_cloudborne=.true. indicates that tracer is stratiform-cloudborne aerosol. + ! This is only used by MAM code. The optional args qqcw and f_act_conv are not referenced + ! in this case. + ! Setting is_strat_cloudborne=.false. is being used to indicate that the tracers are the + ! interstitial modal aerosols. In this case the optional qqcw (the cloud borne mixing ratio + ! corresponding to the interstitial aerosol) must be provided, as well as the optional f_act_conv. + + logical, intent(in), optional :: is_strat_cloudborne + real(r8), intent(in), optional :: qqcw(pcols,pver) + real(r8), intent(in), optional :: f_act_conv(pcols,pver) + + real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) + real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds + + real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective + real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform + real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective + real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform + + ! Setting convproc_do_aer=.true. removes the resuspension term from bcscavt and + ! bsscavt and returns those terms as rcscavt and rsscavt respectively. + logical, intent(in), optional :: convproc_do_aer + real(r8), intent(out), optional :: rcscavt(pcols,pver) ! resuspension, convective + real(r8), intent(out), optional :: rsscavt(pcols,pver) ! resuspension, stratiform + + ! local variables + integer :: i, k + logical :: out_resuspension + real(r8) :: omsm ! 1 - (a small number) + real(r8) :: clds(pcols) ! stratiform cloud fraction + real(r8) :: fracev(pcols) ! fraction of precip from above that is evaporating + real(r8) :: fracev_cu(pcols) ! Fraction of convective precip from above that is evaporating + real(r8) :: fracp(pcols) ! fraction of cloud water converted to precip + real(r8) :: pdog(pcols) ! work variable (pdel/gravit) + real(r8) :: rpdog(pcols) ! work variable (gravit/pdel) + real(r8) :: precabc(pcols) ! conv precip from above (work array) + real(r8) :: precabs(pcols) ! strat precip from above (work array) + real(r8) :: rat(pcols) ! ratio of amount available to amount removed + real(r8) :: scavab(pcols) ! scavenged tracer flux from above (work array) + real(r8) :: scavabc(pcols) ! scavenged tracer flux from above (work array) + real(r8) :: srcc(pcols) ! tend for convective rain + real(r8) :: srcs(pcols) ! tend for stratiform rain + real(r8) :: srct(pcols) ! work variable + + real(r8) :: fins(pcols) ! fraction of rem. rate by strat rain + real(r8) :: finc(pcols) ! fraction of rem. rate by conv. rain + real(r8) :: conv_scav_ic(pcols) ! convective scavenging incloud + real(r8) :: conv_scav_bc(pcols) ! convective scavenging below cloud + real(r8) :: st_scav_ic(pcols) ! stratiform scavenging incloud + real(r8) :: st_scav_bc(pcols) ! stratiform scavenging below cloud + + real(r8) :: odds(pcols) ! limit on removal rate (proportional to prec) + real(r8) :: dblchek(pcols) + logical :: found + + real(r8) :: trac_qqcw(pcols) + real(r8) :: tracer_incu(pcols) + real(r8) :: tracer_mean(pcols) + + ! For stratiform cloud, cloudborne aerosol is treated explicitly, + ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. + ! For convective cloud, cloudborne aerosol is not treated explicitly, + ! and sol_factic is 1.0 for both cloudborne and interstitial. + + real(r8) :: sol_facti ! in cloud fraction of aerosol scavenged + real(r8) :: sol_factb ! below cloud fraction of aerosol scavenged + real(r8) :: sol_factic(pcols,pver) ! in cloud fraction of aerosol scavenged for convective clouds + + real(r8) :: rdeltat + ! ------------------------------------------------------------------------ + + omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero + + ! default (if other sol_facts aren't in call, set all to required sol_fact) + sol_facti = sol_fact + sol_factb = sol_fact + + if ( present(sol_facti_in) ) sol_facti = sol_facti_in + + sol_factic = sol_facti + if ( present(sol_factic_in ) ) sol_factic = sol_factic_in + + ! Determine whether resuspension fields are output. + out_resuspension = .false. + if (present(convproc_do_aer)) then + if (convproc_do_aer) then + if (present(bcscavt) .and. present(bsscavt) .and. & + present(rcscavt) .and. present(rsscavt) ) then + out_resuspension = .true. + else + call endrun('wetdepa_v2: bcscavt, bsscavt, rcscavt, rsscavt'// & + ' must be present when convproc_do_aero true') + end if + end if + end if + + ! this section of code is for highly soluble aerosols, + ! the assumption is that within the cloud that + ! all the tracer is in the cloud water + ! + ! for both convective and stratiform clouds, + ! the fraction of cloud water converted to precip defines + ! the amount of tracer which is pulled out. + + precabs(:ncol) = 0.0_r8 + precabc(:ncol) = 0.0_r8 + scavab(:ncol) = 0.0_r8 + scavabc(:ncol) = 0.0_r8 + + do k = 1, pver + do i = 1, ncol + + clds(i) = cldt(i,k) - cldc(i,k) + pdog(i) = pdel(i,k)/gravit + rpdog(i) = gravit/pdel(i,k) + rdeltat = 1.0_r8/deltat + + ! ****************** Evaporation ************************** + ! calculate the fraction of strat precip from above + ! which evaporates within this layer + fracev(i) = evaps(i,k)*pdog(i) & + /max(1.e-12_r8,precabs(i)) + + ! trap to ensure reasonable ratio bounds + fracev(i) = max(0._r8,min(1._r8,fracev(i))) + + ! Same as above but convective precipitation part + fracev_cu(i) = evapc(i,k)*pdog(i)/max(1.e-12_r8,precabc(i)) + fracev_cu(i) = max(0._r8,min(1._r8,fracev_cu(i))) + + ! ****************** Convection *************************** + ! + ! set odds proportional to fraction of the grid box that is swept by the + ! precipitation =precabc/rhoh20*(area of sphere projected on plane + ! /volume of sphere)*deltat + ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, + ! unless the fraction of the area that is cloud is less than odds, in which + ! case use the cloud fraction (assumes precabs is in kg/m2/s) + ! is really: precabs*3/4/1000./1e-3*deltat + ! here I use .1 from Balkanski + ! + ! use a local rate of convective rain production for incloud scav + ! + ! Fraction of convective cloud water converted to rain. This version is used + ! in 2 of the 3 branches below before fracp is reused in the stratiform calc. + ! NB: In below formula for fracp conicw is a LWC/IWC that has already + ! precipitated out, i.e., conicw does not contain precipitation + + fracp(i) = cmfdqr(i,k)*deltat / & + max( 1.e-12_r8, cldc(i,k)*conicw(i,k) + (cmfdqr(i,k)+dlf(i,k))*deltat ) + fracp(i) = max( min( 1._r8, fracp(i)), 0._r8 ) + + if ( present(is_strat_cloudborne) ) then + + if ( is_strat_cloudborne ) then + + ! convective scavenging + + conv_scav_ic(i) = 0._r8 + + conv_scav_bc(i) = 0._r8 + + ! stratiform scavenging + + fracp(i) = precs(i,k)*deltat / & + max( 1.e-12_r8, cwat(i,k) + precs(i,k)*deltat ) + fracp(i) = max( 0._r8, min(1._r8, fracp(i)) ) + st_scav_ic(i) = sol_facti *fracp(i)*tracer(i,k)*rdeltat + + st_scav_bc(i) = 0._r8 + + else + + ! convective scavenging + + trac_qqcw(i) = min(qqcw(i,k), & + tracer(i,k)*( clds(i)/max( 0.01_r8, 1._r8-clds(i) ) ) ) + + tracer_incu(i) = f_act_conv(i,k)*(tracer(i,k) + trac_qqcw(i)) + + conv_scav_ic(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer_incu(i)*rdeltat + + tracer_mean(i) = tracer(i,k)*(1._r8 - cldc(i,k)*f_act_conv(i,k)) - & + cldc(i,k)*f_act_conv(i,k)*trac_qqcw(i) + tracer_mean(i) = max(0._r8,tracer_mean(i)) + + odds(i) = precabc(i)/max(cldvcu(i,k),1.e-5_r8)*scavcoef(i,k)*deltat + odds(i) = max(min(1._r8,odds(i)),0._r8) + conv_scav_bc(i) = sol_factb *cldvcu(i,k)*odds(i)*tracer_mean(i)*rdeltat + + + ! stratiform scavenging + + st_scav_ic(i) = 0._r8 + + odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat + odds(i) = max(min(1._r8,odds(i)),0._r8) + st_scav_bc(i) = sol_factb *cldvst(i,k)*odds(i)*tracer_mean(i)*rdeltat + + end if + + else + + ! convective scavenging + + conv_scav_ic(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer(i,k)*rdeltat + + odds(i) = precabc(i)/max(cldvcu(i,k), 1.e-5_r8)*scavcoef(i,k)*deltat + odds(i) = max( min(1._r8, odds(i)), 0._r8) + conv_scav_bc(i) = sol_factb*cldvcu(i,k)*odds(i)*tracer(i,k)*rdeltat + + ! stratiform scavenging + + ! fracp is the fraction of cloud water converted to precip + ! NB: In below formula for fracp cwat is a LWC/IWC that has already + ! precipitated out, i.e., cwat does not contain precipitation + fracp(i) = precs(i,k)*deltat / & + max( 1.e-12_r8, cwat(i,k) + precs(i,k)*deltat ) + fracp(i) = max( 0._r8, min( 1._r8, fracp(i) ) ) + + ! assume the corresponding amnt of tracer is removed + st_scav_ic(i) = sol_facti*clds(i)*fracp(i)*tracer(i,k)*rdeltat + + odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat + odds(i) = max(min(1._r8,odds(i)),0._r8) + st_scav_bc(i) =sol_factb*(cldvst(i,k)*odds(i)) *tracer(i,k)*rdeltat + + end if + + ! total convective scavenging + srcc(i) = conv_scav_ic(i) + conv_scav_bc(i) + finc(i) = conv_scav_ic(i)/(srcc(i) + 1.e-36_r8) + + ! total stratiform scavenging + srcs(i) = st_scav_ic(i) + st_scav_bc(i) + fins(i) = st_scav_ic(i)/(srcs(i) + 1.e-36_r8) + + ! make sure we dont take out more than is there + ! ratio of amount available to amount removed + rat(i) = tracer(i,k)/max(deltat*(srcc(i)+srcs(i)),1.e-36_r8) + if (rat(i).lt.1._r8) then + srcs(i) = srcs(i)*rat(i) + srcc(i) = srcc(i)*rat(i) + endif + srct(i) = (srcc(i)+srcs(i))*omsm + + + ! fraction that is not removed within the cloud + ! (assumed to be interstitial, and subject to convective transport) + fracp(i) = deltat*srct(i)/max(cldvst(i,k)*tracer(i,k),1.e-36_r8) ! amount removed + fracp(i) = max(0._r8,min(1._r8,fracp(i))) + fracis(i,k) = 1._r8 - fracp(i) + + ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above + ! Sungsu added cumulus contribution in the below 3 blocks + scavt(i,k) = -srct(i) + (fracev(i)*scavab(i)+fracev_cu(i)*scavabc(i))*rpdog(i) + iscavt(i,k) = -(srcc(i)*finc(i) + srcs(i)*fins(i))*omsm + + if ( present(icscavt) ) icscavt(i,k) = -(srcc(i)*finc(i)) * omsm + if ( present(isscavt) ) isscavt(i,k) = -(srcs(i)*fins(i)) * omsm + + if (.not. out_resuspension) then + if (present(bcscavt)) bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm + & + fracev_cu(i)*scavabc(i)*rpdog(i) + + if (present(bsscavt)) bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm + & + fracev(i)*scavab(i)*rpdog(i) + else + bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm + rcscavt(i,k) = fracev_cu(i)*scavabc(i)*rpdog(i) + + bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm + rsscavt(i,k) = fracev(i)*scavab(i)*rpdog(i) + end if + + dblchek(i) = tracer(i,k) + deltat*scavt(i,k) + + ! now keep track of scavenged mass and precip + scavab(i) = scavab(i)*(1-fracev(i)) + srcs(i)*pdog(i) + precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdog(i) + scavabc(i) = scavabc(i)*(1-fracev_cu(i)) + srcc(i)*pdog(i) + precabc(i) = precabc(i) + (cmfdqr(i,k) - evapc(i,k))*pdog(i) + + end do ! End of i = 1, ncol + + found = .false. + do i = 1,ncol + if ( dblchek(i) < 0._r8 ) then + found = .true. + exit + end if + end do + + if ( found ) then + do i = 1,ncol + if (dblchek(i) .lt. 0._r8) then + write(iulog,*) ' wetdapa: negative value ', i, k, tracer(i,k), & + dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) + endif + end do + endif + + end do ! End of k = 1, pver + + end subroutine wetdepa_v2 + + !============================================================================== + subroutine wetdepg( t, p, q, pdel, & + cldt, cldc, cmfdqr, evapc, precs, evaps, & + rain, cwat, tracer, deltat, molwt, & + solconst, scavt, iscavt, cldv, icwmr1, & + icwmr2, fracis, ncol ) + + !----------------------------------------------------------------------- + ! scavenging of gas phase constituents by henry's law ( Author: P. Rasch) + !----------------------------------------------------------------------- + + real(r8), intent(in) ::& + t(pcols,pver), &! temperature + p(pcols,pver), &! pressure + q(pcols,pver), &! moisture + pdel(pcols,pver), &! pressure thikness + cldt(pcols,pver), &! total cloud fraction + cldc(pcols,pver), &! convective cloud fraction + cmfdqr(pcols,pver), &! rate of production of convective precip + rain (pcols,pver), &! total rainwater mixing ratio + cwat(pcols,pver), &! cloud water amount + precs(pcols,pver), &! rate of production of stratiform precip + evaps(pcols,pver), &! rate of evaporation of precip + evapc(pcols,pver), &! Rate of evaporation of convective precipitation + cldv(pcols,pver), &! estimate of local volume occupied by clouds + icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme + icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme + deltat, &! time step + tracer(pcols,pver), &! trace species + molwt ! molecular weights + + integer, intent(in) :: ncol + + real(r8) & + solconst(pcols,pver) ! Henry's law coefficient + + real(r8), intent(out) ::& + scavt(pcols,pver), &! scavenging tend + iscavt(pcols,pver), &! incloud scavenging tends + fracis(pcols, pver) ! fraction of constituent that is insoluble + + ! local variables + integer i ! x index + integer k ! z index + real(r8) adjfac ! factor stolen from cmfmca + real(r8) aqfrac ! fraction of tracer in aqueous phase + real(r8) cwatc ! local convective total water amount + real(r8) cwats ! local stratiform total water amount + real(r8) cwatl ! local cloud liq water amount + real(r8) cwatp ! local water amount falling from above precip + real(r8) cwatpl ! local water amount falling from above precip (liq) + real(r8) cwatt ! local sum of strat + conv total water amount + real(r8) cwatti ! cwatt/cldv = cloudy grid volume mixing ratio + real(r8) fracev ! fraction of precip from above that is evaporating + real(r8) fracp ! fraction of cloud water converted to precip + real(r8) gafrac ! fraction of tracer in gas phasea + real(r8) hconst ! henry's law solubility constant when equation is expressed + ! in terms of mixing ratios + real(r8) mpla ! moles / liter H2O entering the layer from above + real(r8) mplb ! moles / liter H2O leaving the layer below + real(r8) omsm ! 1 - (a small number) + real(r8) part ! partial pressure of tracer in atmospheres + real(r8) patm ! total pressure in atmospheres + real(r8) pdog ! work variable (pdel/gravit) + real(r8) precab(pcols) ! precip from above (work array) + real(r8) precbl ! precip work variable + real(r8) precxx ! precip work variable + real(r8) precxx2 ! + real(r8) precic ! precip work variable + real(r8) rat ! ratio of amount available to amount removed + real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) + real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) + + real(r8) scavmax ! an estimate of the max tracer avail for removal + real(r8) scavbl ! flux removed at bottom of layer + real(r8) fins ! in cloud fraction removed by strat rain + real(r8) finc ! in cloud fraction removed by conv rain + real(r8) rate ! max removal rate estimate + real(r8) scavlimt ! limiting value 1 + real(r8) scavt1 ! limiting value 2 + real(r8) scavin ! scavenging by incloud processes + real(r8) scavbc ! scavenging by below cloud processes + real(r8) tc + real(r8) weight ! ice fraction + real(r8) wtpl ! work variable + real(r8) cldmabs(pcols) ! maximum cloud at or above this level + real(r8) cldmabc(pcols) ! maximum cloud at or above this level + !----------------------------------------------------------- + + omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero + + adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme + + ! zero accumulators + do i = 1,pcols + precab(i) = 1.e-36_r8 + scavab(i) = 0._r8 + cldmabs(i) = 0._r8 + end do + + do k = 1,pver + do i = 1,ncol + tc = t(i,k) - tmelt + weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice + + cldmabs(i) = max(cldmabs(i),cldt(i,k)) + + ! partitioning coefs for gas and aqueous phase + ! take as a cloud water amount, the sum of the stratiform amount + ! plus the convective rain water amount + + ! convective amnt is just the local precip rate from the hack scheme + ! since there is no storage of water, this ignores that falling from above + cwatc = (icwmr1(i,k) + icwmr2(i,k)) * (1._r8-weight) + + ! strat cloud water amount and also ignore the part falling from above + cwats = cwat(i,k) + + ! cloud water as liq + cwatl = (1._r8-weight)*cwats + + ! cloud water as ice total suspended condensate as liquid + cwatt = cwatl + rain(i,k) + + ! incloud version + cwatti = cwatt/max(cldv(i,k), 0.00001_r8) + cwatc + + ! partitioning terms + patm = p(i,k)/1.013e5_r8 ! pressure in atmospheres + hconst = molwta*patm*solconst(i,k)*cwatti/rhoh2o + aqfrac = hconst/(1._r8+hconst) + gafrac = 1/(1._r8+hconst) + fracis(i,k) = gafrac + + ! partial pressure of the tracer in the gridbox in atmospheres + part = patm*gafrac*tracer(i,k)*molwta/molwt + + ! use henrys law to give moles tracer /liter of water in this volume + ! then convert to kg tracer /liter of water (kg tracer / kg water) + mplb = solconst(i,k)*part*molwt/1000._r8 + + pdog = pdel(i,k)/gravit + + ! this part of precip will be carried downward but at a new molarity of mpl + precic = pdog*(precs(i,k) + cmfdqr(i,k)) + + ! we cant take out more than entered, plus that available in the cloud + scavmax = scavab(i)+tracer(i,k)*cldv(i,k)/deltat*pdog + + ! flux of tracer by incloud processes + scavin = precic*(1._r8-weight)*mplb + + ! fraction of precip which entered above that leaves below + if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then + ! Sungsu added evaporation of convective precipitation below. + precxx = precab(i)-pdog*(evaps(i,k)+evapc(i,k)) + else + precxx = precab(i)-pdog*evaps(i,k) + end if + precxx = max (precxx,0.0_r8) + + ! flux of tracer by below cloud processes + if (tc.gt.0) then + scavbc = precxx*mplb ! if liquid + else + precxx2=max(precxx,1.e-36_r8) + scavbc = scavab(i)*precxx2/(precab(i)) ! if ice + endif + + scavbl = min(scavbc + scavin, scavmax) + + ! first guess assuming that henries law works + scavt1 = (scavab(i)-scavbl)/pdog*omsm + + ! pjr this should not be required, but we put it in to make sure we cant remove too much + ! remember, scavt1 is generally negative (indicating removal) + scavt1 = max(scavt1,-tracer(i,k)*cldv(i,k)/deltat) + + ! instead just set scavt to scavt1 + scavt(i,k) = scavt1 + + ! now update the amount leaving the layer + scavbl = scavab(i) - scavt(i,k)*pdog + + ! in cloud amount is that formed locally over the total flux out bottom + fins = scavin/(scavin + scavbc + 1.e-36_r8) + iscavt(i,k) = scavt(i,k)*fins + + scavab(i) = scavbl + precab(i) = max(precxx + precic,1.e-36_r8) + + end do + end do + + end subroutine wetdepg + end module oslo_aero_depos diff --git a/src/chemistry/oslo_aero/oslo_aero_dust.F90 b/src/chemistry/oslo_aero/oslo_aero_dust.F90 new file mode 100644 index 0000000000..6a1637ea7d --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_aero_dust.F90 @@ -0,0 +1,251 @@ +module oslo_aero_dust + + ! Calculate emission of all dusts. + ! Note that the mobilization is calculated in the land model and + ! the soil erodibility factor is applied here. + + use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl + use ppgrid, only: pcols, begchunk, endchunk + use phys_grid, only: get_ncols_p, get_rlat_all_p, get_rlon_all_p + use physics_types, only: physics_state + use camsrfexch, only: cam_in_t + use spmd_utils, only: masterproc + use constituents, only: cnst_name + use interpolate_data, only: lininterp_init, lininterp, lininterp_finish, interp_type + use mo_constants, only: pi, d2r + use cam_logfile, only: iulog + use cam_abortutils, only: endrun + use cam_pio_utils, only: cam_pio_openfile + use ioFileMod, only: getfil + use pio, only: file_desc_t,pio_inq_dimid,pio_inq_dimlen,pio_get_var,pio_inq_varid, PIO_NOWRITE + ! + use aerosoldef, only: l_dst_a2, l_dst_a3 + + implicit none + private + + ! public routines + public :: oslo_aero_dust_readnl + public :: oslo_aero_dust_init + public :: oslo_aero_dust_emis + + ! private routines (previously in soil_erod_mod in CAM) + private :: soil_erod_init + + character(len=6), public :: dust_names(10) + + integer , parameter :: numberOfDustModes = 2 !define in aerosoldef? + real(r8), parameter :: emis_fraction_in_mode(numberOfDustModes) = (/0.13_r8, 0.87_r8 /) + integer :: tracerMap(numberOfDustModes) = (/-99, -99/) !index of dust tracers in the modes + + integer , parameter, public :: dust_nbin = numberOfDustModes + + !Related to soil erodibility + real(r8) :: dust_emis_fact = -1.e36_r8 ! tuning parameter for dust emissions + character(len=cl) :: soil_erod_file = 'soil_erod_file' ! full pathname for soil erodibility dataset + + logical, parameter, public :: dust_active = .TRUE. + + real(r8), allocatable :: soil_erodibility(:,:) ! soil erodibility factor + real(r8) :: soil_erod_fact ! tuning parameter for dust emissions + +!=============================================================================== +contains +!=============================================================================== + + subroutine oslo_aero_dust_readnl(nlfile) + + use namelist_utils, only: find_group_name + use mpishorthand + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'dust_readnl' + + namelist /dust_nl/ dust_emis_fact, soil_erod_file + !----------------------------------------------------------------------------- + + ! Read namelist + if (masterproc) then + open( newunit=unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'dust_nl', status=ierr) + if (ierr == 0) then + read(unitn, dust_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + end if +#ifdef SPMD + ! Broadcast namelist variables + call mpibcast(dust_emis_fact, 1, mpir8, 0, mpicom) + call mpibcast(soil_erod_file, len(soil_erod_file), mpichar, 0, mpicom) +#endif + end subroutine oslo_aero_dust_readnl + + !=============================================================================== + subroutine oslo_aero_dust_init() + + ! local variables + integer :: i + + call soil_erod_init( dust_emis_fact, soil_erod_file ) + + ! Set module variables + tracerMap(1) = l_dst_a2 + tracerMap(2) = l_dst_a3 + + dust_names(:)=" " + do i=1,numberOfDustModes + dust_names(i) = cnst_name(tracerMap(i)) + end do + + end subroutine oslo_aero_dust_init + + !=============================================================================== + subroutine oslo_aero_dust_emis(state, cam_in) + + !----------------------------------------------------------------------- + ! Purpose: Interface to emission of all dusts. + ! Notice that the mobilization is calculated in the land model and + ! the soil erodibility factor is applied here. + !----------------------------------------------------------------------- + + ! Arguments: + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), target, intent(inout) :: cam_in ! import state + + ! Local variables + integer :: lchnk + integer :: ncol + integer :: i,n + real(r8) :: soil_erod_tmp(pcols) + real(r8) :: totalEmissionFlux(pcols) + real(r8), pointer :: cflx(:,:) + + lchnk = state%lchnk + ncol = state%ncol + + ! Filter away unreasonable values for soil erodibility + ! (using low values e.g. gives emissions in greenland..) + where(soil_erodibility(:,lchnk) .lt. 0.1_r8) + soil_erod_tmp(:)=0.0_r8 + elsewhere + soil_erod_tmp(:)=soil_erodibility(:,lchnk) + end where + + totalEmissionFlux(:) = 0.0_r8 + do i=1,ncol + totalEmissionFlux(i) = totalEmissionFlux(i) + sum(cam_in%dstflx(i,:)) + end do + + ! Note that following CESM use of "dust_emis_fact", the emissions are + ! scaled by the INVERSE of the factor!! + ! There is another random scale factor of 1.15 there. Adapting the exact + ! same formulation as MAM now and tune later + ! As of NE-380: Oslo dust emissions are 2/3 of CAM emissions + ! gives better AOD close to dust sources + + cflx => cam_in%cflx + do n = 1,numberOfDustModes + cflx(:ncol, tracerMap(n)) = -1.0_r8*emis_fraction_in_mode(n) & + *totalEmissionFlux(:ncol)*soil_erod_tmp(:ncol)/(dust_emis_fact)*1.15_r8 + end do + + end subroutine oslo_aero_dust_emis + + !============================================================================= + subroutine soil_erod_init( dust_emis_fact, soil_erod_file ) + + ! arguments + real(r8), intent(in) :: dust_emis_fact + character(len=*), intent(in) :: soil_erod_file + + ! localvaraibles + real(r8), allocatable :: soil_erodibility_in(:,:) + real(r8), allocatable :: dst_lons(:) + real(r8), allocatable :: dst_lats(:) + character(len=cl) :: infile + integer :: did, vid, nlat, nlon + type(file_desc_t) :: ncid + type(interp_type) :: lon_wgts, lat_wgts + real(r8) :: to_lats(pcols), to_lons(pcols) + integer :: c, ncols, ierr + real(r8), parameter :: zero=0._r8 + real(r8), parameter :: twopi=2._r8*pi + + soil_erod_fact = dust_emis_fact + + ! Summary to log file + if (masterproc) then + write(iulog,*) 'soil_erod_mod: soil erodibility dataset: ', trim(soil_erod_file) + write(iulog,*) 'soil_erod_mod: soil_erod_fact = ', soil_erod_fact + end if + + ! read in soil erodibility factors, similar to Zender's boundary conditions + + ! Get file name. + call getfil(soil_erod_file, infile, 0) + call cam_pio_openfile (ncid, trim(infile), PIO_NOWRITE) + + ! Get input data resolution. + ierr = pio_inq_dimid( ncid, 'lon', did ) + ierr = pio_inq_dimlen( ncid, did, nlon ) + + ierr = pio_inq_dimid( ncid, 'lat', did ) + ierr = pio_inq_dimlen( ncid, did, nlat ) + + allocate(dst_lons(nlon)) + allocate(dst_lats(nlat)) + allocate(soil_erodibility_in(nlon,nlat)) + + ierr = pio_inq_varid( ncid, 'lon', vid ) + ierr = pio_get_var( ncid, vid, dst_lons ) + + ierr = pio_inq_varid( ncid, 'lat', vid ) + ierr = pio_get_var( ncid, vid, dst_lats ) + + ierr = pio_inq_varid( ncid, 'mbl_bsn_fct_geo', vid ) + ierr = pio_get_var( ncid, vid, soil_erodibility_in ) + + ! convert to radians and setup regridding + dst_lats(:) = d2r * dst_lats(:) + dst_lons(:) = d2r * dst_lons(:) + + allocate( soil_erodibility(pcols,begchunk:endchunk), stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'soil_erod_init: failed to allocate soil_erodibility_in, ierr = ',ierr + call endrun('soil_erod_init: failed to allocate soil_erodibility_in') + end if + + soil_erodibility(:,:)=0._r8 + + ! regrid + do c=begchunk,endchunk + ncols = get_ncols_p(c) + call get_rlat_all_p(c, pcols, to_lats) + call get_rlon_all_p(c, pcols, to_lons) + + call lininterp_init(dst_lons, nlon, to_lons, ncols, 2, lon_wgts, zero, twopi) + call lininterp_init(dst_lats, nlat, to_lats, ncols, 1, lat_wgts) + + call lininterp(soil_erodibility_in(:,:), nlon, nlat, soil_erodibility(:,c), ncols, lon_wgts, lat_wgts) + + call lininterp_finish(lat_wgts) + call lininterp_finish(lon_wgts) + end do + deallocate( soil_erodibility_in, stat=ierr ) + if( ierr /= 0 ) then + write(iulog,*) 'soil_erod_init: failed to deallocate soil_erodibility_in, ierr = ',ierr + call endrun('soil_erod_init: failed to deallocate soil_erodibility_in') + end if + + deallocate( dst_lats ) + deallocate( dst_lons ) + + end subroutine soil_erod_init + +end module oslo_aero_dust diff --git a/src/chemistry/oslo_aero/seasalt_model.F90 b/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 similarity index 95% rename from src/chemistry/oslo_aero/seasalt_model.F90 rename to src/chemistry/oslo_aero/oslo_aero_seasalt.F90 index 238ed9431d..95f30d2d21 100644 --- a/src/chemistry/oslo_aero/seasalt_model.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 @@ -1,4 +1,4 @@ -module seasalt_model +module oslo_aero_seasalt use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl use ppgrid, only: pcols, pver @@ -15,14 +15,14 @@ module seasalt_model integer :: modeMap(numberOfSaltModes) ! [idx] which modes are we modifying integer :: tracerMap(numberOfSaltModes) ! [idx] which tracers are we modifying - public :: seasalt_init - public :: seasalt_emis + public :: oslo_aero_seasalt_init + public :: oslo_aero_seasalt_emis !=============================================================================== contains !=============================================================================== - subroutine seasalt_init() + subroutine oslo_aero_seasalt_init() use constituents, only: cnst_name use aerosoldef, only: l_ss_a1, l_ss_a2, l_ss_a3 @@ -43,10 +43,10 @@ subroutine seasalt_init() seasalt_names(i) = cnst_name(tracerMap(i)) end do - end subroutine seasalt_init + end subroutine oslo_aero_seasalt_init !=============================================================================== - subroutine seasalt_emis(state, cam_in) + subroutine oslo_aero_seasalt_emis(state, cam_in) !----------------------------------------------------------------------- ! Purpose: Interface to emission of sea salt @@ -143,6 +143,6 @@ subroutine seasalt_emis(state, cam_in) !Add OM ocean source to cam_in cam_in%cflx(:ncol,l_om_ni) = cam_in%cflx(:ncol,l_om_ni) + OMOceanSource(:ncol) - end subroutine seasalt_emis + end subroutine oslo_aero_seasalt_emis -end module seasalt_model +end module oslo_aero_seasalt diff --git a/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 b/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 new file mode 100644 index 0000000000..45b9f6966b --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 @@ -0,0 +1,473 @@ +module oslo_aero_sox_cldaero + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols, pver + use cam_abortutils, only: endrun + use mo_chem_utls, only: get_spc_ndx + use mo_constants, only: pi + use chem_mods, only: adv_mass + use physconst, only: gravit + use chem_mods, only: gas_pcnst + ! + use aerosoldef, only: l_so4_a2, chemistryIndex + + implicit none + private + + public :: sox_cldaero_init + public :: sox_cldaero_create_obj + public :: sox_cldaero_update + public :: sox_cldaero_destroy_obj + + private :: cldaero_uptakerate + private :: cldaero_allocate + private :: cldaero_deallocate + + type :: cldaero_conc_t + real(r8), pointer :: so4c(:,:) + real(r8), pointer :: nh4c(:,:) + real(r8), pointer :: no3c(:,:) + real(r8), pointer :: xlwc(:,:) + real(r8) :: so4_fact + end type cldaero_conc_t + public :: cldaero_conc_t + + integer :: id_msa, id_h2so4, id_so2, id_h2o2, id_nh3 + integer :: id_so4_1a + + real(r8), parameter :: small_value = 1.e-20_r8 + +!=============================================================================== +contains +!=============================================================================== + + subroutine sox_cldaero_init() + + ! module variables + id_msa = get_spc_ndx( 'MSA' ) + id_h2so4 = get_spc_ndx( 'H2SO4' ) + id_so2 = get_spc_ndx( 'SO2' ) + id_h2o2 = get_spc_ndx( 'H2O2' ) + id_nh3 = get_spc_ndx( 'NH3' ) + + if (id_h2so4<1 .or. id_so2<1 .or. id_h2o2<1) then + call endrun('sox_cldaero_init: oslo aero does not include necessary species' & + //' -- should not invoke sox_cldaero_init ') + endif + + id_so4_1a = chemistryIndex(l_so4_a2) + + end subroutine sox_cldaero_init + + !=============================================================================== + + function sox_cldaero_create_obj(cldfrc, qcw, lwc, cfact, ncol, loffset) result( conc_obj ) + + ! arguments + real(r8), intent(in) :: cldfrc(:,:) + real(r8), intent(in) :: qcw(:,:,:) + real(r8), intent(in) :: lwc(:,:) + real(r8), intent(in) :: cfact(:,:) + integer, intent(in) :: ncol + integer, intent(in) :: loffset + type(cldaero_conc_t), pointer :: conc_obj + + ! local variables + integer :: l,n + integer :: i,k + + conc_obj => cldaero_allocate() + + do k = 1,pver + do i = 1,ncol + if (cldfrc(i,k) >0._r8) then + conc_obj%xlwc(i,k) = lwc(i,k) *cfact(i,k) ! cloud water L(water)/L(air) + conc_obj%xlwc(i,k) = conc_obj%xlwc(i,k) / cldfrc(i,k) ! liquid water in the cloudy fraction of cell + else + conc_obj%xlwc(i,k) = 0._r8 + endif + enddo + enddo + + conc_obj%no3c(:,:) = 0._r8 + + ! Set concenctration of cloud so4 + conc_obj%so4c(:ncol,:) = qcw(:ncol,:,id_so4_1a) + + ! current version does not have nh3/nh4 tracers - so so4 is assumed to be nh4hso4 + ! the partial neutralization of so4 is handled by using a + ! -1 charge (instead of -2) in the electro-neutrality equation + conc_obj%nh4c(:ncol,:) = 0._r8 + + ! with 3-mode, assume so4 is nh4hso4, and so half-neutralized + conc_obj%so4_fact = 1._r8 + + end function sox_cldaero_create_obj + + !=============================================================================== + + subroutine sox_cldaero_update( & + ncol, lchnk, loffset, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, xlwc, & + delso4_hprxn, xh2so4, xso4, xso4_init, nh3g, hno3g, xnh3, xhno3, xnh4c, xno3c, xmsa, xso2, xh2o2, qcw, qin, & + aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d, aqso4_o3_3d) + + !---------------------------------------------------------------------------------- + ! Update the mixing ratios + !---------------------------------------------------------------------------------- + + ! arguments + integer, intent(in) :: ncol + integer, intent(in) :: lchnk ! chunk id + integer, intent(in) :: loffset + real(r8), intent(in) :: dtime ! time step (sec) + real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) + real(r8), intent(in) :: pdel(:,:) + real(r8), intent(in) :: press(:,:) + real(r8), intent(in) :: tfld(:,:) + real(r8), intent(in) :: cldnum(:,:) + real(r8), intent(in) :: cldfrc(:,:) + real(r8), intent(in) :: cfact(:,:) + real(r8), intent(in) :: xlwc(:,:) + real(r8), intent(in) :: delso4_hprxn(:,:) + real(r8), intent(in) :: xh2so4(:,:) + real(r8), intent(in) :: xso4(:,:) + real(r8), intent(in) :: xso4_init(:,:) + real(r8), intent(in) :: nh3g(:,:) + real(r8), intent(in) :: hno3g(:,:) + real(r8), intent(in) :: xnh3(:,:) + real(r8), intent(in) :: xhno3(:,:) + real(r8), intent(in) :: xnh4c(:,:) + real(r8), intent(in) :: xmsa(:,:) + real(r8), intent(in) :: xso2(:,:) + real(r8), intent(in) :: xh2o2(:,:) + real(r8), intent(in) :: xno3c(:,:) + real(r8), intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) + real(r8), intent(inout) :: qin(:,:,:) ! xported species ( vmr ) + real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry + real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) + real(r8), intent(out), optional :: aqso4_h2o2_3d(:,:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) + real(r8), intent(out), optional :: aqso4_o3_3d(:,:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) + + + ! local variables + real(r8) :: dqdt_aqso4(ncol,pver,gas_pcnst) + real(r8) :: dqdt_aqh2so4(ncol,pver,gas_pcnst) + real(r8) :: dqdt_aqhprxn(ncol,pver), dqdt_aqo3rxn(ncol,pver) + real(r8) :: sflx(1:ncol) + real(r8) :: delso4_o3rxn + real(r8) :: dso4dt_aqrxn, dso4dt_hprxn + real(r8) :: dso4dt_gasuptk, dmsadt_gasuptk + real(r8) :: dmsadt_gasuptk_tomsa, dmsadt_gasuptk_toso4 + real(r8) :: dqdt_aq, dqdt_wr, dqdt + real(r8) :: fwetrem, sumf, uptkrate + real(r8) :: delnh3, delnh4 + integer :: l, n, m, i,k + integer :: ntot_msa_c + real(r8) :: xl + + ! make sure dqdt is zero initially, for budgets + dqdt_aqso4(:,:,:) = 0.0_r8 + dqdt_aqh2so4(:,:,:) = 0.0_r8 + dqdt_aqhprxn(:,:) = 0.0_r8 + dqdt_aqo3rxn(:,:) = 0.0_r8 + + lev_loop: do k = 1,pver + col_loop: do i = 1,ncol + cloud: if (cldfrc(i,k) >= 1.0e-5_r8) then + xl = xlwc(i,k) ! / cldfrc(i,k) + + IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED + + delso4_o3rxn = xso4(i,k) - xso4_init(i,k) + + if (id_nh3>0) then + delnh3 = nh3g(i,k) - xnh3(i,k) + delnh4 = - delnh3 + endif + + !In the case of OSLO-AEROSOLS, + !set no MSA in cloud droplets + ntot_msa_c = 0 + + ! average uptake rate over dtime + uptkrate = cldaero_uptakerate( xl, cldnum(i,k), cfact(i,k), cldfrc(i,k), tfld(i,k), press(i,k) ) + + ! average uptake rate over dtime + uptkrate = (1.0_r8 - exp(-min(100._r8,dtime*uptkrate))) / dtime + + ! dso4dt_gasuptk = so4_c tendency from h2so4 gas uptake (mol/mol/s) + ! dmsadt_gasuptk = msa_c tendency from msa gas uptake (mol/mol/s) + dso4dt_gasuptk = xh2so4(i,k) * uptkrate + if (id_msa > 0) then + dmsadt_gasuptk = xmsa(i,k) * uptkrate + else + dmsadt_gasuptk = 0.0_r8 + end if + + ! if no modes have msa aerosol, then "rename" scavenged msa gas to so4 + dmsadt_gasuptk_toso4 = 0.0_r8 + dmsadt_gasuptk_tomsa = dmsadt_gasuptk + if (ntot_msa_c == 0) then + dmsadt_gasuptk_tomsa = 0.0_r8 + dmsadt_gasuptk_toso4 = dmsadt_gasuptk + end if + + !----------------------------------------------------------------------- + ! now compute TMR tendencies + ! this includes the above aqueous so2 chemistry AND + ! the uptake of highly soluble aerosol precursor gases (h2so4, msa, ...) + ! AND the wetremoval of dissolved, unreacted so2 and h2o2 + + dso4dt_aqrxn = (delso4_o3rxn + delso4_hprxn(i,k)) / dtime + dso4dt_hprxn = delso4_hprxn(i,k) / dtime + + ! fwetrem = fraction of in-cloud-water material that is wet removed + ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*clwlrat(i,k)))) ) + fwetrem = 0.0_r8 ! don't have so4 & msa wet removal here + + !Update so4 in cloud water + l = id_so4_1a !We only have one aq-phase tracer in CAM_OSLO + + dqdt_aqso4(i,k,l) = dso4dt_aqrxn*cldfrc(i,k) + dqdt_aqh2so4(i,k,l) = (dso4dt_gasuptk + dmsadt_gasuptk_toso4)*cldfrc(i,k) + dqdt_aq = dqdt_aqso4(i,k,l) + dqdt_aqh2so4(i,k,l) + dqdt_wr = -fwetrem*dqdt_aq !wet removal set to zero above + dqdt= dqdt_aq + dqdt_wr + qcw(i,k,l) = qcw(i,k,l) + dqdt*dtime + + !Additional updates for MSA?? + ! For gas species, tendency includes + ! reactive uptake to cloud water that essentially transforms the gas to + ! a different species. Wet removal associated with this is applied + ! to the "new" species (e.g., so4_c) rather than to the gas. + ! wet removal of the unreacted gas that is dissolved in cloud water. + ! Need to multiply both these parts by cldfrc + + ! h2so4 (g) & msa (g) + qin(i,k,id_h2so4) = qin(i,k,id_h2so4) - dso4dt_gasuptk * dtime * cldfrc(i,k) + if (id_msa > 0) qin(i,k,id_msa) = qin(i,k,id_msa) - dmsadt_gasuptk * dtime * cldfrc(i,k) + + + ! so2 -- the first order loss rate for so2 is frso2_c*clwlrat(i,k) + ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frso2_c*clwlrat(i,k)))) ) + fwetrem = 0.0_r8 ! don't include so2 wet removal here + + dqdt_wr = -fwetrem*xso2(i,k)/dtime*cldfrc(i,k) + dqdt_aq = -dso4dt_aqrxn*cldfrc(i,k) + dqdt = dqdt_aq + dqdt_wr + qin(i,k,id_so2) = qin(i,k,id_so2) + dqdt * dtime + + ! h2o2 -- the first order loss rate for h2o2 is frh2o2_c*clwlrat(i,k) + ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frh2o2_c*clwlrat(i,k)))) ) + fwetrem = 0.0_r8 ! don't include h2o2 wet removal here + + dqdt_wr = -fwetrem*xh2o2(i,k)/dtime*cldfrc(i,k) + dqdt_aq = -dso4dt_hprxn*cldfrc(i,k) + dqdt = dqdt_aq + dqdt_wr + qin(i,k,id_h2o2) = qin(i,k,id_h2o2) + dqdt * dtime + + ! NH3 + if (id_nh3>0) then + dqdt_aq = delnh3/dtime*cldfrc(i,k) + dqdt = dqdt_aq + qin(i,k,id_nh3) = qin(i,k,id_nh3) + dqdt * dtime + endif + + ! for SO4 from H2O2/O3 budgets + dqdt_aqhprxn(i,k) = dso4dt_hprxn*cldfrc(i,k) + dqdt_aqo3rxn(i,k) = (dso4dt_aqrxn - dso4dt_hprxn)*cldfrc(i,k) + + ENDIF !! WHEN CLOUD IS PRESENTED + + endif cloud + enddo col_loop + enddo lev_loop + + ! Update the mixing ratios + do k = 1,pver + qcw(:,k,id_so4_1a) = MAX( qcw(:,k,id_so4_1a), small_value ) + qin(:,k,id_so2) = MAX( qin(:,k,id_so2), small_value ) + if ( id_nh3 > 0 ) then + qin(:,k,id_nh3) = MAX( qin(:,k,id_nh3), small_value ) + endif + end do + + ! diagnostics + l = id_so4_1a !Index of the a2-tracer in cloud water + n = 1 !Only distribute to one "mode" + aqso4(:,n)=0._r8 + do k=1,pver + do i=1,ncol + aqso4(i,n)=aqso4(i,n)+dqdt_aqso4(i,k,l)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg/m2/s + enddo + enddo + + aqh2so4(:,n)=0._r8 + do k=1,pver + do i=1,ncol + aqh2so4(:,n)=aqh2so4(:,n)+dqdt_aqh2so4(i,k,l)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg/m2/s + enddo + enddo + + aqso4_h2o2(:) = 0._r8 + do k=1,pver + do i=1,ncol + aqso4_h2o2(i)=aqso4_h2o2(i)+dqdt_aqhprxn(i,k)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg SO4 /m2/s + enddo + enddo + + if (present(aqso4_h2o2_3d)) then + aqso4_h2o2_3d(:,:) = 0._r8 + do k=1,pver + do i=1,ncol + aqso4_h2o2_3d(i,k)=dqdt_aqhprxn(i,k)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg SO4 /m2/s + enddo + enddo + end if + + aqso4_o3(:)=0._r8 + do k=1,pver + do i=1,ncol + aqso4_o3(i)=aqso4_o3(i)+dqdt_aqo3rxn(i,k)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg SO4 /m2/s + enddo + enddo + + if (present(aqso4_o3_3d)) then + aqso4_o3_3d(:,:)=0._r8 + do k=1,pver + do i=1,ncol + aqso4_o3_3d(i,k)=dqdt_aqo3rxn(i,k)*adv_mass(l)/mbar(i,k) & + *pdel(i,k)/gravit ! kg SO4 /m2/s + enddo + enddo + end if + + end subroutine sox_cldaero_update + + !=============================================================================== + + subroutine sox_cldaero_destroy_obj( conc_obj ) + type(cldaero_conc_t), pointer :: conc_obj + call cldaero_deallocate( conc_obj ) + end subroutine sox_cldaero_destroy_obj + + !=============================================================================== + + function cldaero_allocate( ) result( cldconc ) + type(cldaero_conc_t), pointer:: cldconc + + allocate( cldconc ) + allocate( cldconc%so4c(pcols,pver) ) + allocate( cldconc%nh4c(pcols,pver) ) + allocate( cldconc%no3c(pcols,pver) ) + allocate( cldconc%xlwc(pcols,pver) ) + + cldconc%so4c(:,:) = 0._r8 + cldconc%nh4c(:,:) = 0._r8 + cldconc%no3c(:,:) = 0._r8 + cldconc%xlwc(:,:) = 0._r8 + cldconc%so4_fact = 2._r8 + + end function cldaero_allocate + + !=============================================================================== + + subroutine cldaero_deallocate( cldconc ) + type(cldaero_conc_t), pointer :: cldconc + + if ( associated(cldconc%so4c) ) then + deallocate(cldconc%so4c) + nullify(cldconc%so4c) + endif + + if ( associated(cldconc%nh4c) ) then + deallocate(cldconc%nh4c) + nullify(cldconc%nh4c) + endif + + if ( associated(cldconc%no3c) ) then + deallocate(cldconc%no3c) + nullify(cldconc%no3c) + endif + + if ( associated(cldconc%xlwc) ) then + deallocate(cldconc%xlwc) + nullify(cldconc%xlwc) + endif + + deallocate( cldconc ) + nullify( cldconc ) + + end subroutine cldaero_deallocate + + !=============================================================================== + + function cldaero_uptakerate( xl, cldnum, cfact, cldfrc, tfld, press ) result( uptkrate ) + + ! compute uptake of h2so4 and msa to cloud water + ! first-order uptake rate is + ! 4*pi*(drop radius)*(drop number conc) + ! *(gas diffusivity)*(fuchs sutugin correction) + + ! arguments / output + real(r8), intent(in) :: xl, cldnum, cfact, cldfrc, tfld, press + real(r8) :: uptkrate + + ! local variables + real(r8) :: rad_cd, radxnum_cd, num_cd + real(r8) :: gasdiffus, gasspeed, knudsen + real(r8) :: fuchs_sutugin, volx34pi_cd + + ! num_cd = (drop number conc in 1/cm^3) + num_cd = 1.0e-3_r8*cldnum*cfact/cldfrc + num_cd = max( num_cd, 0.0_r8 ) + + ! rad_cd = (drop radius in cm), computed from liquid water and drop number, + ! then bounded by 0.5 and 50.0 micrometers + ! radxnum_cd = (drop radius)*(drop number conc) + ! volx34pi_cd = (3/4*pi) * (liquid water volume in cm^3/cm^3) + + volx34pi_cd = xl*0.75_r8/pi + + ! following holds because volx34pi_cd = num_cd*(rad_cd**3) + radxnum_cd = (volx34pi_cd*num_cd*num_cd)**0.3333333_r8 + + ! apply bounds to rad_cd to avoid the occasional unphysical value + if (radxnum_cd .le. volx34pi_cd*4.0e4_r8) then + radxnum_cd = volx34pi_cd*4.0e4_r8 + rad_cd = 50.0e-4_r8 + else if (radxnum_cd .ge. volx34pi_cd*4.0e8_r8) then + radxnum_cd = volx34pi_cd*4.0e8_r8 + rad_cd = 0.5e-4_r8 + else + rad_cd = radxnum_cd/num_cd + end if + + ! gasdiffus = h2so4 gas diffusivity from mosaic code (cm^2/s) (pmid must be Pa) + gasdiffus = 0.557_r8 * (tfld**1.75_r8) / press + + ! gasspeed = h2so4 gas mean molecular speed from mosaic code (cm/s) + gasspeed = 1.455e4_r8 * sqrt(tfld/98.0_r8) + + ! knudsen number + knudsen = 3.0_r8*gasdiffus/(gasspeed*rad_cd) + + ! following assumes accomodation coefficient = 0.65 + ! (Adams & Seinfeld, 2002, JGR, and references therein) + ! fuchs_sutugin = (0.75*accom*(1. + knudsen)) / + ! (knudsen*(1.0 + knudsen + 0.283*accom) + 0.75*accom) + fuchs_sutugin = (0.4875_r8*(1._r8 + knudsen)) / (knudsen*(1.184_r8 + knudsen) + 0.4875_r8) + + ! instantaneous uptake rate + uptkrate = 12.56637_r8*radxnum_cd*gasdiffus*fuchs_sutugin + + end function cldaero_uptakerate + +end module oslo_aero_sox_cldaero diff --git a/src/chemistry/oslo_aero/sox_cldaero_mod.F90 b/src/chemistry/oslo_aero/sox_cldaero_mod.F90 deleted file mode 100644 index d4224ec750..0000000000 --- a/src/chemistry/oslo_aero/sox_cldaero_mod.F90 +++ /dev/null @@ -1,386 +0,0 @@ -!---------------------------------------------------------------------------------- -! Modal aerosol implementation -!---------------------------------------------------------------------------------- -module sox_cldaero_mod - - use shr_kind_mod, only : r8 => shr_kind_r8 - use cam_abortutils, only : endrun - use ppgrid, only : pcols, pver - use mo_chem_utls, only : get_spc_ndx - use aerosoldef, only: l_so4_a2, chemistryIndex - use cldaero_mod, only : cldaero_conc_t, cldaero_allocate, cldaero_deallocate - use chem_mods, only : adv_mass - use physconst, only : gravit - use phys_control, only : phys_getopts - use cldaero_mod, only : cldaero_uptakerate - use chem_mods, only : gas_pcnst - - implicit none - private - - public :: sox_cldaero_init - public :: sox_cldaero_create_obj - public :: sox_cldaero_update - public :: sox_cldaero_destroy_obj - - integer :: id_msa, id_h2so4, id_so2, id_h2o2, id_nh3 - integer :: id_so4_1a - - real(r8), parameter :: small_value = 1.e-20_r8 - -contains - -!---------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------- - - subroutine sox_cldaero_init - - integer :: l, m - logical :: history_aerosol ! Output the MAM aerosol tendencies - - id_msa = get_spc_ndx( 'MSA' ) - id_h2so4 = get_spc_ndx( 'H2SO4' ) - id_so2 = get_spc_ndx( 'SO2' ) - id_h2o2 = get_spc_ndx( 'H2O2' ) - id_nh3 = get_spc_ndx( 'NH3' ) - - id_so4_1a = chemistryIndex(l_so4_a2) - - if (id_h2so4<1 .or. id_so2<1 .or. id_h2o2<1) then - call endrun('sox_cldaero_init:MAM mech does not include necessary species' & - //' -- should not invoke sox_cldaero_mod ') - endif - - call phys_getopts( history_aerosol_out = history_aerosol ) - ! - ! add to history - ! - - end subroutine sox_cldaero_init - -!---------------------------------------------------------------------------------- -!---------------------------------------------------------------------------------- - function sox_cldaero_create_obj(cldfrc, qcw, lwc, cfact, ncol, loffset) result( conc_obj ) - - real(r8), intent(in) :: cldfrc(:,:) - real(r8), intent(in) :: qcw(:,:,:) - real(r8), intent(in) :: lwc(:,:) - real(r8), intent(in) :: cfact(:,:) - integer, intent(in) :: ncol - integer, intent(in) :: loffset - - type(cldaero_conc_t), pointer :: conc_obj - - - integer :: l,n - integer :: i,k - - - conc_obj => cldaero_allocate() - - do k = 1,pver - do i = 1,ncol - if( cldfrc(i,k) >0._r8) then - conc_obj%xlwc(i,k) = lwc(i,k) *cfact(i,k) ! cloud water L(water)/L(air) - conc_obj%xlwc(i,k) = conc_obj%xlwc(i,k) / cldfrc(i,k) ! liquid water in the cloudy fraction of cell - else - conc_obj%xlwc(i,k) = 0._r8 - endif - enddo - enddo - - conc_obj%no3c(:,:) = 0._r8 - - - !Set concenctration of cloud so4 - conc_obj%so4c(:ncol,:) & - = qcw(:ncol,:,id_so4_1a) - - - ! for oslo aerosols, - ! current version does not have nh3/nh4 tracers - ! so so4 is assumed to be nh4hso4 - ! the partial neutralization of so4 is handled by using a - ! -1 charge (instead of -2) in the electro-neutrality equation - conc_obj%nh4c(:ncol,:) = 0._r8 - - ! with 3-mode, assume so4 is nh4hso4, and so half-neutralized - conc_obj%so4_fact = 1._r8 - - - - end function sox_cldaero_create_obj - -!---------------------------------------------------------------------------------- -! Update the mixing ratios -!---------------------------------------------------------------------------------- - subroutine sox_cldaero_update( & - ncol, lchnk, loffset, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, xlwc, & - delso4_hprxn, xh2so4, xso4, xso4_init, nh3g, hno3g, xnh3, xhno3, xnh4c, xno3c, xmsa, xso2, xh2o2, qcw, qin, & - aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d, aqso4_o3_3d) - - ! args - - integer, intent(in) :: ncol - integer, intent(in) :: lchnk ! chunk id - integer, intent(in) :: loffset - - real(r8), intent(in) :: dtime ! time step (sec) - - real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) - real(r8), intent(in) :: pdel(:,:) - real(r8), intent(in) :: press(:,:) - real(r8), intent(in) :: tfld(:,:) - - real(r8), intent(in) :: cldnum(:,:) - real(r8), intent(in) :: cldfrc(:,:) - real(r8), intent(in) :: cfact(:,:) - real(r8), intent(in) :: xlwc(:,:) - - real(r8), intent(in) :: delso4_hprxn(:,:) - real(r8), intent(in) :: xh2so4(:,:) - real(r8), intent(in) :: xso4(:,:) - real(r8), intent(in) :: xso4_init(:,:) - real(r8), intent(in) :: nh3g(:,:) - real(r8), intent(in) :: hno3g(:,:) - real(r8), intent(in) :: xnh3(:,:) - real(r8), intent(in) :: xhno3(:,:) - real(r8), intent(in) :: xnh4c(:,:) - real(r8), intent(in) :: xmsa(:,:) - real(r8), intent(in) :: xso2(:,:) - real(r8), intent(in) :: xh2o2(:,:) - real(r8), intent(in) :: xno3c(:,:) - - real(r8), intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) - real(r8), intent(inout) :: qin(:,:,:) ! xported species ( vmr ) - - real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) - real(r8), intent(out), optional :: aqso4_h2o2_3d(:,:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out), optional :: aqso4_o3_3d(:,:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) - - - ! local vars ... - - real(r8) :: dqdt_aqso4(ncol,pver,gas_pcnst), & - dqdt_aqh2so4(ncol,pver,gas_pcnst), & - dqdt_aqhprxn(ncol,pver), dqdt_aqo3rxn(ncol,pver), & - sflx(1:ncol) - - real(r8) :: delso4_o3rxn, & - dso4dt_aqrxn, dso4dt_hprxn, & - dso4dt_gasuptk, dmsadt_gasuptk, & - dmsadt_gasuptk_tomsa, dmsadt_gasuptk_toso4, & - dqdt_aq, dqdt_wr, dqdt - - real(r8) :: fwetrem, sumf, uptkrate - real(r8) :: delnh3, delnh4 - - integer :: l, n, m - integer :: ntot_msa_c - - integer :: i,k - real(r8) :: xl - - ! make sure dqdt is zero initially, for budgets - dqdt_aqso4(:,:,:) = 0.0_r8 - dqdt_aqh2so4(:,:,:) = 0.0_r8 - dqdt_aqhprxn(:,:) = 0.0_r8 - dqdt_aqo3rxn(:,:) = 0.0_r8 - - lev_loop: do k = 1,pver - col_loop: do i = 1,ncol - cloud: if (cldfrc(i,k) >= 1.0e-5_r8) then - xl = xlwc(i,k) ! / cldfrc(i,k) - - IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED - - delso4_o3rxn = xso4(i,k) - xso4_init(i,k) - - if (id_nh3>0) then - delnh3 = nh3g(i,k) - xnh3(i,k) - delnh4 = - delnh3 - endif - - !In the case of OSLO-AEROSOLS, - !set no MSA in cloud droplets - ntot_msa_c = 0 - ! average uptake rate over dtime - uptkrate = cldaero_uptakerate( xl, cldnum(i,k), cfact(i,k), cldfrc(i,k), tfld(i,k), press(i,k) ) - ! average uptake rate over dtime - uptkrate = (1.0_r8 - exp(-min(100._r8,dtime*uptkrate))) / dtime - - ! dso4dt_gasuptk = so4_c tendency from h2so4 gas uptake (mol/mol/s) - ! dmsadt_gasuptk = msa_c tendency from msa gas uptake (mol/mol/s) - dso4dt_gasuptk = xh2so4(i,k) * uptkrate - if (id_msa > 0) then - dmsadt_gasuptk = xmsa(i,k) * uptkrate - else - dmsadt_gasuptk = 0.0_r8 - end if - -! if no modes have msa aerosol, then "rename" scavenged msa gas to so4 - dmsadt_gasuptk_toso4 = 0.0_r8 - dmsadt_gasuptk_tomsa = dmsadt_gasuptk - if (ntot_msa_c == 0) then - dmsadt_gasuptk_tomsa = 0.0_r8 - dmsadt_gasuptk_toso4 = dmsadt_gasuptk - end if - -!----------------------------------------------------------------------- -! now compute TMR tendencies -! this includes the above aqueous so2 chemistry AND -! the uptake of highly soluble aerosol precursor gases (h2so4, msa, ...) -! AND the wetremoval of dissolved, unreacted so2 and h2o2 - - dso4dt_aqrxn = (delso4_o3rxn + delso4_hprxn(i,k)) / dtime - dso4dt_hprxn = delso4_hprxn(i,k) / dtime - -! fwetrem = fraction of in-cloud-water material that is wet removed -! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*clwlrat(i,k)))) ) - fwetrem = 0.0_r8 ! don't have so4 & msa wet removal here - - !Update so4 in cloud water - l = id_so4_1a !We only have one aq-phase tracer in CAM_OSLO - - dqdt_aqso4(i,k,l) = dso4dt_aqrxn*cldfrc(i,k) - dqdt_aqh2so4(i,k,l) = & - (dso4dt_gasuptk + dmsadt_gasuptk_toso4)*cldfrc(i,k) - dqdt_aq = dqdt_aqso4(i,k,l) + dqdt_aqh2so4(i,k,l) - dqdt_wr = -fwetrem*dqdt_aq !wet removal set to zero above - dqdt= dqdt_aq + dqdt_wr - qcw(i,k,l) = qcw(i,k,l) + dqdt*dtime - - !Additional updates for MSA?? -! For gas species, tendency includes -! reactive uptake to cloud water that essentially transforms the gas to -! a different species. Wet removal associated with this is applied -! to the "new" species (e.g., so4_c) rather than to the gas. -! wet removal of the unreacted gas that is dissolved in cloud water. -! Need to multiply both these parts by cldfrc - -! h2so4 (g) & msa (g) - qin(i,k,id_h2so4) = qin(i,k,id_h2so4) - dso4dt_gasuptk * dtime * cldfrc(i,k) - if (id_msa > 0) qin(i,k,id_msa) = qin(i,k,id_msa) - dmsadt_gasuptk * dtime * cldfrc(i,k) - - - ! so2 -- the first order loss rate for so2 is frso2_c*clwlrat(i,k) - ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frso2_c*clwlrat(i,k)))) ) - fwetrem = 0.0_r8 ! don't include so2 wet removal here - - dqdt_wr = -fwetrem*xso2(i,k)/dtime*cldfrc(i,k) - dqdt_aq = -dso4dt_aqrxn*cldfrc(i,k) - dqdt = dqdt_aq + dqdt_wr - qin(i,k,id_so2) = qin(i,k,id_so2) + dqdt * dtime - -! h2o2 -- the first order loss rate for h2o2 is frh2o2_c*clwlrat(i,k) -! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frh2o2_c*clwlrat(i,k)))) ) - fwetrem = 0.0_r8 ! don't include h2o2 wet removal here - - dqdt_wr = -fwetrem*xh2o2(i,k)/dtime*cldfrc(i,k) - dqdt_aq = -dso4dt_hprxn*cldfrc(i,k) - dqdt = dqdt_aq + dqdt_wr - qin(i,k,id_h2o2) = qin(i,k,id_h2o2) + dqdt * dtime - - ! NH3 - if (id_nh3>0) then - dqdt_aq = delnh3/dtime*cldfrc(i,k) - dqdt = dqdt_aq - qin(i,k,id_nh3) = qin(i,k,id_nh3) + dqdt * dtime - endif - - ! for SO4 from H2O2/O3 budgets - dqdt_aqhprxn(i,k) = dso4dt_hprxn*cldfrc(i,k) - dqdt_aqo3rxn(i,k) = (dso4dt_aqrxn - dso4dt_hprxn)*cldfrc(i,k) - - ENDIF !! WHEN CLOUD IS PRESENTED - - endif cloud - enddo col_loop - enddo lev_loop - - !============================================================== - ! ... Update the mixing ratios - !============================================================== - do k = 1,pver - - qcw(:,k,id_so4_1a) = MAX( qcw(:,k,id_so4_1a), small_value ) - - qin(:,k,id_so2) = MAX( qin(:,k,id_so2), small_value ) - - if ( id_nh3 > 0 ) then - qin(:,k,id_nh3) = MAX( qin(:,k,id_nh3), small_value ) - endif - - end do - - ! diagnostics - - l = id_so4_1a !Index of the a2-tracer in cloud water - n = 1 !Only distribute to one "mode" - aqso4(:,n)=0._r8 - do k=1,pver - do i=1,ncol - aqso4(i,n)=aqso4(i,n)+dqdt_aqso4(i,k,l)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg/m2/s - enddo - enddo - - aqh2so4(:,n)=0._r8 - do k=1,pver - do i=1,ncol - aqh2so4(:,n)=aqh2so4(:,n)+dqdt_aqh2so4(i,k,l)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg/m2/s - enddo - enddo - - aqso4_h2o2(:) = 0._r8 - do k=1,pver - do i=1,ncol - aqso4_h2o2(i)=aqso4_h2o2(i)+dqdt_aqhprxn(i,k)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - - if (present(aqso4_h2o2_3d)) then - aqso4_h2o2_3d(:,:) = 0._r8 - do k=1,pver - do i=1,ncol - aqso4_h2o2_3d(i,k)=dqdt_aqhprxn(i,k)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - end if - - aqso4_o3(:)=0._r8 - do k=1,pver - do i=1,ncol - aqso4_o3(i)=aqso4_o3(i)+dqdt_aqo3rxn(i,k)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - - if (present(aqso4_o3_3d)) then - aqso4_o3_3d(:,:)=0._r8 - do k=1,pver - do i=1,ncol - aqso4_o3_3d(i,k)=dqdt_aqo3rxn(i,k)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - end if - - end subroutine sox_cldaero_update - - !---------------------------------------------------------------------------------- - !---------------------------------------------------------------------------------- - subroutine sox_cldaero_destroy_obj( conc_obj ) - type(cldaero_conc_t), pointer :: conc_obj - - call cldaero_deallocate( conc_obj ) - - end subroutine sox_cldaero_destroy_obj - -end module sox_cldaero_mod diff --git a/src/physics/cam_oslo/mo_chm_diags.F90 b/src/physics/cam_oslo/mo_chm_diags.F90 deleted file mode 100644 index 943fdb5114..0000000000 --- a/src/physics/cam_oslo/mo_chm_diags.F90 +++ /dev/null @@ -1,1019 +0,0 @@ -module mo_chm_diags - - use shr_kind_mod, only : r8 => shr_kind_r8 - use chem_mods, only : gas_pcnst - use mo_tracname, only : solsym - use chem_mods, only : rxntot, nfs, gas_pcnst, indexm, adv_mass - use ppgrid, only : pver - use mo_constants, only : rgrav, rearth - use mo_chem_utls, only : get_rxt_ndx, get_spc_ndx - use cam_history, only : fieldname_len - use mo_jeuv, only : neuv - use gas_wetdep_opts,only : gas_wetdep_method - - implicit none - private - - public :: chm_diags_inti - public :: chm_diags - public :: het_diags - - integer :: id_n,id_no,id_no2,id_no3,id_n2o5,id_hno3,id_ho2no2,id_clono2,id_brono2 - integer :: id_cl,id_clo,id_hocl,id_cl2,id_cl2o2,id_oclo,id_hcl,id_brcl - integer :: id_ccl4,id_cfc11,id_cfc113,id_ch3ccl3,id_cfc12,id_ch3cl,id_hcfc22,id_cf3br,id_cf2clbr - integer :: id_cfc114,id_cfc115,id_hcfc141b,id_hcfc142b,id_h1202,id_h2402,id_ch2br2,id_chbr3 - integer :: id_hf,id_f,id_cof2,id_cofcl,id_ch3br - integer :: id_br,id_bro,id_hbr,id_hobr,id_ch4,id_h2o,id_h2 - integer :: id_o,id_o2,id_h, id_h2o2, id_n2o - integer :: id_co2,id_o3,id_oh,id_ho2,id_so4_a1,id_so4_a2,id_so4_a3 - integer :: id_num_a2,id_num_a3,id_dst_a3,id_ncl_a3 - integer :: id_ndep,id_nhdep - - integer, parameter :: NJEUV = neuv - integer :: rid_jeuv(NJEUV), rid_jno_i, rid_jno - - logical :: has_jeuvs, has_jno_i, has_jno - - integer :: nox_species(3), noy_species(26) - integer :: clox_species(6), cloy_species(9), tcly_species(21) - integer :: brox_species(4), broy_species(6), tbry_species(13) - integer :: foy_species(4), tfy_species(16) - integer :: hox_species(4) - integer :: toth_species(3) - integer :: sox_species(3) - integer :: nhx_species(2) - integer :: aer_species(gas_pcnst) - - character(len=fieldname_len) :: dtchem_name(gas_pcnst) - character(len=fieldname_len) :: depvel_name(gas_pcnst) - character(len=fieldname_len) :: depflx_name(gas_pcnst) - character(len=fieldname_len) :: wetdep_name(gas_pcnst) - character(len=fieldname_len) :: wtrate_name(gas_pcnst) - character(len=fieldname_len) :: wetdep_name_area(gas_pcnst) - - real(r8), parameter :: N_molwgt = 14.00674_r8 - real(r8), parameter :: S_molwgt = 32.066_r8 - -contains - - subroutine chm_diags_inti - !-------------------------------------------------------------------- - ! ... initialize utility routine - !-------------------------------------------------------------------- - - use cam_history, only : addfld, add_default, horiz_only - use constituents, only : cnst_get_ind, cnst_longname - use phys_control, only : phys_getopts - use mo_drydep, only : has_drydep - use species_sums_diags, only : species_sums_init - use commondefinitions - use aerosoldef, only: getCloudTracerIndexDirect, getCloudTracerName, isAerosol - implicit none - - integer :: j, k, m, n - character(len=16) :: jname, spc_name, attr - character(len=2) :: jchar - character(len=2) :: unit_basename ! Units 'kg' or '1' - - integer :: id_pan, id_onit, id_mpan, id_isopno3, id_onitr, id_nh4no3 - integer :: id_so2, id_so4, id_h2so4 - integer :: id_nh3, id_nh4 - integer :: id_honitr - integer :: id_alknit - integer :: id_isopnita - integer :: id_isopnitb - integer :: id_isopnooh - integer :: id_nc4ch2oh - integer :: id_nc4cho - integer :: id_noa - integer :: id_nterpooh - integer :: id_pbznit - integer :: id_terpnit - integer :: id_dst01, id_dst02, id_dst03, id_dst04, id_sslt01, id_sslt02, id_sslt03, id_sslt04 - integer :: id_soa, id_oc1, id_oc2, id_cb1, id_cb2 - integer :: id_soam,id_soai,id_soat,id_soab,id_soax - integer :: id_bry, id_cly - - logical :: history_aerosol ! Output the MAM aerosol tendencies - logical :: history_chemistry - logical :: history_cesm_forcing - logical :: history_scwaccm_forcing - logical :: history_chemspecies_srf ! output the chemistry constituents species in the surface layer - integer :: bulkaero_species(20) - integer :: cloudTracerIndex - character(len=20) :: cloudTracerName - !----------------------------------------------------------------------- - - call phys_getopts( history_aerosol_out = history_aerosol, & - history_chemistry_out = history_chemistry, & - history_chemspecies_srf_out = history_chemspecies_srf, & - history_cesm_forcing_out = history_cesm_forcing, & - history_scwaccm_forcing_out = history_scwaccm_forcing ) - - id_bry = get_spc_ndx( 'BRY' ) - id_cly = get_spc_ndx( 'CLY' ) - - id_n = get_spc_ndx( 'N' ) - id_no = get_spc_ndx( 'NO' ) - id_no2 = get_spc_ndx( 'NO2' ) - id_no3 = get_spc_ndx( 'NO3' ) - id_n2o5 = get_spc_ndx( 'N2O5' ) - id_n2o = get_spc_ndx( 'N2O' ) - id_hno3 = get_spc_ndx( 'HNO3' ) - id_ho2no2 = get_spc_ndx( 'HO2NO2' ) - id_clono2 = get_spc_ndx( 'CLONO2' ) - id_brono2 = get_spc_ndx( 'BRONO2' ) - id_cl = get_spc_ndx( 'CL' ) - id_clo = get_spc_ndx( 'CLO' ) - id_hocl = get_spc_ndx( 'HOCL' ) - id_cl2 = get_spc_ndx( 'CL2' ) - id_cl2o2 = get_spc_ndx( 'CL2O2' ) - id_oclo = get_spc_ndx( 'OCLO' ) - id_hcl = get_spc_ndx( 'HCL' ) - id_brcl = get_spc_ndx( 'BRCL' ) - - id_co2 = get_spc_ndx( 'CO2' ) - id_o3 = get_spc_ndx( 'O3' ) - id_oh = get_spc_ndx( 'OH' ) - id_ho2 = get_spc_ndx( 'HO2' ) - id_h2o2 = get_spc_ndx( 'H2O2' ) - id_so4_a1 = get_spc_ndx( 'so4_a1' ) - id_so4_a2 = get_spc_ndx( 'so4_a2' ) - id_so4_a3 = get_spc_ndx( 'so4_a3' ) - id_num_a2 = get_spc_ndx( 'num_a2' ) - id_num_a3 = get_spc_ndx( 'num_a3' ) - id_dst_a3 = get_spc_ndx( 'dst_a3' ) - id_ncl_a3 = get_spc_ndx( 'ncl_a3' ) - - id_f = get_spc_ndx( 'F' ) - id_hf = get_spc_ndx( 'HF' ) - id_cofcl = get_spc_ndx( 'COFCL' ) - id_cof2 = get_spc_ndx( 'COF2' ) - - id_ccl4 = get_spc_ndx( 'CCL4' ) - id_cfc11 = get_spc_ndx( 'CFC11' ) - - id_cfc113 = get_spc_ndx( 'CFC113' ) - id_cfc114 = get_spc_ndx( 'CFC114' ) - id_cfc115 = get_spc_ndx( 'CFC115' ) - - id_ch3ccl3 = get_spc_ndx( 'CH3CCL3' ) - id_cfc12 = get_spc_ndx( 'CFC12' ) - id_ch3cl = get_spc_ndx( 'CH3CL' ) - - id_hcfc22 = get_spc_ndx( 'HCFC22' ) - id_hcfc141b= get_spc_ndx( 'HCFC141B' ) - id_hcfc142b= get_spc_ndx( 'HCFC142B' ) - - id_cf2clbr = get_spc_ndx( 'CF2CLBR' ) - id_cf3br = get_spc_ndx( 'CF3BR' ) - id_ch3br = get_spc_ndx( 'CH3BR' ) - id_h1202 = get_spc_ndx( 'H1202' ) - id_h2402 = get_spc_ndx( 'H2402' ) - id_ch2br2 = get_spc_ndx( 'CH2BR2' ) - id_chbr3 = get_spc_ndx( 'CHBR3' ) - - id_br = get_spc_ndx( 'BR' ) - id_bro = get_spc_ndx( 'BRO' ) - id_hbr = get_spc_ndx( 'HBR' ) - id_hobr = get_spc_ndx( 'HOBR' ) - id_ch4 = get_spc_ndx( 'CH4' ) - id_h2o = get_spc_ndx( 'H2O' ) - id_h2 = get_spc_ndx( 'H2' ) - id_o = get_spc_ndx( 'O' ) - id_o2 = get_spc_ndx( 'O2' ) - id_h = get_spc_ndx( 'H' ) - - id_pan = get_spc_ndx( 'PAN' ) - id_onit = get_spc_ndx( 'ONIT' ) - id_mpan = get_spc_ndx( 'MPAN' ) - id_isopno3 = get_spc_ndx( 'ISOPNO3' ) - id_onitr = get_spc_ndx( 'ONITR' ) - id_nh4no3 = get_spc_ndx( 'NH4NO3' ) - - id_honitr = get_spc_ndx( 'HONITR' ) - id_alknit = get_spc_ndx( 'ALKNIT' ) - id_isopnita = get_spc_ndx( 'ISOPNITA' ) - id_isopnitb = get_spc_ndx( 'ISOPNITB' ) - id_isopnooh = get_spc_ndx( 'ISOPNOOH' ) - id_nc4ch2oh = get_spc_ndx( 'NC4CH2OH' ) - id_nc4cho = get_spc_ndx( 'NC4CHO' ) - id_noa = get_spc_ndx( 'NOA' ) - id_nterpooh = get_spc_ndx( 'NTERPOOH' ) - id_pbznit = get_spc_ndx( 'PBZNIT' ) - id_terpnit = get_spc_ndx( 'TERPNIT' ) - id_ndep = get_spc_ndx( 'NDEP' ) - id_nhdep = get_spc_ndx( 'NHDEP' ) - - id_so2 = get_spc_ndx( 'SO2' ) - id_so4 = get_spc_ndx( 'SO4' ) - id_h2so4 = get_spc_ndx( 'H2SO4' ) - - id_nh3 = get_spc_ndx( 'NH3' ) - id_nh4 = get_spc_ndx( 'NH4' ) - id_nh4no3 = get_spc_ndx( 'NH4NO3' ) - - id_dst01 = get_spc_ndx( 'DST01' ) - id_dst02 = get_spc_ndx( 'DST02' ) - id_dst03 = get_spc_ndx( 'DST03' ) - id_dst04 = get_spc_ndx( 'DST04' ) - id_sslt01 = get_spc_ndx( 'SSLT01' ) - id_sslt02 = get_spc_ndx( 'SSLT02' ) - id_sslt03 = get_spc_ndx( 'SSLT03' ) - id_sslt04 = get_spc_ndx( 'SSLT04' ) - id_soa = get_spc_ndx( 'SOA' ) - id_so4 = get_spc_ndx( 'SO4' ) - id_oc1 = get_spc_ndx( 'OC1' ) - id_oc2 = get_spc_ndx( 'OC2' ) - id_cb1 = get_spc_ndx( 'CB1' ) - id_cb2 = get_spc_ndx( 'CB2' ) - - rid_jno = get_rxt_ndx( 'jno' ) - rid_jno_i = get_rxt_ndx( 'jno_i' ) - - id_soam = get_spc_ndx( 'SOAM' ) - id_soai = get_spc_ndx( 'SOAI' ) - id_soat = get_spc_ndx( 'SOAT' ) - id_soab = get_spc_ndx( 'SOAB' ) - id_soax = get_spc_ndx( 'SOAX' ) - - - !... NOY species - nox_species = (/ id_n, id_no, id_no2 /) - noy_species = (/ id_n, id_no, id_no2, id_no3, id_n2o5, id_hno3, id_ho2no2, id_clono2, & - id_brono2, id_pan, id_onit, id_mpan, id_isopno3, id_onitr, id_nh4no3, & - id_honitr, id_alknit, id_isopnita, id_isopnitb, id_isopnooh, id_nc4ch2oh, & - id_nc4cho, id_noa, id_nterpooh, id_pbznit, id_terpnit /) - !... HOX species - hox_species = (/ id_h, id_oh, id_ho2, id_h2o2 /) - - !... CLOY species - clox_species = (/ id_cl, id_clo, id_hocl, id_cl2, id_cl2o2, id_oclo /) - cloy_species = (/ id_cl, id_clo, id_hocl, id_cl2, id_cl2o2, id_oclo, id_hcl, id_clono2, id_brcl /) - tcly_species = (/ id_cl, id_clo, id_hocl, id_cl2, id_cl2o2, id_oclo, id_hcl, id_clono2, id_brcl, & - id_ccl4, id_cfc11, id_cfc113, id_cfc114, id_cfc115, id_ch3ccl3, id_cfc12, id_ch3cl, & - id_hcfc22, id_hcfc141b, id_hcfc142b, id_cf2clbr /) - - !... FOY species - foy_species = (/ id_F, id_hf, id_cofcl, id_cof2 /) - tfy_species = (/ id_f, id_hf, id_cofcl, id_cof2, id_cfc11, id_cfc12, id_cfc113, id_cfc114, id_cfc115, & - id_hcfc22, id_hcfc141b, id_hcfc142b, id_cf2clbr, id_cf3br, id_h1202, id_h2402 /) - - !... BROY species - brox_species = (/ id_br, id_bro, id_brcl, id_hobr /) - broy_species = (/ id_br, id_bro, id_hbr, id_brono2, id_brcl, id_hobr /) - tbry_species = (/ id_br, id_bro, id_hbr, id_brono2, id_brcl, id_hobr, id_cf2clbr, id_cf3br, id_ch3br, id_h1202, & - id_h2402, id_ch2br2, id_chbr3 /) - - sox_species = (/ id_so2, id_so4, id_h2so4 /) - nhx_species = (/ id_nh3, id_nh4 /) - bulkaero_species(:) = -1 - bulkaero_species(1:20) = (/ id_dst01, id_dst02, id_dst03, id_dst04, & - id_sslt01, id_sslt02, id_sslt03, id_sslt04, & - id_soa, id_so4, id_oc1, id_oc2, id_cb1, id_cb2, id_nh4no3, & - id_soam,id_soai,id_soat,id_soab,id_soax /) - - aer_species(:) = -1 - n = 1 - do m = 1,gas_pcnst - k=0 - if ( any(bulkaero_species(:)==m) ) k=1 - if ( k==0 ) k = index(trim(solsym(m)), '_a') - if ( k==0 ) k = index(trim(solsym(m)), '_c') - if ( k>0 ) then ! must be aerosol species - aer_species(n) = m - n = n+1 - endif - enddo - - toth_species = (/ id_ch4, id_h2o, id_h2 /) - - call addfld( 'NOX', (/ 'lev' /), 'A', 'mol/mol', 'nox (N+NO+NO2)' ) - call addfld( 'NOY', (/ 'lev' /), 'A', 'mol/mol', & - 'noy = total nitrogen (N+NO+NO2+NO3+2N2O5+HNO3+HO2NO2+ORGNOY+NH4NO3' ) - call addfld( 'NOY_SRF', horiz_only, 'A', 'mol/mol', 'surface noy volume mixing ratio' ) - call addfld( 'HOX', (/ 'lev' /), 'A', 'mol/mol', 'HOx (H+OH+HO2+2H2O2)' ) - - call addfld( 'BROX', (/ 'lev' /), 'A', 'mol/mol', 'brox (Br+BrO+BRCl+HOBr)' ) - call addfld( 'BROY', (/ 'lev' /), 'A', 'mol/mol', 'total inorganic bromine (Br+BrO+HOBr+BrONO2+HBr+BrCl)' ) - call addfld( 'TBRY', (/ 'lev' /), 'A', 'mol/mol', 'total Br (ORG+INORG) volume mixing ratio' ) - - call addfld( 'CLOX', (/ 'lev' /), 'A', 'mol/mol', 'clox (Cl+CLO+HOCl+2Cl2+2Cl2O2+OClO' ) - call addfld( 'CLOY', (/ 'lev' /), 'A', 'mol/mol', 'total inorganic chlorine (Cl+ClO+2Cl2+2Cl2O2+OClO+HOCl+ClONO2+HCl+BrCl)' ) - call addfld( 'TCLY', (/ 'lev' /), 'A', 'mol/mol', 'total Cl (ORG+INORG) volume mixing ratio' ) - - call addfld( 'FOY', (/ 'lev' /), 'A', 'mol/mol', 'total inorganic fluorine (F+HF+COFCL+2COF2)' ) - call addfld( 'TFY', (/ 'lev' /), 'A', 'mol/mol', 'total F (ORG+INORG) volume mixing ratio' ) - - call addfld( 'TOTH', (/ 'lev' /), 'A', 'mol/mol', 'total H2 volume mixing ratio' ) - - call addfld( 'NOY_mmr', (/ 'lev' /), 'A', 'kg/kg', 'NOy mass mixing ratio' ) - call addfld( 'SOX_mmr', (/ 'lev' /), 'A', 'kg/kg', 'SOx mass mixing ratio' ) - call addfld( 'NHX_mmr', (/ 'lev' /), 'A', 'kg/kg', 'NHx mass mixing ratio' ) - - do j = 1,NJEUV - write( jchar, '(I2)' ) j - jname = 'jeuv_'//trim(adjustl(jchar)) - rid_jeuv(j) = get_rxt_ndx( trim(jname) ) - enddo - - has_jeuvs = all( rid_jeuv(:) > 0 ) - has_jno_i = rid_jno_i>0 - has_jno = rid_jno>0 - - if ( has_jeuvs ) then - call addfld( 'PION_EUV', (/ 'lev' /), 'I', '/cm^3/s', 'total euv ionization rate' ) - call addfld( 'PEUV1', (/ 'lev' /), 'I', '/cm^3/s', '(j1+j2+j3)*o' ) - call addfld( 'PEUV1e', (/ 'lev' /), 'I', '/cm^3/s', '(j14+j15+j16)*o' ) - call addfld( 'PEUV2', (/ 'lev' /), 'I', '/cm^3/s', 'j4*n' ) - call addfld( 'PEUV3', (/ 'lev' /), 'I', '/cm^3/s', '(j5+j7+j8+j9)*o2' ) - call addfld( 'PEUV3e', (/ 'lev' /), 'I', '/cm^3/s', '(j17+j19+j20+j21)*o2' ) - call addfld( 'PEUV4', (/ 'lev' /), 'I', '/cm^3/s', '(j10+j11)*n2' ) - call addfld( 'PEUV4e', (/ 'lev' /), 'I', '/cm^3/s', '(j22+j23)*n2' ) - call addfld( 'PEUVN2D', (/ 'lev' /), 'I', '/cm^3/s', '(j11+j13)*n2' ) - call addfld( 'PEUVN2De', (/ 'lev' /), 'I', '/cm^3/s', '(j23+j25)*n2' ) - endif - if ( has_jno ) then - call addfld( 'PJNO', (/ 'lev' /), 'I', '/cm^3/s', 'jno*no' ) - endif - if ( has_jno_i ) then - call addfld( 'PJNO_I', (/ 'lev' /), 'I', '/cm^3/s', 'jno_i*no' ) - endif - ! - ! CCMI - ! - call addfld( 'DO3CHM_TRP', horiz_only, 'A', 'kg/s', 'integrated net tendency from chem in troposphere', & - flag_xyfill=.True. ) - call addfld( 'DO3CHM_LMS', horiz_only, 'A', 'kg/s', 'integrated net tendency from chem in lowermost stratosphere', & - flag_xyfill=.True. ) - ! - do m = 1,gas_pcnst - - spc_name = trim(solsym(m)) - - call cnst_get_ind(spc_name, n, abort=.false. ) - if ( n > 0 ) then - attr = cnst_longname(n) - elseif ( trim(spc_name) == 'H2O' ) then - attr = 'water vapor' - else - attr = spc_name - endif - - depvel_name(m) = 'DV_'//trim(spc_name) - depflx_name(m) = 'DF_'//trim(spc_name) - dtchem_name(m) = 'D'//trim(spc_name)//'CHM' - - call addfld( depvel_name(m), horiz_only, 'A', 'cm/s', 'deposition velocity ' ) - call addfld( depflx_name(m), horiz_only, 'A', 'kg/m2/s', 'dry deposition flux ' ) - call addfld( dtchem_name(m), (/ 'lev' /), 'A', 'kg/s', 'net tendency from chem' ) - - if (has_drydep(spc_name).and.history_chemistry) then - call add_default( depflx_name(m), 1, ' ' ) - endif - - if (gas_wetdep_method=='MOZ') then - wetdep_name(m) = 'WD_'//trim(spc_name) - wtrate_name(m) = 'WDR_'//trim(spc_name) - - call addfld( wetdep_name(m), horiz_only, 'A', 'kg/s', spc_name//' wet deposition' ) - call addfld( wtrate_name(m), (/ 'lev' /), 'A', '/s', spc_name//' wet deposition rate' ) - endif - - wetdep_name_area(m)='WD_A_'//trim(spc_name) - call addfld( wetdep_name_area(m), horiz_only, 'A', 'kg/m2/s ', spc_name//' wet deposition' ) - - !Needed for budget term of gases! Aerosols have their own budget terms - if(n.gt.0) then - if(.NOT. isAerosol(n))then - if(history_chemistry)then - call add_default( wetdep_name_area(m), 1, ' ') - end if - endif - end if - - if (spc_name(1:3) == 'num') then - unit_basename = ' 1' - else - unit_basename = 'kg' - endif - - if (n.gt.0) then - if ( any( aer_species == m ) .or. isAerosol(n) ) then - call addfld( spc_name, (/ 'lev' /), 'A', unit_basename//'/kg ', trim(attr)//' concentration') - call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', unit_basename//'/kg', trim(attr)//" in bottom layer") - else - call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') - call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") - endif - else - call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') - call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") - endif - - if ((m /= id_cly) .and. (m /= id_bry)) then - if (history_aerosol.or.history_chemistry) then - call add_default( spc_name, 1, ' ' ) - endif - if (history_chemspecies_srf) then - call add_default( trim(spc_name)//'_SRF', 1, ' ' ) - endif - endif - - if ( history_cesm_forcing ) then - if (m==id_o3) call add_default( spc_name, 1, ' ') - if (m==id_oh) call add_default( spc_name, 1, ' ') - if (m==id_no3) call add_default( spc_name, 1, ' ') - if (m==id_ho2) call add_default( spc_name, 1, ' ') - - if (m==id_o3) call add_default( spc_name, 8, ' ') - if (m==id_so4_a1) call add_default( spc_name, 8, ' ') - if (m==id_so4_a2) call add_default( spc_name, 8, ' ') - if (m==id_so4_a3) call add_default( spc_name, 8, ' ') - - if (m==id_num_a2) call add_default( spc_name, 8, ' ') - if (m==id_num_a3) call add_default( spc_name, 8, ' ') - if (m==id_dst_a3) call add_default( spc_name, 8, ' ') - if (m==id_ncl_a3) call add_default( spc_name, 8, ' ') - - endif - if ( history_scwaccm_forcing ) then - if (m==id_co2) call add_default( spc_name, 8, ' ') - if (m==id_h) call add_default( spc_name, 8, ' ') - if (m==id_no) call add_default( spc_name, 8, ' ') - if (m==id_o) call add_default( spc_name, 8, ' ') - if (m==id_o2) call add_default( spc_name, 8, ' ') - if (m==id_o3) call add_default( spc_name, 8, ' ') - if (m==id_h2o) call add_default( spc_name, 1, ' ') - if (m==id_ch4 ) call add_default( spc_name, 1, ' ') - if (m==id_n2o ) call add_default( spc_name, 1, ' ') - if (m==id_cfc11 ) call add_default( spc_name, 1, ' ') - if (m==id_cfc12 ) call add_default( spc_name, 1, ' ') - endif - - call add_default( spc_name, 1, ' ' ) - - !output 3d-field of aersol tracer in cloud water - if(n > 0) then - cloudTracerIndex = getCloudTracerIndexDirect(n) - if(cloudTracerIndex > 0)then - cloudTracerName(1:len(CloudTracerName))=" " - cloudTracerName = getCloudTracerName(n) - call addfld( trim(cloudTracerName), (/'lev'/), 'A','kg/kg', & - trim(cloudTracerName)//' in cloud water') - call add_default( trim(cloudTracerName), 1, ' ' ) - - !Add column burden of cloud tracers - call addfld('cb_'//trim(cloudTracerName),horiz_only, 'A', 'kg/m2', & - 'cb_'//trim(cloudTracerName)//' column in cloud water') - call add_default('cb_'//trim(cloudTracerName),1,' ') - endif - !..and column burden in clean air - call addfld('cb_'//trim(spc_name),horiz_only, 'A', 'kg/m2', & - 'cb_'//trim(spc_name)//' in column') - call add_default('cb_'//trim(spc_name),1,' ' ) - - if(history_aerosol)then - if(cloudTracerIndex > 0)then - !Output budget-terms for cloud borne aerosols - call add_default (trim(cloudTracerName)//'GVF', 1, ' ') - call add_default (trim(cloudTracerName)//'SFWET', 1, ' ') - call add_default (trim(cloudTracerName)//'TBF', 1, ' ') - call add_default (trim(cloudTracerName)//'DDF', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSBS', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSIC', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSBC', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSIS', 1, ' ') - endif - endif - end if - - enddo - - call addfld( 'MASS', (/ 'lev' /), 'A', 'kg', 'mass of grid box' ) - call addfld( 'AREA', horiz_only, 'A', 'm2', 'area of grid box' ) - do n=1,N_AEROSOL_TYPES - call addfld('cb_'//trim(aerosol_type_name(n)),horiz_only, 'A', 'kg/m2',& - 'cb_'//trim(aerosol_type_name(n))//' column of aerosol type') - call add_default('cb_'//trim(aerosol_type_name(n)), 1, ' ') - call addfld('mmr_'//trim(aerosol_type_name(n)),(/'lev'/),'A','kg/kg' ,& - 'mmr_'//trim(aerosol_type_name(n))//' mmr of aerosol type') - call add_default('mmr_'//trim(aerosol_type_name(n)), 1, ' ') - end do - - call addfld( 'dry_deposition_NOy_as_N', horiz_only, 'I', 'kg/m2/s', 'NOy dry deposition flux ' ) - call addfld( 'DF_SOX', horiz_only, 'I', 'kg/m2/s', 'SOx dry deposition flux ' ) - call addfld( 'dry_deposition_NHx_as_N', horiz_only, 'I', 'kg/m2/s', 'NHx dry deposition flux ' ) - if (gas_wetdep_method=='NEU') then - call addfld( 'wet_deposition_NOy_as_N', horiz_only, 'A', 'kg/m2/s', 'NOy wet deposition' ) - call addfld( 'wet_deposition_NHx_as_N', horiz_only, 'A', 'kg/m2/s', 'NHx wet deposition' ) - elseif (gas_wetdep_method=='MOZ') then - call addfld( 'wet_deposition_NOy_as_N', horiz_only, 'A', 'kg/s', 'NOy wet deposition' ) - call addfld( 'WD_SOX', horiz_only, 'A', 'kg/s', 'SOx wet deposition' ) - call addfld( 'wet_deposition_NHx_as_N', horiz_only, 'A', 'kg/s', 'NHx wet deposition' ) - endif - if ( history_cesm_forcing ) then - call add_default('dry_deposition_NOy_as_N', 1, ' ') - call add_default('dry_deposition_NHx_as_N', 1, ' ') - call add_default('wet_deposition_NOy_as_N', 1, ' ') - call add_default('wet_deposition_NHx_as_N', 1, ' ') - endif - - call species_sums_init() - - end subroutine chm_diags_inti - - subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depflx, mmr_tend, pdel, pmid, ltrop, & - wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx, pbuf) - !-------------------------------------------------------------------- - ! ... utility routine to output chemistry diagnostic variables - !-------------------------------------------------------------------- - - use cam_history, only : outfld - use phys_grid, only : get_area_all_p - use species_sums_diags, only : species_sums_output - use constituents, only : cnst_get_ind - use phys_grid, only : pcols - use commondefinitions - use aerosoldef, only : getCloudTracerIndexDirect, getCloudTracerName & - , aerosolType, isAerosol - use physics_buffer, only : pbuf_get_field, pbuf_get_index - use physics_buffer, only : physics_buffer_desc - use cam_history_support, only : fillvalue ! CCMI - - !-------------------------------------------------------------------- - ! ... dummy arguments - !-------------------------------------------------------------------- - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - real(r8), intent(in) :: vmr(ncol,pver,gas_pcnst) - real(r8), intent(in) :: mmr(ncol,pver,gas_pcnst) - real(r8), intent(in) :: rxt_rates(ncol,pver,rxntot) - real(r8), intent(in) :: invariants(ncol,pver,max(1,nfs)) - real(r8), intent(in) :: depvel(ncol, gas_pcnst) - real(r8), intent(in) :: depflx(ncol, gas_pcnst) - real(r8), intent(in) :: mmr_tend(ncol,pver,gas_pcnst) - real(r8), intent(in) :: pdel(ncol,pver) - real(r8), intent(in) :: pmid(ncol,pver) - integer, intent(in) :: ltrop(ncol) - real(r8), intent(in) :: wetdepflx(ncol, gas_pcnst) - real(r8), intent(out) :: nhx_nitrogen_flx(ncol) ! kgN/m2/sec - real(r8), intent(out) :: noy_nitrogen_flx(ncol) ! kgN/m2/sec - type(physics_buffer_desc), pointer :: pbuf(:) - - real(r8), dimension(:,:), pointer :: cloudTracerField - integer :: cloudTracerIndex - character(len=20) :: cloudTracerName - real(r8) :: mass_tmp(pcols,pver) - real(r8) :: cb(pcols) - real(r8) :: cb_aerosol_type(pcols,N_AEROSOL_TYPES) !column burden aerosol types - real(r8) :: mmr_aerosol_type(pcols,pver,N_AEROSOL_TYPES) !concentration aerosol types - - !-------------------------------------------------------------------- - ! ... local variables - !-------------------------------------------------------------------- - integer :: i, k, m, n - real(r8) :: wrk(ncol,pver) - ! real(r8) :: tmp(ncol,pver) - ! real(r8) :: m(ncol,pver) - real(r8) :: un2(ncol) - - real(r8), dimension(ncol,pver) :: vmr_nox, vmr_noy, vmr_clox, vmr_cloy, vmr_tcly, vmr_brox, vmr_broy, vmr_toth - real(r8), dimension(ncol,pver) :: vmr_tbry, vmr_foy, vmr_tfy - real(r8), dimension(ncol,pver) :: mmr_noy, mmr_sox, mmr_nhx, net_chem - real(r8), dimension(ncol) :: df_noy, df_sox, df_nhx, do3chm_trp, do3chm_lms - real(r8), dimension(ncol) :: wd_noy, wd_nhx - real(r8), dimension(ncol,pver) :: vmr_hox - - real(r8) :: area(ncol), mass(ncol,pver) - real(r8) :: wgt - character(len=16) :: spc_name - - - !-------------------------------------------------------------------- - ! ... "diagnostic" groups - !-------------------------------------------------------------------- - vmr_nox(:ncol,:) = 0._r8 - vmr_noy(:ncol,:) = 0._r8 - vmr_hox(:ncol,:) = 0._r8 - vmr_clox(:ncol,:) = 0._r8 - vmr_cloy(:ncol,:) = 0._r8 - vmr_tcly(:ncol,:) = 0._r8 - vmr_brox(:ncol,:) = 0._r8 - vmr_broy(:ncol,:) = 0._r8 - vmr_tbry(:ncol,:) = 0._r8 - vmr_foy(:ncol,:) = 0._r8 - vmr_tfy(:ncol,:) = 0._r8 - vmr_toth(:ncol,:) = 0._r8 - mmr_noy(:ncol,:) = 0._r8 - mmr_sox(:ncol,:) = 0._r8 - mmr_nhx(:ncol,:) = 0._r8 - df_noy(:ncol) = 0._r8 - df_sox(:ncol) = 0._r8 - df_nhx(:ncol) = 0._r8 - - wd_noy(:ncol) = 0._r8 - wd_nhx(:ncol) = 0._r8 - - call get_area_all_p(lchnk, ncol, area) - area = area * rearth**2 - - do k = 1,pver - mass(:ncol,k) = pdel(:ncol,k) * area(:ncol) * rgrav - enddo - - call outfld( 'AREA', area(:ncol), ncol, lchnk ) - call outfld( 'MASS', mass(:ncol,:), ncol, lchnk ) - - cb_aerosol_type(:,:) = 0.0_r8 - mmr_aerosol_type(:,:,:) = 0.0_r8 - - do m = 1,gas_pcnst - - !...FOY (counting Fluorines, not chlorines or bromines) - if ( m == id_cfc12 .or. m == id_hcfc22 .or. m == id_cf2clbr .or. m == id_h1202 .or. m == id_hcfc142b & - .or. m == id_cof2 ) then - wgt = 2._r8 - elseif ( m == id_cfc113 .or. m == id_cf3br ) then - wgt = 3._r8 - elseif ( m == id_cfc114 .or. m == id_h2402 ) then - wgt = 4._r8 - elseif ( m == id_cfc115 ) then - wgt = 5._r8 - else - wgt = 1._r8 - endif - if ( any( foy_species == m ) ) then - vmr_foy(:ncol,:) = vmr_foy(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - if ( any( tfy_species == m ) ) then - vmr_tfy(:ncol,:) = vmr_tfy(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - - !... counting chlorine and bromines, etc... (and total H2 species) - if ( m == id_ch4 .or. m == id_n2o5 .or. m == id_cfc12 .or. m == id_cl2 .or. m == id_cl2o2 .or. m==id_h2o2 ) then - wgt = 2._r8 - elseif (m == id_cfc114 .or. m == id_hcfc141b .or. m == id_h1202 .or. m == id_h2402 .or. m == id_ch2br2 ) then - wgt = 2._r8 - elseif ( m == id_cfc11 .or. m == id_cfc113 .or. m == id_ch3ccl3 .or. m == id_chbr3 ) then - wgt = 3._r8 - elseif ( m == id_ccl4 ) then - wgt = 4._r8 - else - wgt = 1._r8 - endif - !...NOY - if ( any( nox_species == m ) ) then - vmr_nox(:ncol,:) = vmr_nox(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - if ( any( noy_species == m ) ) then - vmr_noy(:ncol,:) = vmr_noy(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - !...NOY, SOX, NHX - if ( any( noy_species == m ) ) then - mmr_noy(:ncol,:) = mmr_noy(:ncol,:) + wgt * mmr(:ncol,:,m) - endif - if ( any( sox_species == m ) ) then - mmr_sox(:ncol,:) = mmr_sox(:ncol,:) + wgt * mmr(:ncol,:,m) - endif - if ( any( nhx_species == m ) ) then - mmr_nhx(:ncol,:) = mmr_nhx(:ncol,:) + wgt * mmr(:ncol,:,m) - endif - !...CLOY - if ( any( clox_species == m ) ) then - vmr_clox(:ncol,:) = vmr_clox(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - if ( any( cloy_species == m ) ) then - vmr_cloy(:ncol,:) = vmr_cloy(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - if ( any( tcly_species == m ) ) then - vmr_tcly(:ncol,:) = vmr_tcly(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - !...BROY - if ( any( brox_species == m ) ) then - vmr_brox(:ncol,:) = vmr_brox(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - if ( any( broy_species == m ) ) then - vmr_broy(:ncol,:) = vmr_broy(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - if ( any( tbry_species == m ) ) then - vmr_tbry(:ncol,:) = vmr_tbry(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - !...HOY - if ( any ( toth_species == m ) ) then - vmr_toth(:ncol,:) = vmr_toth(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - !...HOx - if ( any( hox_species == m ) ) then - vmr_hox(:ncol,:) = vmr_hox(:ncol,:) + wgt * vmr(:ncol,:,m) - endif - - spc_name = trim(solsym(m)) - call cnst_get_ind(spc_name, n, abort=.false.) - - if (n.gt.0) then - if ( any( aer_species == m ) .or. isAerosol(n) ) then - call outfld( solsym(m), mmr(:ncol,:,m), ncol ,lchnk ) - call outfld( trim(solsym(m))//'_SRF', mmr(:ncol,pver,m), ncol ,lchnk ) - else - call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) - call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) - endif - else - call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) - call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) - end if - - if(n > 0) then - cloudTracerIndex = getCloudTracerIndexDirect(n) - if(cloudTracerIndex > 0)then - cloudTracerName = getCloudTracerName(n) - call pbuf_get_field(pbuf, cloudTracerIndex, cloudTracerField ) - call outfld ( trim(cloudTracerName),cloudTracerField,pcols,lchnk) - - !Treat column burden (cloud tracer) - mass_tmp(:ncol,:) = cloudTracerField(:ncol,:) *pdel(:ncol,:) * rgrav - cb(:ncol) = sum(mass_tmp(:ncol,:),2) - call outfld(trim('cb_'//trim(cloudTracerName)), cb, pcols, lchnk) - endif - !Treat column burden (normal tracer) - mass_tmp(:ncol,:) = mmr(:ncol,:,m) * pdel(:ncol,:) * rgrav - cb(:ncol) = sum(mass_tmp(:ncol,:),2) - call outfld(trim('cb_'//trim(spc_name)), cb, pcols, lchnk) - - !Sum column burden per aerosol type - if(aerosolType(n) .gt. 0)then - cb_aerosol_type(:ncol,aerosolType(n)) = & - cb_aerosol_type(:ncol,aerosolType(n)) & - + cb(:ncol) - - !Total mass mixing ratio of aerosol type - mmr_aerosol_type(:ncol,:,aerosolType(n)) = & - mmr_aerosol_type(:ncol,:,aerosolType(n)) & - + mmr(:ncol,:,m) - endif - - end if !Check if this is a chemistry tracer - - call outfld( depvel_name(m), depvel(:ncol,m), ncol ,lchnk ) - call outfld( depflx_name(m), depflx(:ncol,m), ncol ,lchnk ) - - if ( any( noy_species == m ) ) then - df_noy(:ncol) = df_noy(:ncol) + wgt * depflx(:ncol,m)*N_molwgt/adv_mass(m) - endif - if ( any( sox_species == m ) ) then - df_sox(:ncol) = df_sox(:ncol) + wgt * depflx(:ncol,m)*S_molwgt/adv_mass(m) - endif - if ( any( nhx_species == m ) ) then - df_nhx(:ncol) = df_nhx(:ncol) + wgt * depflx(:ncol,m)*N_molwgt/adv_mass(m) - endif - - if ( any( noy_species == m ) ) then - wd_noy(:ncol) = wd_noy(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) - endif - if ( any( nhx_species == m ) ) then - wd_nhx(:ncol) = wd_nhx(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) - endif - ! - ! add contribution from non-conservation tracers - ! - if ( id_ndep == m ) then - wd_noy(:ncol) = wd_noy(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) - end if - if ( id_nhdep == m ) then - wd_nhx(:ncol) = wd_nhx(:ncol) + wgt * wetdepflx(:ncol,m)*N_molwgt/adv_mass(m) - end if - - do k=1,pver - do i=1,ncol - net_chem(i,k) = mmr_tend(i,k,m) * mass(i,k) - end do - end do - call outfld( dtchem_name(m), net_chem(:ncol,:), ncol, lchnk ) - ! - ! CCMI - ! - if ( trim(dtchem_name(m)) == 'DO3CHM' ) then - do3chm_trp(:) = 0._r8 - do i=1,ncol - do k=ltrop(i),pver - do3chm_trp(i) = do3chm_trp(i) + net_chem(i,k) - end do - end do - where ( do3chm_trp == 0._r8 ) - do3chm_trp = fillvalue - end where - call outfld('DO3CHM_TRP',do3chm_trp(:ncol), ncol, lchnk ) - do3chm_lms(:) = 0._r8 - do i=1,ncol - do k=1,pver - if ( pmid(i,k) > 100.e2_r8 .and. k < ltrop(i) ) then - do3chm_lms(i) = do3chm_lms(i) + net_chem(i,k) - end if - end do - end do - where ( do3chm_lms == 0._r8 ) - do3chm_lms = fillvalue - end where - call outfld('DO3CHM_LMS',do3chm_lms(:ncol), ncol, lchnk ) - end if - ! - enddo - - do n=1,N_AEROSOL_TYPES - call outfld("mmr_"//trim(aerosol_type_name(n)), mmr_aerosol_type(:ncol,:,n), ncol,lchnk) - call outfld("cb_"//trim(aerosol_type_name(n)), cb_aerosol_type(:ncol,n), ncol,lchnk) - enddo - call outfld( 'NOX', vmr_nox (:ncol,:), ncol, lchnk ) - call outfld( 'NOY', vmr_noy (:ncol,:), ncol, lchnk ) - call outfld( 'HOX', vmr_hox (:ncol,:), ncol, lchnk ) - call outfld( 'NOY_SRF', vmr_noy(:ncol,pver), ncol, lchnk ) - call outfld( 'CLOX', vmr_clox (:ncol,:), ncol, lchnk ) - call outfld( 'CLOY', vmr_cloy (:ncol,:), ncol, lchnk ) - call outfld( 'BROX', vmr_brox (:ncol,:), ncol, lchnk ) - call outfld( 'BROY', vmr_broy (:ncol,:), ncol, lchnk ) - call outfld( 'TCLY', vmr_tcly (:ncol,:), ncol, lchnk ) - call outfld( 'TBRY', vmr_tbry (:ncol,:), ncol, lchnk ) - call outfld( 'FOY', vmr_foy (:ncol,:), ncol, lchnk ) - call outfld( 'TFY', vmr_tfy (:ncol,:), ncol, lchnk ) - call outfld( 'TOTH', vmr_toth (:ncol,:), ncol, lchnk ) - - call outfld( 'NOY_mmr', mmr_noy(:ncol,:), ncol ,lchnk ) - call outfld( 'SOX_mmr', mmr_sox(:ncol,:), ncol ,lchnk ) - call outfld( 'NHX_mmr', mmr_nhx(:ncol,:), ncol ,lchnk ) - call outfld( 'dry_deposition_NOy_as_N', df_noy(:ncol), ncol ,lchnk ) - call outfld( 'DF_SOX', df_sox(:ncol), ncol ,lchnk ) - call outfld( 'dry_deposition_NHx_as_N', df_nhx(:ncol), ncol ,lchnk ) - if (gas_wetdep_method=='NEU') then - wd_noy(:ncol) = -wd_noy(:ncol) ! downward is possitive - wd_nhx(:ncol) = -wd_nhx(:ncol) - call outfld( 'wet_deposition_NOy_as_N', wd_noy(:ncol), ncol, lchnk ) - call outfld( 'wet_deposition_NHx_as_N', wd_nhx(:ncol), ncol, lchnk ) - end if - - nhx_nitrogen_flx = df_nhx + wd_nhx - noy_nitrogen_flx = df_noy + wd_noy - - !-------------------------------------------------------------------- - ! ... euv ion production - !-------------------------------------------------------------------- - - jeuvs: if ( has_jeuvs ) then - do k = 1,pver - un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) - wrk(:,k) = vmr(:,k,id_o)*(rxt_rates(:,k,rid_jeuv(1)) + rxt_rates(:,k,rid_jeuv(2)) & - + rxt_rates(:,k,rid_jeuv(3)) + rxt_rates(:,k,rid_jeuv(14)) & - + rxt_rates(:,k,rid_jeuv(15)) + rxt_rates(:,k,rid_jeuv(16))) & - + vmr(:,k,id_n)*rxt_rates(:,k,rid_jeuv(4)) & - + vmr(:,k,id_o2)*(rxt_rates(:,k,rid_jeuv(5)) + rxt_rates(:,k,rid_jeuv(7)) & - + rxt_rates(:,k,rid_jeuv(8)) + rxt_rates(:,k,rid_jeuv(9)) & - + rxt_rates(:,k,rid_jeuv(17)) + rxt_rates(:,k,rid_jeuv(19)) & - + rxt_rates(:,k,rid_jeuv(20)) + rxt_rates(:,k,rid_jeuv(21))) & - + un2(:)*(rxt_rates(:,k,rid_jeuv(6)) + rxt_rates(:,k,rid_jeuv(10)) & - + rxt_rates(:,k,rid_jeuv(11)) + rxt_rates(:,k,rid_jeuv(18)) & - + rxt_rates(:,k,rid_jeuv(22)) + rxt_rates(:,k,rid_jeuv(23))) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PION_EUV', wrk, ncol, lchnk ) - - do k = 1,pver - wrk(:,k) = vmr(:,k,id_o)*(rxt_rates(:,k,rid_jeuv(1)) + rxt_rates(:,k,rid_jeuv(2)) & - + rxt_rates(:,k,rid_jeuv(3))) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PEUV1', wrk, ncol, lchnk ) - do k = 1,pver - wrk(:,k) = vmr(:,k,id_o)*(rxt_rates(:,k,rid_jeuv(14)) + rxt_rates(:,k,rid_jeuv(15)) & - + rxt_rates(:,k,rid_jeuv(16))) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PEUV1e', wrk, ncol, lchnk ) - do k = 1,pver - wrk(:,k) = vmr(:,k,id_n)*rxt_rates(:,k,rid_jeuv(4)) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PEUV2', wrk, ncol, lchnk ) - do k = 1,pver - wrk(:,k) = vmr(:,k,id_o2)*(rxt_rates(:,k,rid_jeuv(5)) + rxt_rates(:,k,rid_jeuv(7)) & - + rxt_rates(:,k,rid_jeuv(8)) + rxt_rates(:,k,rid_jeuv(9))) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PEUV3', wrk, ncol, lchnk ) - do k = 1,pver - wrk(:,k) = vmr(:,k,id_o2)*(rxt_rates(:,k,rid_jeuv(17)) + rxt_rates(:,k,rid_jeuv(19)) & - + rxt_rates(:,k,rid_jeuv(20)) + rxt_rates(:,k,rid_jeuv(21))) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PEUV3e', wrk, ncol, lchnk ) - do k = 1,pver - un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) - wrk(:,k) = un2(:)*(rxt_rates(:,k,rid_jeuv(6)) + rxt_rates(:,k,rid_jeuv(10)) + rxt_rates(:,k,rid_jeuv(11))) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PEUV4', wrk, ncol, lchnk ) - do k = 1,pver - un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) - wrk(:,k) = un2(:)*(rxt_rates(:,k,rid_jeuv(18)) + rxt_rates(:,k,rid_jeuv(22)) + rxt_rates(:,k,rid_jeuv(23))) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PEUV4e', wrk, ncol, lchnk ) - do k = 1,pver - un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) - wrk(:,k) = un2(:)*(rxt_rates(:,k,rid_jeuv(11)) + rxt_rates(:,k,rid_jeuv(13))) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PEUVN2D', wrk, ncol, lchnk ) - do k = 1,pver - un2(:) = 1._r8 - (vmr(:,k,id_o) + vmr(:,k,id_o2) + vmr(:,k,id_h)) - wrk(:,k) = un2(:)*(rxt_rates(:,k,rid_jeuv(23)) + rxt_rates(:,k,rid_jeuv(25))) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PEUVN2De', wrk, ncol, lchnk ) - endif jeuvs - - if ( has_jno_i ) then - do k = 1,pver - wrk(:,k) = vmr(:,k,id_no)*rxt_rates(:,k,rid_jno_i) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PJNO_I', wrk, ncol, lchnk ) - endif - if ( has_jno ) then - do k = 1,pver - wrk(:,k) = vmr(:,k,id_no)*rxt_rates(:,k,rid_jno) - wrk(:,k) = wrk(:,k) * invariants(:,k,indexm) - end do - call outfld( 'PJNO', wrk, ncol, lchnk ) - endif - - call species_sums_output(vmr, mmr, ncol, lchnk) - - end subroutine chm_diags - - subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) - - use cam_history, only : outfld - use phys_grid, only : get_wght_all_p, get_area_all_p - implicit none - - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - real(r8), intent(in) :: het_rates(ncol,pver,max(1,gas_pcnst)) - real(r8), intent(in) :: mmr(ncol,pver,gas_pcnst) - real(r8), intent(in) :: pdel(ncol,pver) - - real(r8), dimension(ncol) :: noy_wk, sox_wk, nhx_wk, wrk_wd - real(r8), dimension(ncol) :: area - integer :: m, k - real(r8) :: wght(ncol) - ! - ! output integrated wet deposition field - ! - noy_wk(:) = 0._r8 - sox_wk(:) = 0._r8 - nhx_wk(:) = 0._r8 - - call get_area_all_p(lchnk, ncol, area) - area = area * rearth**2 - - call get_wght_all_p(lchnk, ncol, wght) - - do m = 1,gas_pcnst - ! - ! compute vertical integral - ! - wrk_wd(:ncol) = 0._r8 - do k = 1,pver - wrk_wd(:ncol) = wrk_wd(:ncol) + het_rates(:ncol,k,m) * mmr(:ncol,k,m) * pdel(:ncol,k) - end do - ! - wrk_wd(:ncol) = wrk_wd(:ncol) * rgrav * wght(:ncol) * rearth**2 - ! - if (gas_wetdep_method=='MOZ') then - call outfld( wetdep_name(m), wrk_wd(:ncol), ncol, lchnk ) - call outfld( wetdep_name_area(m), wrk_wd(:ncol)/area(:ncol) ,ncol, lchnk ) - call outfld( wtrate_name(m), het_rates(:ncol,:,m), ncol, lchnk ) - - if ( any(noy_species == m ) ) then - noy_wk(:ncol) = noy_wk(:ncol) + wrk_wd(:ncol)*N_molwgt/adv_mass(m) - endif - if ( m == id_n2o5 ) then ! 2 NOy molecules in N2O5 - noy_wk(:ncol) = noy_wk(:ncol) + wrk_wd(:ncol)*N_molwgt/adv_mass(m) - endif - if ( any(sox_species == m ) ) then - sox_wk(:ncol) = sox_wk(:ncol) + wrk_wd(:ncol)*S_molwgt/adv_mass(m) - endif - if ( any(nhx_species == m ) ) then - nhx_wk(:ncol) = nhx_wk(:ncol) + wrk_wd(:ncol)*N_molwgt/adv_mass(m) - endif - endif - end do - if (gas_wetdep_method=='MOZ') then - call outfld( 'wet_deposition_NOy_as_N', noy_wk(:ncol), ncol, lchnk ) - call outfld( 'WD_SOX', sox_wk(:ncol), ncol, lchnk ) - call outfld( 'wet_deposition_NHx_as_N', nhx_wk(:ncol), ncol, lchnk ) - endif - - end subroutine het_diags - -end module mo_chm_diags diff --git a/src/physics/cam_oslo/mo_drydep.F90 b/src/physics/cam_oslo/mo_drydep.F90 index b3c033c8d8..e81f3d66f7 100644 --- a/src/physics/cam_oslo/mo_drydep.F90 +++ b/src/physics/cam_oslo/mo_drydep.F90 @@ -4,6 +4,9 @@ module mo_drydep ! ... Dry deposition velocity input data and code for netcdf input !--------------------------------------------------------------------- +!LKE (10/11/2010): added HCN, CH3CN, HCOOH +!LKE (7/30/2015): added new TS1 species (phenooh, iepox, noa, etc.) + use shr_kind_mod, only : r8 => shr_kind_r8, shr_kind_cl use chem_mods, only : gas_pcnst use pmgrid, only : plev, plevp @@ -23,6 +26,8 @@ module mo_drydep implicit none + save + interface drydep_inti module procedure dvel_inti_table module procedure dvel_inti_xactive @@ -1611,7 +1616,9 @@ subroutine dvel_inti_xactive( depvel_lnd_file, clim_soilw_file, season_wes_file ! determine if modal aerosols are active so that fraction_landuse array is initialized for modal aerosal dry dep call phys_getopts(prog_modal_aero_out=prog_modal_aero) +#ifdef OSLO_AERO prog_modal_aero = .TRUE. +#endif call dvel_inti_fromlnd() diff --git a/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 b/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 index 8788535835..a8601643e7 100644 --- a/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 +++ b/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 @@ -6,13 +6,18 @@ module mo_gas_phase_chemdr use cam_history, only : fieldname_len use chem_mods, only : phtcnt, rxntot, gas_pcnst use chem_mods, only : rxt_tag_cnt, rxt_tag_lst, rxt_tag_map, extcnt, num_rnts +#ifdef OSLO_AERO + use oslo_aero_dust, only : dust_names, ndust => dust_nbin +#else use dust_model, only : dust_names, ndust => dust_nbin +#endif use ppgrid, only : pcols, pver use phys_control, only : phys_getopts use carma_flags_mod, only : carma_hetchem_feedback use chem_prod_loss_diags, only: chem_prod_loss_diags_init, chem_prod_loss_diags_out implicit none + save private public :: gas_phase_chemdr, gas_phase_chemdr_inti @@ -25,8 +30,10 @@ module mo_gas_phase_chemdr integer :: het1_ndx integer :: ndx_cldfr, ndx_cmfdqr, ndx_nevapr, ndx_cldtop, ndx_prain integer :: ndx_h2so4 +#ifdef OSLO_AERO logical :: inv_o3, inv_oh, inv_no3, inv_ho2 integer :: id_o3, id_oh, id_no3, id_ho2 +#endif ! ! CCMI ! @@ -62,6 +69,8 @@ subroutine gas_phase_chemdr_inti() use rate_diags, only : rate_diags_init use cam_abortutils, only : endrun + implicit none + character(len=3) :: string integer :: n, m, err, ii logical :: history_cesm_forcing @@ -73,6 +82,7 @@ subroutine gas_phase_chemdr_inti() call phys_getopts( convproc_do_aer_out = convproc_do_aer, history_cesm_forcing_out=history_cesm_forcing ) +#if defined(OSLO_AERO) inv_o3 = get_inv_ndx('O3') > 0 inv_oh = get_inv_ndx('OH') > 0 inv_no3 = get_inv_ndx('NO3') > 0 @@ -89,6 +99,7 @@ subroutine gas_phase_chemdr_inti() if (inv_ho2) then id_ho2 = get_inv_ndx('HO2') endif +#endif ndx_h2so4 = get_spc_ndx('H2SO4') ! @@ -216,7 +227,7 @@ subroutine gas_phase_chemdr_inti() call addfld( 'HCL_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase hcl' ) call addfld( 'HCL_STS', (/ 'lev' /), 'I', 'mol/mol', 'STS condensed HCL' ) - ! Adding extra fields for oxi-output (before and after diurnal variations.) + !++IH: Adding extra fields for oxi-output (before and after diurnal variations.) call addfld ('OH_bef ', (/ 'lev' /), 'A','unit', 'OH invariants before adding diurnal variations' ) call addfld ('HO2_bef ', (/ 'lev' /), 'A','unit', 'HO2 invariants before adding diurnal variations' ) call addfld ('NO3_bef ', (/ 'lev' /), 'A','unit', 'NO3 invariants before adding diurnal variations' ) @@ -327,19 +338,25 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & use mo_chm_diags, only : chm_diags, het_diags use perf_mod, only : t_startf, t_stopf use gas_wetdep_opts, only : gas_wetdep_method +#if (defined OSLO_AERO) use oslo_aero_diurnal_var, only : set_diurnal_invariants +#endif use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx use infnan, only : nan, assignment(=) use rate_diags, only : rate_diags_calc use mo_mass_xforms, only : mmr2vmr, vmr2mmr, h2o_to_vmr, mmr2vmri use orbit, only : zenith - ! - ! LINOZ +! +! LINOZ +! use lin_strat_chem, only : do_lin_strat_chem, lin_strat_chem_solve use linoz_data, only : has_linoz_data - ! - ! for aqueous chemistry and aerosol growth - use aero_model, only : aero_model_gasaerexch, aero_model_strat_surfarea +! +! for aqueous chemistry and aerosol growth +! + use aero_model, only : aero_model_gasaerexch + + use aero_model, only : aero_model_strat_surfarea implicit none @@ -652,6 +669,7 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & call setinv( invariants, tfld, h2ovmr, vmr, pmid, ncol, lchnk, pbuf ) !----------------------------------------------------------------------- +#if defined (OSLO_AERO) ! ... Set the "day/night cycle for prescribed oxidants" !----------------------------------------------------------------------- @@ -670,6 +688,7 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & call outfld('NO3_aft', invariants(:,:,id_no3), ncol, lchnk) !--IH +#endif ! ... stratosphere aerosol surface area !----------------------------------------------------------------------- if (sad_pbf_ndx>0) then diff --git a/src/physics/cam_oslo/mo_neu_wetdep.F90 b/src/physics/cam_oslo/mo_neu_wetdep.F90 index 5762cb0e71..eae583761a 100644 --- a/src/physics/cam_oslo/mo_neu_wetdep.F90 +++ b/src/physics/cam_oslo/mo_neu_wetdep.F90 @@ -14,15 +14,19 @@ module mo_neu_wetdep use cam_abortutils, only : endrun use seq_drydep_mod, only : n_species_table, species_name_table, dheff use gas_wetdep_opts, only : gas_wetdep_method, gas_wetdep_list, gas_wetdep_cnt +#ifdef OSLO_AERO use phys_control, only: phys_getopts use mo_constants, only: rgrav use phys_control, only: phys_getopts +#endif ! implicit none ! private public :: neu_wetdep_init public :: neu_wetdep_tend +! + save ! integer, allocatable, dimension(:) :: mapping_to_heff,mapping_to_mmr real(r8),allocatable, dimension(:) :: mol_weight @@ -278,8 +282,10 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & real(r8) :: pi real(r8) :: lats(pcols) +#ifdef OSLO_AERO real(r8) :: wrk_wd(pcols) logical history_aerosol +#endif call phys_getopts( history_aerosol_out = history_aerosol) ! @@ -480,6 +486,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & !This is output normally in mo_chm_diags, but !if neu wetdep, we have to output it here! +#ifdef OSLO_AERO if(history_aerosol)then do m=1,gas_wetdep_cnt wrk_wd(:ncol) = 0.0_r8 @@ -491,6 +498,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & call outfld('WD_A_'//trim(gas_wetdep_list(m)),wrk_wd(:ncol),ncol,lchnk) end do end if +#endif ! if ( do_diag ) then call outfld('QT_RAIN_HNO3', qt_rain, ncol, lchnk ) diff --git a/src/physics/cam_oslo/mo_setsox.F90 b/src/physics/cam_oslo/mo_setsox.F90 deleted file mode 100644 index d2c20b8d4d..0000000000 --- a/src/physics/cam_oslo/mo_setsox.F90 +++ /dev/null @@ -1,873 +0,0 @@ -module MO_SETSOX - - use shr_kind_mod, only : r8 => shr_kind_r8 - use cam_logfile, only : iulog - - private - public :: sox_inti, setsox - public :: has_sox - - logical :: inv_o3 - integer :: id_msa - - integer :: id_so2, id_nh3, id_hno3, id_h2o2, id_o3, id_ho2 - integer :: id_so4, id_h2so4 - - logical :: has_sox = .true. - logical :: inv_so2, inv_nh3, inv_hno3, inv_h2o2, inv_ox, inv_nh4no3, inv_ho2 - - logical :: cloud_borne = .false. - logical :: modal_aerosols = .false. - -contains - - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - subroutine sox_inti - !----------------------------------------------------------------------- - ! ... initialize the hetero sox routine - !----------------------------------------------------------------------- - - use mo_chem_utls, only : get_spc_ndx, get_inv_ndx - use spmd_utils, only : masterproc - use phys_control, only : phys_getopts - use sox_cldaero_mod, only : sox_cldaero_init - - call phys_getopts(prog_modal_aero_out=modal_aerosols ) - - cloud_borne = modal_aerosols - - cloud_borne = .TRUE. - modal_aerosols = .TRUE. - - !----------------------------------------------------------------- - ! ... get species indicies - !----------------------------------------------------------------- - - if (cloud_borne) then - id_h2so4 = get_spc_ndx( 'H2SO4' ) - else - id_so4 = get_spc_ndx( 'SO4' ) - endif - id_msa = get_spc_ndx( 'MSA' ) - - inv_so2 = .false. - id_so2 = get_inv_ndx( 'SO2' ) - inv_so2 = id_so2 > 0 - if ( .not. inv_so2 ) then - id_so2 = get_spc_ndx( 'SO2' ) - endif - - inv_NH3 = .false. - id_NH3 = get_inv_ndx( 'NH3' ) - inv_NH3 = id_NH3 > 0 - if ( .not. inv_NH3 ) then - id_NH3 = get_spc_ndx( 'NH3' ) - endif - - inv_HNO3 = .false. - id_HNO3 = get_inv_ndx( 'HNO3' ) - inv_HNO3 = id_hno3 > 0 - if ( .not. inv_HNO3 ) then - id_HNO3 = get_spc_ndx( 'HNO3' ) - endif - - inv_H2O2 = .false. - id_H2O2 = get_inv_ndx( 'H2O2' ) - inv_H2O2 = id_H2O2 > 0 - if ( .not. inv_H2O2 ) then - id_H2O2 = get_spc_ndx( 'H2O2' ) - endif - - inv_HO2 = .false. - id_HO2 = get_inv_ndx( 'HO2' ) - inv_HO2 = id_HO2 > 0 - if ( .not. inv_HO2 ) then - id_HO2 = get_spc_ndx( 'HO2' ) - endif - - inv_o3 = get_inv_ndx( 'O3' ) > 0 - if (inv_o3) then - id_o3 = get_inv_ndx( 'O3' ) - else - id_o3 = get_spc_ndx( 'O3' ) - endif - inv_ho2 = get_inv_ndx( 'HO2' ) > 0 - if (inv_ho2) then - id_ho2 = get_inv_ndx( 'HO2' ) - else - id_ho2 = get_spc_ndx( 'HO2' ) - endif - - has_sox = (id_so2>0) .and. (id_h2o2>0) .and. (id_o3>0) .and. (id_ho2>0) - if (cloud_borne) then - has_sox = has_sox .and. (id_h2so4>0) - else - has_sox = has_sox .and. (id_so4>0) .and. (id_nh3>0) - endif - - if (masterproc) then - write(iulog,*) 'sox_inti: has_sox = ',has_sox - endif - - if( has_sox ) then - if (masterproc) then - write(iulog,*) '-----------------------------------------' - write(iulog,*) 'mozart will do sox aerosols' - write(iulog,*) '-----------------------------------------' - endif - else - return - end if - - call sox_cldaero_init() - - end subroutine sox_inti - - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - subroutine SETSOX( & - ncol, & - lchnk, & - loffset,& - dtime, & - press, & - pdel, & - tfld, & - mbar, & - lwc, & - cldfrc, & - cldnum, & - xhnm, & - invariants, & - qcw, & - qin, & - xphlwc, & - aqso4, & - aqh2so4,& - aqso4_h2o2, & - aqso4_o3, & - yph_in, & - aqso4_h2o2_3d, & - aqso4_o3_3d & - ) - - !----------------------------------------------------------------------- - ! ... Compute heterogeneous reactions of SOX - ! - ! (0) using initial PH to calculate PH - ! (a) HENRYs law constants - ! (b) PARTIONING - ! (c) PH values - ! - ! (1) using new PH to repeat - ! (a) HENRYs law constants - ! (b) PARTIONING - ! (c) REACTION rates - ! (d) PREDICTION - !----------------------------------------------------------------------- - ! - use ppgrid, only : pcols, pver - use chem_mods, only : gas_pcnst, nfs - use chem_mods, only : adv_mass - use physconst, only : mwdry, gravit - use mo_constants, only : pi - use sox_cldaero_mod, only : sox_cldaero_update, sox_cldaero_create_obj, sox_cldaero_destroy_obj - use cldaero_mod, only : cldaero_conc_t - - !----------------------------------------------------------------------- - ! ... Dummy arguments - !----------------------------------------------------------------------- - integer, intent(in) :: ncol ! num of columns in chunk - integer, intent(in) :: lchnk ! chunk id - integer, intent(in) :: loffset ! offset of chem tracers in the advected tracers array - real(r8), intent(in) :: dtime ! time step (sec) - real(r8), intent(in) :: press(:,:) ! midpoint pressure ( Pa ) - real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: tfld(:,:) ! temperature - real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) - real(r8), target, intent(in) :: lwc(:,:) ! cloud liquid water content (kg/kg) - real(r8), target, intent(in) :: cldfrc(:,:) ! cloud fraction - real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) - real(r8), intent(in) :: xhnm(:,:) ! total atms density ( /cm**3) - real(r8), intent(in) :: invariants(:,:,:) - real(r8), target, intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) - real(r8), intent(inout) :: qin(:,:,:) ! transported species ( vmr ) - real(r8), intent(out) :: xphlwc(:,:) ! pH value multiplied by lwc - - real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) - real(r8), intent(in), optional :: yph_in ! ph value - real(r8), intent(out), optional :: aqso4_h2o2_3d(:, :) ! 3D SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out), optional :: aqso4_o3_3d(:, :) ! 3D SO4 aqueous phase chemistry due to O3 (kg/m2) - - - !----------------------------------------------------------------------- - ! ... Local variables - ! - ! xhno3 ... in mixing ratio - !----------------------------------------------------------------------- - integer, parameter :: itermax = 20 - real(r8), parameter :: ph0 = 5.0_r8 ! INITIAL PH VALUES - real(r8), parameter :: const0 = 1.e3_r8/6.023e23_r8 - real(r8), parameter :: xa0 = 11._r8 - real(r8), parameter :: xb0 = -.1_r8 - real(r8), parameter :: xa1 = 1.053_r8 - real(r8), parameter :: xb1 = -4.368_r8 - real(r8), parameter :: xa2 = 1.016_r8 - real(r8), parameter :: xb2 = -2.54_r8 - real(r8), parameter :: xa3 = .816e-32_r8 - real(r8), parameter :: xb3 = .259_r8 - - real(r8), parameter :: kh0 = 9.e3_r8 ! HO2(g) -> Ho2(a) - real(r8), parameter :: kh1 = 2.05e-5_r8 ! HO2(a) -> H+ + O2- - real(r8), parameter :: kh2 = 8.6e5_r8 ! HO2(a) + ho2(a) -> h2o2(a) + o2 - real(r8), parameter :: kh3 = 1.e8_r8 ! HO2(a) + o2- -> h2o2(a) + o2 - real(r8), parameter :: Ra = 8314._r8/101325._r8 ! universal constant (atm)/(M-K) - real(r8), parameter :: xkw = 1.e-14_r8 ! water acidity - - ! - real(r8) :: xdelso4hp(ncol,pver) - - integer :: k, i, iter, file - real(r8) :: wrk, delta - real(r8) :: xph0, aden, xk, xe, x2 - real(r8) :: tz, xl, px, qz, pz, es, qs, patm - real(r8) :: Eso2, Eso4, Ehno3, Eco2, Eh2o, Enh3 - real(r8) :: so2g, h2o2g, co2g, o3g - real(r8) :: hno3a, nh3a, so2a, h2o2a, co2a, o3a - real(r8) :: rah2o2, rao3, pso4, ccc - real(r8) :: cnh3, chno3, com, com1, com2, xra - - real(r8) :: hno3g(ncol,pver), nh3g(ncol,pver) - ! - !----------------------------------------------------------------------- - ! for Ho2(g) -> H2o2(a) formation - ! schwartz JGR, 1984, 11589 - !----------------------------------------------------------------------- - real(r8) :: kh4 ! kh2+kh3 - real(r8) :: xam ! air density /cm3 - real(r8) :: ho2s ! ho2s = ho2(a)+o2- - real(r8) :: r1h2o2 ! prod(h2o2) by ho2 in mole/L(w)/s - real(r8) :: r2h2o2 ! prod(h2o2) by ho2 in mix/s - - real(r8), dimension(ncol,pver) :: & - xhno3, xh2o2, xso2, xso4, xno3, & - xnh3, xnh4, xo3, & - cfact, & - xph, xho2, & - xh2so4, xmsa, xso4_init, & - hehno3, & ! henry law const for hno3 - heh2o2, & ! henry law const for h2o2 - heso2, & ! henry law const for so2 - henh3, & ! henry law const for nh3 - heo3 !!, & ! henry law const for o3 - - real(r8) :: patm_x - - real(r8), dimension(ncol) :: work1 - logical :: converged - - real(r8), pointer :: xso4c(:,:) - real(r8), pointer :: xnh4c(:,:) - real(r8), pointer :: xno3c(:,:) - type(cldaero_conc_t), pointer :: cldconc - - real(r8) :: fact1_hno3, fact2_hno3, fact3_hno3 - real(r8) :: fact1_so2, fact2_so2, fact3_so2, fact4_so2 - real(r8) :: fact1_nh3, fact2_nh3, fact3_nh3 - real(r8) :: tmp_hp, tmp_hso3, tmp_hco3, tmp_nh4, tmp_no3 - real(r8) :: tmp_oh, tmp_so3, tmp_so4 - real(r8) :: tmp_neg, tmp_pos - real(r8) :: yph, yph_lo, yph_hi - real(r8) :: ynetpos, ynetpos_lo, ynetpos_hi - - !----------------------------------------------------------------- - ! ... NOTE: The press array is in pascals and must be - ! mutiplied by 10 to yield dynes/cm**2. - !----------------------------------------------------------------- - !================================================================== - ! ... First set the PH - !================================================================== - ! ... Initial values - ! The values of so2, so4 are after (1) SLT, and CHEM - !----------------------------------------------------------------- - xph0 = 10._r8**(-ph0) ! initial PH value - - do k = 1,pver - cfact(:,k) = xhnm(:,k) & ! /cm3(a) - * 1.e6_r8 & ! /m3(a) - * 1.38e-23_r8/287._r8 & ! Kg(a)/m3(a) - * 1.e-3_r8 ! Kg(a)/L(a) - end do - - cldconc => sox_cldaero_create_obj( cldfrc,qcw,lwc, cfact, ncol, loffset ) - xso4c => cldconc%so4c - xnh4c => cldconc%nh4c - xno3c => cldconc%no3c - - xso4(:,:) = 0._r8 - xno3(:,:) = 0._r8 - xnh4(:,:) = 0._r8 - - do k = 1,pver - xph(:,k) = xph0 ! initial PH value - - if ( inv_so2 ) then - xso2 (:,k) = invariants(:,k,id_so2)/xhnm(:,k) ! mixing ratio - else - xso2 (:,k) = qin(:,k,id_so2) ! mixing ratio - endif - - if (id_hno3 > 0) then - xhno3(:,k) = qin(:,k,id_hno3) - else - xhno3(:,k) = 0.0_r8 - endif - - if ( inv_h2o2 ) then - xh2o2 (:,k) = invariants(:,k,id_h2o2)/xhnm(:,k) ! mixing ratio - else - xh2o2 (:,k) = qin(:,k,id_h2o2) ! mixing ratio - endif - - if (id_nh3 > 0) then - xnh3 (:,k) = qin(:,k,id_nh3) - else - xnh3 (:,k) = 0.0_r8 - endif - - if ( inv_o3 ) then - xo3 (:,k) = invariants(:,k,id_o3)/xhnm(:,k) ! mixing ratio - else - xo3 (:,k) = qin(:,k,id_o3) ! mixing ratio - endif - if ( inv_ho2 ) then - xho2 (:,k) = invariants(:,k,id_ho2)/xhnm(:,k)! mixing ratio - else - xho2 (:,k) = qin(:,k,id_ho2) ! mixing ratio - endif - - if (cloud_borne) then - xh2so4(:,k) = qin(:,k,id_h2so4) - else - xso4 (:,k) = qin(:,k,id_so4) ! mixing ratio - endif - if (id_msa > 0) xmsa (:,k) = qin(:,k,id_msa) - - end do - - !----------------------------------------------------------------- - ! ... Temperature dependent Henry constants - !----------------------------------------------------------------- - ver_loop0: do k = 1,pver !! pver loop for STEP 0 - col_loop0: do i = 1,ncol - - if (cloud_borne .and. cldfrc(i,k)>0._r8) then - xso4(i,k) = xso4c(i,k) / cldfrc(i,k) - xnh4(i,k) = xnh4c(i,k) / cldfrc(i,k) - xno3(i,k) = xno3c(i,k) / cldfrc(i,k) - endif - xl = cldconc%xlwc(i,k) - - if( xl >= 1.e-8_r8 ) then - work1(i) = 1._r8 / tfld(i,k) - 1._r8 / 298._r8 - - !----------------------------------------------------------------- - ! 21-mar-2011 changes by rce - ! ph calculation now uses bisection method to solve the electro-neutrality equation - ! 3-mode aerosols (where so4 is assumed to be nh4hso4) - ! old code set xnh4c = so4c - ! new code sets xnh4c = 0, then uses a -1 charge (instead of -2) - ! for so4 when solving the electro-neutrality equation - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! calculations done before iterating - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - pz = .01_r8*press(i,k) !! pressure in mb - tz = tfld(i,k) - patm = pz/1013._r8 - xam = press(i,k)/(1.38e-23_r8*tz) !air density /M3 - - !----------------------------------------------------------------- - ! ... hno3 - !----------------------------------------------------------------- - ! previous code - ! hehno3(i,k) = xk*(1._r8 + xe/xph(i,k)) - ! px = hehno3(i,k) * Ra * tz * xl - ! hno3g = xhno3(i,k)/(1._r8 + px) - ! Ehno3 = xk*xe*hno3g *patm - ! equivalent new code - ! hehno3 = xk + xk*xe/hplus - ! hno3g = xhno3/(1 + px) - ! = xhno3/(1 + hehno3*ra*tz*xl) - ! = xhno3/(1 + xk*ra*tz*xl*(1 + xe/hplus) - ! ehno3 = hno3g*xk*xe*patm - ! = xk*xe*patm*xhno3/(1 + xk*ra*tz*xl*(1 + xe/hplus) - ! = ( fact1_hno3 )/(1 + fact2_hno3 *(1 + fact3_hno3/hplus) - ! [hno3-] = ehno3/hplus - xk = 2.1e5_r8 *EXP( 8700._r8*work1(i) ) - xe = 15.4_r8 - fact1_hno3 = xk*xe*patm*xhno3(i,k) - fact2_hno3 = xk*ra*tz*xl - fact3_hno3 = xe - - !----------------------------------------------------------------- - ! ... so2 - !----------------------------------------------------------------- - ! previous code - ! heso2(i,k) = xk*(1._r8 + wrk*(1._r8 + x2/xph(i,k))) - ! px = heso2(i,k) * Ra * tz * xl - ! so2g = xso2(i,k)/(1._r8+ px) - ! Eso2 = xk*xe*so2g *patm - ! equivalent new code - ! heso2 = xk + xk*xe/hplus * xk*xe*x2/hplus**2 - ! so2g = xso2/(1 + px) - ! = xso2/(1 + heso2*ra*tz*xl) - ! = xso2/(1 + xk*ra*tz*xl*(1 + (xe/hplus)*(1 + x2/hplus)) - ! eso2 = so2g*xk*xe*patm - ! = xk*xe*patm*xso2/(1 + xk*ra*tz*xl*(1 + (xe/hplus)*(1 + x2/hplus)) - ! = ( fact1_so2 )/(1 + fact2_so2 *(1 + (fact3_so2/hplus)*(1 + fact4_so2/hplus) - ! [hso3-] + 2*[so3--] = (eso2/hplus)*(1 + 2*x2/hplus) - xk = 1.23_r8 *EXP( 3120._r8*work1(i) ) - xe = 1.7e-2_r8*EXP( 2090._r8*work1(i) ) - x2 = 6.0e-8_r8*EXP( 1120._r8*work1(i) ) - fact1_so2 = xk*xe*patm*xso2(i,k) - fact2_so2 = xk*ra*tz*xl - fact3_so2 = xe - fact4_so2 = x2 - - !----------------------------------------------------------------- - ! ... nh3 - !----------------------------------------------------------------- - ! previous code - ! henh3(i,k) = xk*(1._r8 + xe*xph(i,k)/xkw) - ! px = henh3(i,k) * Ra * tz * xl - ! nh3g = (xnh3(i,k)+xnh4(i,k))/(1._r8+ px) - ! Enh3 = xk*xe*nh3g/xkw *patm - ! equivalent new code - ! henh3 = xk + xk*xe*hplus/xkw - ! nh3g = xnh34/(1 + px) - ! = xnh34/(1 + henh3*ra*tz*xl) - ! = xnh34/(1 + xk*ra*tz*xl*(1 + xe*hplus/xkw) - ! enh3 = nh3g*xk*xe*patm/xkw - ! = ((xk*xe*patm/xkw)*xnh34)/(1 + xk*ra*tz*xl*(1 + xe*hplus/xkw) - ! = ( fact1_nh3 )/(1 + fact2_nh3 *(1 + fact3_nh3*hplus) - ! [nh4+] = enh3*hplus - xk = 58._r8 *EXP( 4085._r8*work1(i) ) - xe = 1.7e-5_r8*EXP( -4325._r8*work1(i) ) - - fact1_nh3 = (xk*xe*patm/xkw)*(xnh3(i,k)+xnh4(i,k)) - fact2_nh3 = xk*ra*tz*xl - fact3_nh3 = xe/xkw - - !----------------------------------------------------------------- - ! ... h2o effects - !----------------------------------------------------------------- - Eh2o = xkw - - !----------------------------------------------------------------- - ! ... co2 effects - !----------------------------------------------------------------- - co2g = 330.e-6_r8 !330 ppm = 330.e-6 atm - xk = 3.1e-2_r8*EXP( 2423._r8*work1(i) ) - xe = 4.3e-7_r8*EXP(-913._r8 *work1(i) ) - Eco2 = xk*xe*co2g *patm - - !----------------------------------------------------------------- - ! ... so4 effect - !----------------------------------------------------------------- - Eso4 = xso4(i,k)*xhnm(i,k) & ! /cm3(a) - *const0/xl - - - !----------------------------------------------------------------- - ! now use bisection method to solve electro-neutrality equation - ! - ! during the iteration loop, - ! yph_lo = lower ph value that brackets the root (i.e., correct ph) - ! yph_hi = upper ph value that brackets the root (i.e., correct ph) - ! yph = current ph value - ! yposnet_lo and yposnet_hi = net positive ions for - ! yph_lo and yph_hi - !----------------------------------------------------------------- - do iter = 1,itermax - - if (.not. present(yph_in)) then - if (iter == 1) then - ! 1st iteration ph = lower bound value - yph_lo = 2.0_r8 - yph_hi = yph_lo - yph = yph_lo - else if (iter == 2) then - ! 2nd iteration ph = upper bound value - yph_hi = 7.0_r8 - yph = yph_hi - else - ! later iteration ph = mean of the two bracketing values - yph = 0.5_r8*(yph_lo + yph_hi) - end if - else - yph = yph_in - end if - - ! calc current [H+] from ph - xph(i,k) = 10.0_r8**(-yph) - - - !----------------------------------------------------------------- - ! ... hno3 - !----------------------------------------------------------------- - Ehno3 = fact1_hno3/(1.0_r8 + fact2_hno3*(1.0_r8 + fact3_hno3/xph(i,k))) - - !----------------------------------------------------------------- - ! ... so2 - !----------------------------------------------------------------- - Eso2 = fact1_so2/(1.0_r8 + fact2_so2*(1.0_r8 + (fact3_so2/xph(i,k)) & - *(1.0_r8 + fact4_so2/xph(i,k)))) - - !----------------------------------------------------------------- - ! ... nh3 - !----------------------------------------------------------------- - Enh3 = fact1_nh3/(1.0_r8 + fact2_nh3*(1.0_r8 + fact3_nh3*xph(i,k))) - - tmp_nh4 = Enh3 * xph(i,k) - tmp_hso3 = Eso2 / xph(i,k) - tmp_so3 = tmp_hso3 * 2.0_r8*fact4_so2/xph(i,k) - tmp_hco3 = Eco2 / xph(i,k) - tmp_oh = Eh2o / xph(i,k) - tmp_no3 = Ehno3 / xph(i,k) - tmp_so4 = cldconc%so4_fact*Eso4 - tmp_pos = xph(i,k) + tmp_nh4 - tmp_neg = tmp_oh + tmp_hco3 + tmp_no3 + tmp_hso3 + tmp_so3 + tmp_so4 - - ynetpos = tmp_pos - tmp_neg - - - ! yposnet = net positive ions/charge - ! if the correct ph is bracketed by yph_lo and yph_hi (with yph_lo < yph_hi), - ! then you will have yposnet_lo > 0 and yposnet_hi < 0 - converged = .false. - if (iter > 2) then - if (ynetpos == 0.0_r8) then - ! the exact solution was found (very unlikely) - tmp_hp = xph(i,k) - converged = .true. - exit - else if (ynetpos >= 0.0_r8) then - ! net positive ions are >= 0 for both yph and yph_lo - ! so replace yph_lo with yph - yph_lo = yph - ynetpos_lo = ynetpos - else - ! net positive ions are <= 0 for both yph and yph_hi - ! so replace yph_hi with yph - yph_hi = yph - ynetpos_hi = ynetpos - end if - - if (abs(yph_hi - yph_lo) .le. 0.005_r8) then - ! |yph_hi - yph_lo| <= convergence criterion, so set - ! final ph to their midpoint and exit - ! (.005 absolute error in pH gives .01 relative error in H+) - tmp_hp = xph(i,k) - yph = 0.5_r8*(yph_hi + yph_lo) - xph(i,k) = 10.0_r8**(-yph) - converged = .true. - exit - else - ! do another iteration - converged = .false. - end if - - else if (iter == 1) then - if (ynetpos <= 0.0_r8) then - ! the lower and upper bound ph values (2.0 and 7.0) do not bracket - ! the correct ph, so use the lower bound - tmp_hp = xph(i,k) - converged = .true. - exit - end if - ynetpos_lo = ynetpos - - else ! (iter == 2) - if (ynetpos >= 0.0_r8) then - ! the lower and upper bound ph values (2.0 and 7.0) do not bracket - ! the correct ph, so use they upper bound - tmp_hp = xph(i,k) - converged = .true. - exit - end if - ynetpos_hi = ynetpos - end if - - end do ! iter - - if( .not. converged ) then - write(iulog,*) 'SETSOX: pH failed to converge @ (',i,',',k,'), % change=', & - 100._r8*delta - end if - else - xph(i,k) = 1.e-7_r8 - end if - end do col_loop0 - end do ver_loop0 ! end pver loop for STEP 0 - - !============================================================== - ! ... Now use the actual PH - !============================================================== - ver_loop1: do k = 1,pver - col_loop1: do i = 1,ncol - work1(i) = 1._r8 / tfld(i,k) - 1._r8 / 298._r8 - tz = tfld(i,k) - - xl = cldconc%xlwc(i,k) - - patm = press(i,k)/101300._r8 ! press is in pascal - xam = press(i,k)/(1.38e-23_r8*tz) ! air density /M3 - - !----------------------------------------------------------------------- - ! ... hno3 - !----------------------------------------------------------------------- - xk = 2.1e5_r8 *EXP( 8700._r8*work1(i) ) - xe = 15.4_r8 - hehno3(i,k) = xk*(1._r8 + xe/xph(i,k)) - - !----------------------------------------------------------------- - ! ... h2o2 - !----------------------------------------------------------------- - xk = 7.4e4_r8 *EXP( 6621._r8*work1(i) ) - xe = 2.2e-12_r8 *EXP(-3730._r8*work1(i) ) - heh2o2(i,k) = xk*(1._r8 + xe/xph(i,k)) - - !----------------------------------------------------------------- - ! ... so2 - !----------------------------------------------------------------- - xk = 1.23_r8 *EXP( 3120._r8*work1(i) ) - xe = 1.7e-2_r8*EXP( 2090._r8*work1(i) ) - x2 = 6.0e-8_r8*EXP( 1120._r8*work1(i) ) - - wrk = xe/xph(i,k) - heso2(i,k) = xk*(1._r8 + wrk*(1._r8 + x2/xph(i,k))) - - !----------------------------------------------------------------- - ! ... nh3 - !----------------------------------------------------------------- - xk = 58._r8 *EXP( 4085._r8*work1(i) ) - xe = 1.7e-5_r8*EXP(-4325._r8*work1(i) ) - henh3(i,k) = xk*(1._r8 + xe*xph(i,k)/xkw) - - !----------------------------------------------------------------- - ! ... o3 - !----------------------------------------------------------------- - xk = 1.15e-2_r8 *EXP( 2560._r8*work1(i) ) - heo3(i,k) = xk - - !------------------------------------------------------------------------ - ! ... for Ho2(g) -> H2o2(a) formation - ! schwartz JGR, 1984, 11589 - !------------------------------------------------------------------------ - kh4 = (kh2 + kh3*kh1/xph(i,k)) / ((1._r8 + kh1/xph(i,k))**2) - ho2s = kh0*xho2(i,k)*patm*(1._r8 + kh1/xph(i,k)) ! ho2s = ho2(a)+o2- - r1h2o2 = kh4*ho2s*ho2s ! prod(h2o2) in mole/L(w)/s - - if ( cloud_borne ) then - r2h2o2 = r1h2o2*xl & ! mole/L(w)/s * L(w)/fm3(a) = mole/fm3(a)/s - / const0*1.e+6_r8 & ! correct a bug here ???? - / xam - else - r2h2o2 = r1h2o2*xl & ! mole/L(w)/s * L(w)/fm3(a) = mole/fm3(a)/s - * const0 & ! mole/fm3(a)/s * 1.e-3 = mole/cm3(a)/s - / xam ! /cm3(a)/s / air-den = mix-ratio/s - endif - - if ( .not. modal_aerosols ) then - xh2o2(i,k) = xh2o2(i,k) + r2h2o2*dtime ! updated h2o2 by het production - endif - - !----------------------------------------------- - ! ... Partioning - !----------------------------------------------- - - !----------------------------------------------------------------- - ! ... hno3 - !----------------------------------------------------------------- - px = hehno3(i,k) * Ra * tz * xl - hno3g(i,k) = (xhno3(i,k)+xno3(i,k))/(1._r8 + px) - - !------------------------------------------------------------------------ - ! ... h2o2 - !------------------------------------------------------------------------ - px = heh2o2(i,k) * Ra * tz * xl - h2o2g = xh2o2(i,k)/(1._r8+ px) - - !------------------------------------------------------------------------ - ! ... so2 - !------------------------------------------------------------------------ - px = heso2(i,k) * Ra * tz * xl - so2g = xso2(i,k)/(1._r8+ px) - - !------------------------------------------------------------------------ - ! ... o3 - !------------------------------------------------------------------------ - px = heo3(i,k) * Ra * tz * xl - o3g = xo3(i,k)/(1._r8+ px) - - !------------------------------------------------------------------------ - ! ... nh3 - !------------------------------------------------------------------------ - px = henh3(i,k) * Ra * tz * xl - if (id_nh3>0) then - nh3g(i,k) = (xnh3(i,k)+xnh4(i,k))/(1._r8+ px) - else - nh3g(i,k) = 0._r8 - endif - - !----------------------------------------------- - ! ... Aqueous phase reaction rates - ! SO2 + H2O2 -> SO4 - ! SO2 + O3 -> SO4 - !----------------------------------------------- - - !------------------------------------------------------------------------ - ! ... S(IV) (HSO3) + H2O2 - !------------------------------------------------------------------------ - rah2o2 = 8.e4_r8 * EXP( -3650._r8*work1(i) ) & - / (.1_r8 + xph(i,k)) - - !------------------------------------------------------------------------ - ! ... S(IV)+ O3 - !------------------------------------------------------------------------ - rao3 = 4.39e11_r8 * EXP(-4131._r8/tz) & - + 2.56e3_r8 * EXP(-996._r8 /tz) /xph(i,k) - - !----------------------------------------------------------------- - ! ... Prediction after aqueous phase - ! so4 - ! When Cloud is present - ! - ! S(IV) + H2O2 = S(VI) - ! S(IV) + O3 = S(VI) - ! - ! reference: - ! (1) Seinfeld - ! (2) Benkovitz - !----------------------------------------------------------------- - - !............................ - ! S(IV) + H2O2 = S(VI) - !............................ - - IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED - - if (cloud_borne) then - patm_x = patm - else - patm_x = 1._r8 - endif - - if (modal_aerosols) then - - pso4 = rah2o2 * 7.4e4_r8*EXP(6621._r8*work1(i)) * h2o2g * patm_x & - * 1.23_r8 *EXP(3120._r8*work1(i)) * so2g * patm_x - else - pso4 = rah2o2 * heh2o2(i,k) * h2o2g * patm_x & - * heso2(i,k) * so2g * patm_x ! [M/s] - - endif - - pso4 = pso4 & ! [M/s] = [mole/L(w)/s] - * xl & ! [mole/L(a)/s] - / const0 & ! [/L(a)/s] - / xhnm(i,k) - - - ccc = pso4*dtime - ccc = max(ccc, 1.e-30_r8) - - xso4_init(i,k)=xso4(i,k) - - IF (xh2o2(i,k) .gt. xso2(i,k)) THEN - if (ccc .gt. xso2(i,k)) then - xso4(i,k)=xso4(i,k)+xso2(i,k) - if (cloud_borne) then - xh2o2(i,k)=xh2o2(i,k)-xso2(i,k) - xso2(i,k)=1.e-20_r8 - else ! ???? bug ???? - xso2(i,k)=1.e-20_r8 - xh2o2(i,k)=xh2o2(i,k)-xso2(i,k) - endif - else - xso4(i,k) = xso4(i,k) + ccc - xh2o2(i,k) = xh2o2(i,k) - ccc - xso2(i,k) = xso2(i,k) - ccc - end if - - ELSE - if (ccc .gt. xh2o2(i,k)) then - xso4(i,k)=xso4(i,k)+xh2o2(i,k) - xso2(i,k)=xso2(i,k)-xh2o2(i,k) - xh2o2(i,k)=1.e-20_r8 - else - xso4(i,k) = xso4(i,k) + ccc - xh2o2(i,k) = xh2o2(i,k) - ccc - xso2(i,k) = xso2(i,k) - ccc - end if - END IF - - if (modal_aerosols) then - xdelso4hp(i,k) = xso4(i,k) - xso4_init(i,k) - endif - !........................... - ! S(IV) + O3 = S(VI) - !........................... - - pso4 = rao3 * heo3(i,k)*o3g*patm_x * heso2(i,k)*so2g*patm_x ! [M/s] - - pso4 = pso4 & ! [M/s] = [mole/L(w)/s] - * xl & ! [mole/L(a)/s] - / const0 & ! [/L(a)/s] - / xhnm(i,k) ! [mixing ratio/s] - - ccc = pso4*dtime - ccc = max(ccc, 1.e-30_r8) - - xso4_init(i,k)=xso4(i,k) - - if (ccc .gt. xso2(i,k)) then - xso4(i,k) = xso4(i,k) + xso2(i,k) - xso2(i,k) = 1.e-20_r8 - else - xso4(i,k) = xso4(i,k) + ccc - xso2(i,k) = xso2(i,k) - ccc - end if - - END IF !! WHEN CLOUD IS PRESENTED - - end do col_loop1 - end do ver_loop1 - - call sox_cldaero_update( & - ncol, lchnk, loffset, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, cldconc%xlwc, & - xdelso4hp, xh2so4, xso4, xso4_init, nh3g, hno3g, xnh3, xhno3, xnh4c, xno3c, xmsa, xso2, xh2o2, qcw, qin, & - aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d=aqso4_h2o2_3d, aqso4_o3_3d=aqso4_o3_3d ) - - xphlwc(:,:) = 0._r8 - do k = 1, pver - do i = 1, ncol - if (cldfrc(i,k)>=1.e-5_r8 .and. lwc(i,k)>=1.e-8_r8) then - xphlwc(i,k) = -1._r8*log10(xph(i,k)) * lwc(i,k) - endif - end do - end do - - call sox_cldaero_destroy_obj(cldconc) - - end subroutine SETSOX - -end module MO_SETSOX diff --git a/src/physics/cam_oslo/mo_usrrxt.F90 b/src/physics/cam_oslo/mo_usrrxt.F90 deleted file mode 100644 index ea1c1ef559..0000000000 --- a/src/physics/cam_oslo/mo_usrrxt.F90 +++ /dev/null @@ -1,1569 +0,0 @@ -module mo_usrrxt - - use shr_kind_mod, only : r8 => shr_kind_r8 - use cam_logfile, only : iulog - use ppgrid, only : pver, pcols - use commondefinitions, only: nmodes_oslo=> nmodes - - implicit none - - private - public :: usrrxt, usrrxt_inti, usrrxt_hrates - - integer :: usr_O_O2_ndx - integer :: usr_HO2_HO2_ndx - integer :: usr_N2O5_M_ndx - integer :: usr_HNO3_OH_ndx - integer :: usr_HO2NO2_M_ndx - integer :: usr_N2O5_aer_ndx - integer :: usr_NO3_aer_ndx - integer :: usr_NO2_aer_ndx - integer :: usr_CO_OH_a_ndx - integer :: usr_CO_OH_b_ndx - integer :: usr_PAN_M_ndx - integer :: usr_CH3COCH3_OH_ndx - integer :: usr_MCO3_NO2_ndx - integer :: usr_MPAN_M_ndx - integer :: usr_XOOH_OH_ndx - integer :: usr_SO2_OH_ndx - integer :: usr_DMS_OH_ndx - integer :: usr_HO2_aer_ndx - integer :: usr_GLYOXAL_aer_ndx - - integer :: tag_NO2_NO3_ndx - integer :: tag_NO2_OH_ndx - integer :: tag_NO2_HO2_ndx - integer :: tag_C2H4_OH_ndx - integer :: tag_C3H6_OH_ndx - integer :: tag_CH3CO3_NO2_ndx - -!lke-TS1 - integer :: usr_PBZNIT_M_ndx - integer :: tag_ACBZO2_NO2_ndx - integer :: usr_ISOPNITA_aer_ndx - integer :: usr_ISOPNITB_aer_ndx - integer :: usr_ONITR_aer_ndx - integer :: usr_HONITR_aer_ndx - integer :: usr_TERPNIT_aer_ndx - integer :: usr_NTERPOOH_aer_ndx - integer :: usr_NC4CHO_aer_ndx - integer :: usr_NC4CH2OH_aer_ndx -! - integer :: usr_OA_O2_NDX - integer :: usr_XNO2NO3_M_ndx - integer :: usr_NO2XNO3_M_ndx - integer :: usr_XHNO3_OH_ndx - integer :: usr_XHO2NO2_M_ndx - integer :: usr_XNO2NO3_aer_ndx - integer :: usr_NO2XNO3_aer_ndx - integer :: usr_XNO3_aer_ndx - integer :: usr_XNO2_aer_ndx - integer :: usr_XPAN_M_ndx - integer :: usr_XMPAN_M_ndx - integer :: usr_MCO3_XNO2_ndx - - integer :: usr_C2O3_NO2_ndx - integer :: usr_C2H4_OH_ndx - integer :: usr_XO2N_HO2_ndx - integer :: usr_C2O3_XNO2_ndx - - integer :: tag_XO2N_NO_ndx - integer :: tag_XO2_HO2_ndx - integer :: tag_XO2_NO_ndx - - integer :: usr_O_O_ndx - integer :: usr_CL2O2_M_ndx - integer :: usr_SO3_H2O_ndx - integer :: tag_CLO_CLO_M_ndx - - integer :: ion1_ndx, ion2_ndx, ion3_ndx, ion11_ndx - integer :: elec1_ndx, elec2_ndx, elec3_ndx - integer :: elec4_ndx, elec5_ndx, elec6_ndx - integer :: het1_ndx - - integer, parameter :: nean = 3 - integer :: ean_ndx(nean) - integer, parameter :: nrpe = 5 - integer :: rpe_ndx(nrpe) - integer, parameter :: npir = 16 - integer :: pir_ndx(npir) - integer, parameter :: nedn = 2 - integer :: edn_ndx(nedn) - integer, parameter :: nnir = 13 - integer :: nir_ndx(nnir) - integer, parameter :: niira = 112 - integer :: iira_ndx(niira) - integer, parameter :: niirb = 14 - integer :: iirb_ndx(niirb) - - integer :: usr_clm_h2o_m_ndx, usr_clm_hcl_m_ndx - integer :: usr_oh_co_ndx, het_no2_h2o_ndx, usr_oh_dms_ndx, aq_so2_h2o2_ndx, aq_so2_o3_ndx - - integer :: h2o_ndx -! -! jfl -! - integer, parameter :: num_strat_tau = 22 - integer :: usr_strat_tau_ndx(num_strat_tau) -! -!lke++ - integer :: usr_COhc_OH_ndx - integer :: usr_COme_OH_ndx - integer :: usr_CO01_OH_ndx - integer :: usr_CO02_OH_ndx - integer :: usr_CO03_OH_ndx - integer :: usr_CO04_OH_ndx - integer :: usr_CO05_OH_ndx - integer :: usr_CO06_OH_ndx - integer :: usr_CO07_OH_ndx - integer :: usr_CO08_OH_ndx - integer :: usr_CO09_OH_ndx - integer :: usr_CO10_OH_ndx - integer :: usr_CO11_OH_ndx - integer :: usr_CO12_OH_ndx - integer :: usr_CO13_OH_ndx - integer :: usr_CO14_OH_ndx - integer :: usr_CO15_OH_ndx - integer :: usr_CO16_OH_ndx - integer :: usr_CO17_OH_ndx - integer :: usr_CO18_OH_ndx - integer :: usr_CO19_OH_ndx - integer :: usr_CO20_OH_ndx - integer :: usr_CO21_OH_ndx - integer :: usr_CO22_OH_ndx - integer :: usr_CO23_OH_ndx - integer :: usr_CO24_OH_ndx - integer :: usr_CO25_OH_ndx - integer :: usr_CO26_OH_ndx - integer :: usr_CO27_OH_ndx - integer :: usr_CO28_OH_ndx - integer :: usr_CO29_OH_ndx - integer :: usr_CO30_OH_ndx - integer :: usr_CO31_OH_ndx - integer :: usr_CO32_OH_ndx - integer :: usr_CO33_OH_ndx - integer :: usr_CO34_OH_ndx - integer :: usr_CO35_OH_ndx - integer :: usr_CO36_OH_ndx - integer :: usr_CO37_OH_ndx - integer :: usr_CO38_OH_ndx - integer :: usr_CO39_OH_ndx - integer :: usr_CO40_OH_ndx - integer :: usr_CO41_OH_ndx - integer :: usr_CO42_OH_ndx -!lke-- - - real(r8), parameter :: t0 = 300._r8 ! K - real(r8), parameter :: trlim2 = 17._r8/3._r8 ! K - real(r8), parameter :: trlim3 = 15._r8/3._r8 ! K - - logical :: has_ion_rxts, has_d_chem - -contains - - subroutine usrrxt_inti - !----------------------------------------------------------------- - ! ... intialize the user reaction constants module - !----------------------------------------------------------------- - - use mo_chem_utls, only : get_rxt_ndx, get_spc_ndx - use spmd_utils, only : masterproc - - implicit none - - character(len=4) :: xchar - character(len=32) :: rxtname - integer :: i - -! -! full tropospheric chemistry -! - usr_O_O2_ndx = get_rxt_ndx( 'usr_O_O2' ) - usr_HO2_HO2_ndx = get_rxt_ndx( 'usr_HO2_HO2' ) - usr_N2O5_M_ndx = get_rxt_ndx( 'usr_N2O5_M' ) - usr_HNO3_OH_ndx = get_rxt_ndx( 'usr_HNO3_OH' ) - usr_HO2NO2_M_ndx = get_rxt_ndx( 'usr_HO2NO2_M' ) - usr_N2O5_aer_ndx = get_rxt_ndx( 'usr_N2O5_aer' ) - usr_NO3_aer_ndx = get_rxt_ndx( 'usr_NO3_aer' ) - usr_NO2_aer_ndx = get_rxt_ndx( 'usr_NO2_aer' ) - usr_CO_OH_a_ndx = get_rxt_ndx( 'usr_CO_OH_a' ) - usr_CO_OH_b_ndx = get_rxt_ndx( 'usr_CO_OH_b' ) - usr_PAN_M_ndx = get_rxt_ndx( 'usr_PAN_M' ) - usr_CH3COCH3_OH_ndx = get_rxt_ndx( 'usr_CH3COCH3_OH' ) - usr_MCO3_NO2_ndx = get_rxt_ndx( 'usr_MCO3_NO2' ) - usr_MPAN_M_ndx = get_rxt_ndx( 'usr_MPAN_M' ) - usr_XOOH_OH_ndx = get_rxt_ndx( 'usr_XOOH_OH' ) - usr_SO2_OH_ndx = get_rxt_ndx( 'usr_SO2_OH' ) - usr_DMS_OH_ndx = get_rxt_ndx( 'usr_DMS_OH' ) - usr_HO2_aer_ndx = get_rxt_ndx( 'usr_HO2_aer' ) - usr_GLYOXAL_aer_ndx = get_rxt_ndx( 'usr_GLYOXAL_aer' ) - ! - tag_NO2_NO3_ndx = get_rxt_ndx( 'tag_NO2_NO3' ) - tag_NO2_OH_ndx = get_rxt_ndx( 'tag_NO2_OH' ) - tag_NO2_HO2_ndx = get_rxt_ndx( 'tag_NO2_HO2' ) - tag_C2H4_OH_ndx = get_rxt_ndx( 'tag_C2H4_OH' ) - tag_C3H6_OH_ndx = get_rxt_ndx( 'tag_C3H6_OH' ) - tag_CH3CO3_NO2_ndx = get_rxt_ndx( 'tag_CH3CO3_NO2' ) -!lke-TS1 - usr_PBZNIT_M_ndx = get_rxt_ndx( 'usr_PBZNIT_M' ) - tag_ACBZO2_NO2_ndx = get_rxt_ndx( 'tag_ACBZO2_NO2' ) - usr_ISOPNITA_aer_ndx = get_rxt_ndx( 'usr_ISOPNITA_aer' ) - usr_ISOPNITB_aer_ndx = get_rxt_ndx( 'usr_ISOPNITB_aer' ) - usr_ONITR_aer_ndx = get_rxt_ndx( 'usr_ONITR_aer' ) - usr_HONITR_aer_ndx = get_rxt_ndx( 'usr_HONITR_aer' ) - usr_TERPNIT_aer_ndx = get_rxt_ndx( 'usr_TERPNIT_aer' ) - usr_NTERPOOH_aer_ndx = get_rxt_ndx( 'usr_NTERPOOH_aer' ) - usr_NC4CHO_aer_ndx = get_rxt_ndx( 'usr_NC4CHO_aer' ) - usr_NC4CH2OH_aer_ndx = get_rxt_ndx( 'usr_NC4CH2OH_aer' ) - ! - ! additional reactions for O3A/XNO - ! - usr_OA_O2_ndx = get_rxt_ndx( 'usr_OA_O2' ) - usr_XNO2NO3_M_ndx = get_rxt_ndx( 'usr_XNO2NO3_M' ) - usr_NO2XNO3_M_ndx = get_rxt_ndx( 'usr_NO2XNO3_M' ) - usr_XNO2NO3_aer_ndx = get_rxt_ndx( 'usr_XNO2NO3_aer' ) - usr_NO2XNO3_aer_ndx = get_rxt_ndx( 'usr_NO2XNO3_aer' ) - usr_XHNO3_OH_ndx = get_rxt_ndx( 'usr_XHNO3_OH' ) - usr_XNO3_aer_ndx = get_rxt_ndx( 'usr_XNO3_aer' ) - usr_XNO2_aer_ndx = get_rxt_ndx( 'usr_XNO2_aer' ) - usr_MCO3_XNO2_ndx = get_rxt_ndx( 'usr_MCO3_XNO2' ) - usr_XPAN_M_ndx = get_rxt_ndx( 'usr_XPAN_M' ) - usr_XMPAN_M_ndx = get_rxt_ndx( 'usr_XMPAN_M' ) - usr_XHO2NO2_M_ndx = get_rxt_ndx( 'usr_XHO2NO2_M' ) -! -! reduced hydrocarbon chemistry -! - usr_C2O3_NO2_ndx = get_rxt_ndx( 'usr_C2O3_NO2' ) - usr_C2H4_OH_ndx = get_rxt_ndx( 'usr_C2H4_OH' ) - usr_XO2N_HO2_ndx = get_rxt_ndx( 'usr_XO2N_HO2' ) - usr_C2O3_XNO2_ndx = get_rxt_ndx( 'usr_C2O3_XNO2' ) -! - tag_XO2N_NO_ndx = get_rxt_ndx( 'tag_XO2N_NO' ) - tag_XO2_HO2_ndx = get_rxt_ndx( 'tag_XO2_HO2' ) - tag_XO2_NO_ndx = get_rxt_ndx( 'tag_XO2_NO' ) -! -! stratospheric chemistry -! - usr_O_O_ndx = get_rxt_ndx( 'usr_O_O' ) - usr_CL2O2_M_ndx = get_rxt_ndx( 'usr_CL2O2_M' ) - usr_SO3_H2O_ndx = get_rxt_ndx( 'usr_SO3_H2O' ) -! - tag_CLO_CLO_M_ndx = get_rxt_ndx( 'tag_CLO_CLO_M' ) - if (tag_CLO_CLO_M_ndx<0) then ! for backwards compatibility - tag_CLO_CLO_M_ndx = get_rxt_ndx( 'tag_CLO_CLO' ) - endif -! -! reactions to remove BAM aerosols in the stratosphere -! - usr_strat_tau_ndx( 1) = get_rxt_ndx( 'usr_CB1_strat_tau' ) - usr_strat_tau_ndx( 2) = get_rxt_ndx( 'usr_CB2_strat_tau' ) - usr_strat_tau_ndx( 3) = get_rxt_ndx( 'usr_OC1_strat_tau' ) - usr_strat_tau_ndx( 4) = get_rxt_ndx( 'usr_OC2_strat_tau' ) - usr_strat_tau_ndx( 5) = get_rxt_ndx( 'usr_SO4_strat_tau' ) - usr_strat_tau_ndx( 6) = get_rxt_ndx( 'usr_SOA_strat_tau' ) - usr_strat_tau_ndx( 7) = get_rxt_ndx( 'usr_NH4_strat_tau' ) - usr_strat_tau_ndx( 8) = get_rxt_ndx( 'usr_NH4NO3_strat_tau' ) - usr_strat_tau_ndx( 9) = get_rxt_ndx( 'usr_SSLT01_strat_tau' ) - usr_strat_tau_ndx(10) = get_rxt_ndx( 'usr_SSLT02_strat_tau' ) - usr_strat_tau_ndx(11) = get_rxt_ndx( 'usr_SSLT03_strat_tau' ) - usr_strat_tau_ndx(12) = get_rxt_ndx( 'usr_SSLT04_strat_tau' ) - usr_strat_tau_ndx(13) = get_rxt_ndx( 'usr_DST01_strat_tau' ) - usr_strat_tau_ndx(14) = get_rxt_ndx( 'usr_DST02_strat_tau' ) - usr_strat_tau_ndx(15) = get_rxt_ndx( 'usr_DST03_strat_tau' ) - usr_strat_tau_ndx(16) = get_rxt_ndx( 'usr_DST04_strat_tau' ) - usr_strat_tau_ndx(17) = get_rxt_ndx( 'usr_SO2t_strat_tau' ) - usr_strat_tau_ndx(18) = get_rxt_ndx( 'usr_SOAI_strat_tau' ) - usr_strat_tau_ndx(19) = get_rxt_ndx( 'usr_SOAM_strat_tau' ) - usr_strat_tau_ndx(20) = get_rxt_ndx( 'usr_SOAB_strat_tau' ) - usr_strat_tau_ndx(21) = get_rxt_ndx( 'usr_SOAT_strat_tau' ) - usr_strat_tau_ndx(22) = get_rxt_ndx( 'usr_SOAX_strat_tau' ) -! -! stratospheric aerosol chemistry -! - het1_ndx = get_rxt_ndx( 'het1' ) -! -! ion chemistry -! - ion1_ndx = get_rxt_ndx( 'ion_Op_O2' ) - ion2_ndx = get_rxt_ndx( 'ion_Op_N2' ) - ion3_ndx = get_rxt_ndx( 'ion_N2p_Oa' ) - ion11_ndx = get_rxt_ndx( 'ion_N2p_Ob' ) - - elec1_ndx = get_rxt_ndx( 'elec1' ) - elec2_ndx = get_rxt_ndx( 'elec2' ) - elec3_ndx = get_rxt_ndx( 'elec3' ) - - do i = 1,nean - write (xchar,'(i4)') i - rxtname = 'ean'//trim(adjustl(xchar)) - ean_ndx(i) = get_rxt_ndx(trim(rxtname)) - enddo - - do i = 1,nrpe - write (xchar,'(i4)') i - rxtname = 'rpe'//trim(adjustl(xchar)) - rpe_ndx(i) = get_rxt_ndx(trim(rxtname)) - enddo - - do i = 1,npir - write (xchar,'(i4)') i - rxtname = 'pir'//trim(adjustl(xchar)) - pir_ndx(i) = get_rxt_ndx(trim(rxtname)) - enddo - - do i = 1,nedn - write (xchar,'(i4)') i - rxtname = 'edn'//trim(adjustl(xchar)) - edn_ndx(i) = get_rxt_ndx(trim(rxtname)) - enddo - - do i = 1,nnir - write (xchar,'(i4)') i - rxtname = 'nir'//trim(adjustl(xchar)) - nir_ndx(i) = get_rxt_ndx(trim(rxtname)) - enddo - - do i = 1,niira - write (xchar,'(i4)') i - rxtname = 'iira'//trim(adjustl(xchar)) - iira_ndx(i) = get_rxt_ndx(trim(rxtname)) - enddo - - do i = 1,niirb - write (xchar,'(i4)') i - rxtname = 'iirb'//trim(adjustl(xchar)) - iirb_ndx(i) = get_rxt_ndx(trim(rxtname)) - enddo - - usr_clm_h2o_m_ndx = get_rxt_ndx( 'usr_CLm_H2O_M' ) - usr_clm_hcl_m_ndx = get_rxt_ndx( 'usr_CLm_HCL_M' ) - - elec4_ndx = get_rxt_ndx( 'Op2P_ea' ) - elec5_ndx = get_rxt_ndx( 'Op2P_eb' ) - elec6_ndx = get_rxt_ndx( 'Op2D_e' ) - - has_ion_rxts = ion1_ndx>0 .and. ion2_ndx>0 .and. ion3_ndx>0 .and. elec1_ndx>0 & - .and. elec2_ndx>0 .and. elec3_ndx>0 - - has_d_chem = & - all(ean_ndx>0) .and. & - all(rpe_ndx>0) .and. & - all(pir_ndx>0) .and. & - all(edn_ndx>0) .and. & - all(nir_ndx>0) .and. & - all(iira_ndx>0) .and. & - all(iirb_ndx>0) .and. & - usr_clm_h2o_m_ndx>0 .and. usr_clm_hcl_m_ndx>0 - - h2o_ndx = get_spc_ndx( 'H2O' ) - - ! - ! llnl super fast - ! - usr_oh_co_ndx = get_rxt_ndx( 'usr_oh_co' ) - het_no2_h2o_ndx = get_rxt_ndx( 'het_no2_h2o' ) - usr_oh_dms_ndx = get_rxt_ndx( 'usr_oh_dms' ) - aq_so2_h2o2_ndx = get_rxt_ndx( 'aq_so2_h2o2' ) - aq_so2_o3_ndx = get_rxt_ndx( 'aq_so2_o3' ) - -!lke++ -! CO tags -! - usr_COhc_OH_ndx = get_rxt_ndx( 'usr_COhc_OH' ) - usr_COme_OH_ndx = get_rxt_ndx( 'usr_COme_OH' ) - usr_CO01_OH_ndx = get_rxt_ndx( 'usr_CO01_OH' ) - usr_CO02_OH_ndx = get_rxt_ndx( 'usr_CO02_OH' ) - usr_CO03_OH_ndx = get_rxt_ndx( 'usr_CO03_OH' ) - usr_CO04_OH_ndx = get_rxt_ndx( 'usr_CO04_OH' ) - usr_CO05_OH_ndx = get_rxt_ndx( 'usr_CO05_OH' ) - usr_CO06_OH_ndx = get_rxt_ndx( 'usr_CO06_OH' ) - usr_CO07_OH_ndx = get_rxt_ndx( 'usr_CO07_OH' ) - usr_CO08_OH_ndx = get_rxt_ndx( 'usr_CO08_OH' ) - usr_CO09_OH_ndx = get_rxt_ndx( 'usr_CO09_OH' ) - usr_CO10_OH_ndx = get_rxt_ndx( 'usr_CO10_OH' ) - usr_CO11_OH_ndx = get_rxt_ndx( 'usr_CO11_OH' ) - usr_CO12_OH_ndx = get_rxt_ndx( 'usr_CO12_OH' ) - usr_CO13_OH_ndx = get_rxt_ndx( 'usr_CO13_OH' ) - usr_CO14_OH_ndx = get_rxt_ndx( 'usr_CO14_OH' ) - usr_CO15_OH_ndx = get_rxt_ndx( 'usr_CO15_OH' ) - usr_CO16_OH_ndx = get_rxt_ndx( 'usr_CO16_OH' ) - usr_CO17_OH_ndx = get_rxt_ndx( 'usr_CO17_OH' ) - usr_CO18_OH_ndx = get_rxt_ndx( 'usr_CO18_OH' ) - usr_CO19_OH_ndx = get_rxt_ndx( 'usr_CO19_OH' ) - usr_CO20_OH_ndx = get_rxt_ndx( 'usr_CO20_OH' ) - usr_CO21_OH_ndx = get_rxt_ndx( 'usr_CO21_OH' ) - usr_CO22_OH_ndx = get_rxt_ndx( 'usr_CO22_OH' ) - usr_CO23_OH_ndx = get_rxt_ndx( 'usr_CO23_OH' ) - usr_CO24_OH_ndx = get_rxt_ndx( 'usr_CO24_OH' ) - usr_CO25_OH_ndx = get_rxt_ndx( 'usr_CO25_OH' ) - usr_CO26_OH_ndx = get_rxt_ndx( 'usr_CO26_OH' ) - usr_CO27_OH_ndx = get_rxt_ndx( 'usr_CO27_OH' ) - usr_CO28_OH_ndx = get_rxt_ndx( 'usr_CO28_OH' ) - usr_CO29_OH_ndx = get_rxt_ndx( 'usr_CO29_OH' ) - usr_CO30_OH_ndx = get_rxt_ndx( 'usr_CO30_OH' ) - usr_CO31_OH_ndx = get_rxt_ndx( 'usr_CO31_OH' ) - usr_CO32_OH_ndx = get_rxt_ndx( 'usr_CO32_OH' ) - usr_CO33_OH_ndx = get_rxt_ndx( 'usr_CO33_OH' ) - usr_CO34_OH_ndx = get_rxt_ndx( 'usr_CO34_OH' ) - usr_CO35_OH_ndx = get_rxt_ndx( 'usr_CO35_OH' ) - usr_CO36_OH_ndx = get_rxt_ndx( 'usr_CO36_OH' ) - usr_CO37_OH_ndx = get_rxt_ndx( 'usr_CO37_OH' ) - usr_CO38_OH_ndx = get_rxt_ndx( 'usr_CO38_OH' ) - usr_CO39_OH_ndx = get_rxt_ndx( 'usr_CO39_OH' ) - usr_CO40_OH_ndx = get_rxt_ndx( 'usr_CO40_OH' ) - usr_CO41_OH_ndx = get_rxt_ndx( 'usr_CO41_OH' ) - usr_CO42_OH_ndx = get_rxt_ndx( 'usr_CO42_OH' ) -!lke-- - - if (masterproc) then - write(iulog,*) ' ' - write(iulog,*) 'usrrxt_inti: diagnostics ' - write(iulog,'(10i5)') usr_O_O2_ndx,usr_HO2_HO2_ndx,tag_NO2_NO3_ndx,usr_N2O5_M_ndx,tag_NO2_OH_ndx,usr_HNO3_OH_ndx & - ,tag_NO2_HO2_ndx,usr_HO2NO2_M_ndx,usr_N2O5_aer_ndx,usr_NO3_aer_ndx,usr_NO2_aer_ndx & - ,usr_CO_OH_b_ndx,tag_C2H4_OH_ndx,tag_C3H6_OH_ndx,tag_CH3CO3_NO2_ndx,usr_PAN_M_ndx,usr_CH3COCH3_OH_ndx & - ,usr_MCO3_NO2_ndx,usr_MPAN_M_ndx,usr_XOOH_OH_ndx,usr_SO2_OH_ndx,usr_DMS_OH_ndx,usr_HO2_aer_ndx & - ,usr_GLYOXAL_aer_ndx,usr_ISOPNITA_aer_ndx,usr_ISOPNITB_aer_ndx,usr_ONITR_aer_ndx,usr_HONITR_aer_ndx & - ,usr_TERPNIT_aer_ndx,usr_NTERPOOH_aer_ndx,usr_NC4CHO_aer_ndx,usr_NC4CH2OH_aer_ndx - - end if - - end subroutine usrrxt_inti - - subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, & - pmid, m, sulfate, mmr, relhum, strato_sad, & - tropchemlev, dlat, ncol, sad_trop, reff_trop, cwat, mbar, pbuf ) - -!----------------------------------------------------------------- -! ... set the user specified reaction rates -!----------------------------------------------------------------- - - use mo_constants, only : pi, avo => avogadro, boltz_cgs, rgas - use chem_mods, only : nfs, rxntot, gas_pcnst, inv_m_ndx=>indexm - use mo_setinv, only : inv_o2_ndx=>o2_ndx, inv_h2o_ndx=>h2o_ndx - use physics_buffer,only : physics_buffer_desc - use carma_flags_mod, only : carma_hetchem_feedback - use aero_model, only : aero_model_surfarea - use rad_constituents,only : rad_cnst_get_info - - implicit none - -!----------------------------------------------------------------- -! ... dummy arguments -!----------------------------------------------------------------- - integer, intent(in) :: ncol - integer, intent(in) :: tropchemlev(pcols) ! trop/strat reaction separation vertical index - real(r8), intent(in) :: dlat(:) ! degrees latitude - real(r8), intent(in) :: temp(pcols,pver) ! temperature (K); neutral temperature - real(r8), intent(in) :: tempi(pcols,pver) ! ionic temperature (K); only used if ion chemistry - real(r8), intent(in) :: tempe(pcols,pver) ! electronic temperature (K); only used if ion chemistry - real(r8), intent(in) :: m(ncol,pver) ! total atm density (/cm^3) - real(r8), intent(in) :: sulfate(ncol,pver) ! sulfate aerosol (mol/mol) - real(r8), intent(in) :: strato_sad(pcols,pver) ! stratospheric aerosol sad (1/cm) - real(r8), intent(in) :: h2ovmr(ncol,pver) ! water vapor (mol/mol) - real(r8), intent(in) :: relhum(ncol,pver) ! relative humidity - real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressure (Pa) - real(r8), intent(in) :: invariants(ncol,pver,nfs) ! invariants density (/cm^3) - real(r8), intent(in) :: mmr(pcols,pver,gas_pcnst) ! species concentrations (kg/kg) - real(r8), intent(in) :: cwat(ncol,pver) !PJC Condensed Water (liquid+ice) (kg/kg) - real(r8), intent(in) :: mbar(ncol,pver) !PJC Molar mass of air (g/mol) - real(r8), intent(inout) :: rxt(ncol,pver,rxntot) ! gas phase rates - real(r8), intent(out) :: sad_trop(pcols,pver) ! tropospheric surface area density (cm2/cm3) - real(r8), intent(out) :: reff_trop(pcols,pver) ! tropospheric effective radius (cm) - type(physics_buffer_desc), pointer :: pbuf(:) - -!----------------------------------------------------------------- -! ... local variables -!----------------------------------------------------------------- - - real(r8), parameter :: dg = 0.1_r8 ! mole diffusion =0.1 cm2/s (Dentener, 1993) - -!----------------------------------------------------------------- -! ... reaction probabilities for heterogeneous reactions -!----------------------------------------------------------------- - real(r8), parameter :: gamma_n2o5 = 0.10_r8 ! from Jacob, Atm Env, 34, 2131, 2000 - real(r8), parameter :: gamma_ho2 = 0.20_r8 ! - real(r8), parameter :: gamma_no2 = 0.0001_r8 ! - real(r8), parameter :: gamma_no3 = 0.001_r8 ! - real(r8), parameter :: gamma_glyoxal = 2.0e-4_r8 ! Washenfelder et al, JGR, 2011 -!TS1 species - real(r8), parameter :: gamma_isopnita = 0.005_r8 ! from Fisher et al., ACP, 2016 - real(r8), parameter :: gamma_isopnitb = 0.005_r8 ! - real(r8), parameter :: gamma_onitr = 0.005_r8 ! - real(r8), parameter :: gamma_honitr = 0.005_r8 ! - real(r8), parameter :: gamma_terpnit = 0.01_r8 ! - real(r8), parameter :: gamma_nterpooh = 0.01_r8 ! - real(r8), parameter :: gamma_nc4cho = 0.005_r8 ! - real(r8), parameter :: gamma_nc4ch2oh = 0.005_r8 ! - - - integer :: i, k - integer :: l - real(r8) :: tp(ncol) ! 300/t - real(r8) :: tinv(ncol) ! 1/t - real(r8) :: ko(ncol) - real(r8) :: term1(ncol) - real(r8) :: term2(ncol) - real(r8) :: kinf(ncol) - real(r8) :: fc(ncol) - real(r8) :: xr(ncol) - real(r8) :: sur(ncol) - real(r8) :: sqrt_t(ncol) ! sqrt( temp ) - real(r8) :: sqrt_t_58(ncol) ! sqrt( temp / 58.) - real(r8) :: exp_fac(ncol) ! vector exponential - real(r8) :: lwc(ncol) - real(r8) :: ko_m(ncol) - real(r8) :: k0(ncol) - real(r8) :: kinf_m(ncol) - real(r8) :: o2(ncol) - real(r8) :: c_n2o5, c_ho2, c_no2, c_no3, c_glyoxal -!TS1 species - real(r8) :: c_isopnita, c_isopnitb, c_onitr, c_honitr, c_terpnit, c_nterpooh - real(r8) :: c_nc4cho, c_nc4ch2oh - - real(r8) :: amas - !----------------------------------------------------------------- - ! ... density of sulfate aerosol - !----------------------------------------------------------------- - real(r8), parameter :: gam1 = 0.04_r8 ! N2O5+SUL ->2HNO3 - real(r8), parameter :: wso4 = 98._r8 - real(r8), parameter :: den = 1.15_r8 ! each molecule of SO4(aer) density g/cm3 - !------------------------------------------------- - ! ... volume of sulfate particles - ! assuming mean rm - ! continient 0.05um 0.07um 0.09um - ! ocean 0.09um 0.25um 0.37um - ! 0.16um Blake JGR,7195, 1995 - !------------------------------------------------- - real(r8), parameter :: rm1 = 0.16_r8*1.e-4_r8 ! mean radii in cm - real(r8), parameter :: fare = 4._r8*pi*rm1*rm1 ! each mean particle(r=0.1u) area cm2/cm3 - - !----------------------------------------------------------------------- - ! ... Aqueous phase sulfur quantities for SO2 + H2O2 and SO2 + O3 - !----------------------------------------------------------------------- - real(r8), parameter :: HENRY298_H2O2 = 7.45e+04_r8 - real(r8), parameter :: H298_H2O2 = -1.45e+04_r8 - real(r8), parameter :: HENRY298_SO2 = 1.23e+00_r8 - real(r8), parameter :: H298_SO2 = -6.25e+03_r8 - real(r8), parameter :: K298_SO2_HSO3 = 1.3e-02_r8 - real(r8), parameter :: H298_SO2_HSO3 = -4.16e+03_r8 - real(r8), parameter :: R_CONC = 82.05e+00_r8 / avo - real(r8), parameter :: R_CAL = rgas * 0.239006e+00_r8 - real(r8), parameter :: K_AQ = 7.57e+07_r8 - real(r8), parameter :: ER_AQ = 4.43e+03_r8 - - real(r8), parameter :: HENRY298_O3 = 1.13e-02_r8 - real(r8), parameter :: H298_O3 = -5.04e+03_r8 - real(r8), parameter :: K298_HSO3_SO3 = 6.6e-08_r8 - real(r8), parameter :: H298_HSO3_SO3 = -2.23e+03_r8 - real(r8), parameter :: K0_AQ = 2.4e+04_r8 - real(r8), parameter :: ER0_AQ = 0.0e+00_r8 - real(r8), parameter :: K1_AQ = 3.7e+05_r8 - real(r8), parameter :: ER1_AQ = 5.53e+03_r8 - real(r8), parameter :: K2_AQ = 1.5e+09_r8 - real(r8), parameter :: ER2_AQ = 5.28e+03_r8 - - real(r8), parameter :: pH = 4.5e+00_r8 - - real(r8), pointer :: sfc(:), dm_aer(:) - integer :: ntot_amode - - real(r8), pointer :: sfc_array(:,:,:), dm_array(:,:,:) - - ntot_amode = nmodes_oslo - if (ntot_amode>0) then - allocate(sfc_array(pcols,pver,ntot_amode), dm_array(pcols,pver,ntot_amode) ) - else - allocate(sfc_array(pcols,pver,5), dm_array(pcols,pver,5) ) - endif - - sfc_array(:,:,:) = 0._r8 - dm_array(:,:,:) = 0._r8 - sad_trop(:,:) = 0._r8 - reff_trop(:,:) = 0._r8 - - if( usr_NO2_aer_ndx > 0 .or. usr_NO3_aer_ndx > 0 .or. usr_N2O5_aer_ndx > 0 .or. usr_HO2_aer_ndx > 0 ) then - -! sad_trop should be set outside of usrrxt ?? - if( carma_hetchem_feedback ) then - sad_trop(:ncol,:pver)=strato_sad(:ncol,:pver) - else - - call aero_model_surfarea( & - mmr, rm1, relhum, pmid, temp, strato_sad, sulfate, m, tropchemlev, dlat, & - het1_ndx, pbuf, ncol, sfc_array, dm_array, sad_trop, reff_trop ) - - endif - endif - - level_loop : do k = 1,pver - tinv(:) = 1._r8 / temp(:ncol,k) - tp(:) = 300._r8 * tinv(:) - sqrt_t(:) = sqrt( temp(:ncol,k) ) - sqrt_t_58(:) = sqrt( temp(:ncol,k) / 58.0_r8 ) - -!----------------------------------------------------------------- -! ... o + o2 + m --> o3 + m (JPL15-10) -!----------------------------------------------------------------- - if( usr_O_O2_ndx > 0 ) then - rxt(:,k,usr_O_O2_ndx) = 6.e-34_r8 * tp(:)**2.4_r8 - end if - if( usr_OA_O2_ndx > 0 ) then - rxt(:,k,usr_OA_O2_ndx) = 6.e-34_r8 * tp(:)**2.4_r8 - end if - -!----------------------------------------------------------------- -! ... o + o + m -> o2 + m -!----------------------------------------------------------------- - if ( usr_O_O_ndx > 0 ) then - rxt(:,k,usr_O_O_ndx) = 2.76e-34_r8 * exp( 720.0_r8*tinv(:) ) - end if - -!----------------------------------------------------------------- -! ... cl2o2 + m -> 2*clo + m (JPL15-10) -!----------------------------------------------------------------- - if ( usr_CL2O2_M_ndx > 0 ) then - if ( tag_CLO_CLO_M_ndx > 0 ) then - ko(:) = 2.16e-27_r8 * exp( 8537.0_r8* tinv(:) ) - rxt(:,k,usr_CL2O2_M_ndx) = rxt(:,k,tag_CLO_CLO_M_ndx)/ko(:) - else - rxt(:,k,usr_CL2O2_M_ndx) = 0._r8 - end if - end if - -!----------------------------------------------------------------- -! ... so3 + 2*h2o --> h2so4 + h2o -! Note: this reaction proceeds by the 2 intermediate steps below -! so3 + h2o --> adduct -! adduct + h2o --> h2so4 + h2o -! (Lovejoy et al., JCP, pp. 19911-19916, 1996) -! The first order rate constant used here is recommended by JPL 2011. -! This rate involves the water vapor number density. -!----------------------------------------------------------------- - - if ( usr_SO3_H2O_ndx > 0 ) then - call comp_exp( exp_fac, 6540.0_r8*tinv(:), ncol ) - if( h2o_ndx > 0 ) then - fc(:) = 8.5e-21_r8 * m(:,k) * h2ovmr(:,k) * exp_fac(:) - else - fc(:) = 8.5e-21_r8 * invariants(:,k,inv_h2o_ndx) * exp_fac(:) - end if - rxt(:,k,usr_SO3_H2O_ndx) = 1.0e-20_r8 * fc(:) - end if - -!----------------------------------------------------------------- -! ... n2o5 + m --> no2 + no3 + m (JPL15-10) -!----------------------------------------------------------------- - if( usr_N2O5_M_ndx > 0 ) then - if( tag_NO2_NO3_ndx > 0 ) then - call comp_exp( exp_fac, -10840.0_r8*tinv, ncol ) - rxt(:,k,usr_N2O5_M_ndx) = rxt(:,k,tag_NO2_NO3_ndx) * 1.724138e26_r8 * exp_fac(:) - else - rxt(:,k,usr_N2O5_M_ndx) = 0._r8 - end if - end if - if( usr_XNO2NO3_M_ndx > 0 ) then - if( tag_NO2_NO3_ndx > 0 ) then - call comp_exp( exp_fac, -10840.0_r8*tinv, ncol ) - rxt(:,k,usr_XNO2NO3_M_ndx) = rxt(:,k,tag_NO2_NO3_ndx) *1.724138e26_r8 * exp_fac(:) - else - rxt(:,k,usr_XNO2NO3_M_ndx) = 0._r8 - end if - end if - if( usr_NO2XNO3_M_ndx > 0 ) then - if( tag_NO2_NO3_ndx > 0 ) then - call comp_exp( exp_fac, -10840.0_r8*tinv, ncol ) - rxt(:,k,usr_NO2XNO3_M_ndx) = rxt(:,k,tag_NO2_NO3_ndx) * 1.734138e26_r8 * exp_fac(:) - else - rxt(:,k,usr_NO2XNO3_M_ndx) = 0._r8 - end if - end if - -!----------------------------------------------------------------- -! set rates for: -! ... hno3 + oh --> no3 + h2o -! ho2no2 + m --> ho2 + no2 + m -!----------------------------------------------------------------- - if( usr_HNO3_OH_ndx > 0 ) then - call comp_exp( exp_fac, 1335._r8*tinv, ncol ) - ko(:) = m(:,k) * 6.5e-34_r8 * exp_fac(:) - call comp_exp( exp_fac, 2199._r8*tinv, ncol ) - ko(:) = ko(:) / (1._r8 + ko(:)/(2.7e-17_r8*exp_fac(:))) - call comp_exp( exp_fac, 460._r8*tinv, ncol ) - rxt(:,k,usr_HNO3_OH_ndx) = ko(:) + 2.4e-14_r8*exp_fac(:) - end if - if( usr_XHNO3_OH_ndx > 0 ) then - call comp_exp( exp_fac, 1335._r8*tinv, ncol ) - ko(:) = m(:,k) * 6.5e-34_r8 * exp_fac(:) - call comp_exp( exp_fac, 2199._r8*tinv, ncol ) - ko(:) = ko(:) / (1._r8 + ko(:)/(2.7e-17_r8*exp_fac(:))) - call comp_exp( exp_fac, 460._r8*tinv, ncol ) - rxt(:,k,usr_XHNO3_OH_ndx) = ko(:) + 2.4e-14_r8*exp_fac(:) - end if - if( usr_HO2NO2_M_ndx > 0 ) then - if( tag_NO2_HO2_ndx > 0 ) then - call comp_exp( exp_fac, -10900._r8*tinv, ncol ) - rxt(:,k,usr_HO2NO2_M_ndx) = rxt(:,k,tag_NO2_HO2_ndx) * exp_fac(:) / 2.1e-27_r8 - else - rxt(:,k,usr_HO2NO2_M_ndx) = 0._r8 - end if - end if - if( usr_XHO2NO2_M_ndx > 0 ) then - if( tag_NO2_HO2_ndx > 0 ) then - call comp_exp( exp_fac, -10900._r8*tinv, ncol ) - rxt(:,k,usr_XHO2NO2_M_ndx) = rxt(:,k,tag_NO2_HO2_ndx) * exp_fac(:) / 2.1e-27_r8 - else - rxt(:,k,usr_XHO2NO2_M_ndx) = 0._r8 - end if - end if -!----------------------------------------------------------------- -! co + oh --> co2 + ho2 (combined branches - do not use with CO_OH_b) -!----------------------------------------------------------------- - if( usr_CO_OH_a_ndx > 0 ) then - rxt(:,k,usr_CO_OH_a_ndx) = 1.5e-13_r8 * & - (1._r8 + 6.e-7_r8*boltz_cgs*m(:,k)*temp(:ncol,k)) - end if -!----------------------------------------------------------------- -! ... co + oh --> co2 + h (second branch JPL15-10, with CO+OH+M) -!----------------------------------------------------------------- - if( usr_CO_OH_b_ndx > 0 ) then - kinf(:) = 2.1e+09_r8 * (temp(:ncol,k)/ t0)**(6.1_r8) - ko (:) = 1.5e-13_r8 - - term1(:) = ko(:) / ( (kinf(:) / m(:,k)) ) - term2(:) = ko(:) / (1._r8 + term1(:)) - - term1(:) = log10( term1(:) ) - term1(:) = 1.0_r8 / (1.0_r8 + term1(:)*term1(:)) - - rxt(:ncol,k,usr_CO_OH_b_ndx) = term2(:) * (0.6_r8)**term1(:) - end if - -!----------------------------------------------------------------- -! ... ho2 + ho2 --> h2o2 -! note: this rate involves the water vapor number density -!----------------------------------------------------------------- - if( usr_HO2_HO2_ndx > 0 ) then - - call comp_exp( exp_fac, 460._r8*tinv, ncol ) - ko(:) = 3.0e-13_r8 * exp_fac(:) - call comp_exp( exp_fac, 920._r8*tinv, ncol ) - kinf(:) = 2.1e-33_r8 * m(:,k) * exp_fac(:) - call comp_exp( exp_fac, 2200._r8*tinv, ncol ) - - if( h2o_ndx > 0 ) then - fc(:) = 1._r8 + 1.4e-21_r8 * m(:,k) * h2ovmr(:,k) * exp_fac(:) - else - fc(:) = 1._r8 + 1.4e-21_r8 * invariants(:,k,inv_h2o_ndx) * exp_fac(:) - end if - rxt(:,k,usr_HO2_HO2_ndx) = (ko(:) + kinf(:)) * fc(:) - - end if - -!----------------------------------------------------------------- -! ... mco3 + no2 -> mpan -!----------------------------------------------------------------- - if( usr_MCO3_NO2_ndx > 0 ) then - rxt(:,k,usr_MCO3_NO2_ndx) = 1.1e-11_r8 * tp(:) / m(:,k) - end if - if( usr_MCO3_XNO2_ndx > 0 ) then - rxt(:,k,usr_MCO3_XNO2_ndx) = 1.1e-11_r8 * tp(:) / m(:,k) - end if - -!----------------------------------------------------------------- -! ... pan + m --> ch3co3 + no2 + m (JPL15-10) -!----------------------------------------------------------------- - call comp_exp( exp_fac, -14000._r8*tinv, ncol ) - if( usr_PAN_M_ndx > 0 ) then - if( tag_CH3CO3_NO2_ndx > 0 ) then - rxt(:,k,usr_PAN_M_ndx) = rxt(:,k,tag_CH3CO3_NO2_ndx) * 1.111e28_r8 * exp_fac(:) - else - rxt(:,k,usr_PAN_M_ndx) = 0._r8 - end if - end if - if( usr_XPAN_M_ndx > 0 ) then - if( tag_CH3CO3_NO2_ndx > 0 ) then - rxt(:,k,usr_XPAN_M_ndx) = rxt(:,k,tag_CH3CO3_NO2_ndx) * 1.111e28_r8 * exp_fac(:) - else - rxt(:,k,usr_XPAN_M_ndx) = 0._r8 - end if - end if - -!----------------------------------------------------------------- -! ... mpan + m --> mco3 + no2 + m (JPL15-10) -!----------------------------------------------------------------- - if( usr_MPAN_M_ndx > 0 ) then - if( usr_MCO3_NO2_ndx > 0 ) then - rxt(:,k,usr_MPAN_M_ndx) = rxt(:,k,usr_MCO3_NO2_ndx) * 1.111e28_r8 * exp_fac(:) - else - rxt(:,k,usr_MPAN_M_ndx) = 0._r8 - end if - end if - if( usr_XMPAN_M_ndx > 0 ) then - if( usr_MCO3_NO2_ndx > 0 ) then - rxt(:,k,usr_XMPAN_M_ndx) = rxt(:,k,usr_MCO3_NO2_ndx) * 1.111e28_r8 * exp_fac(:) - else - rxt(:,k,usr_XMPAN_M_ndx) = 0._r8 - end if - end if - -!lke-TS1 -!----------------------------------------------------------------- -! ... pbznit + m --> acbzo2 + no2 + m -!----------------------------------------------------------------- - if( usr_PBZNIT_M_ndx > 0 ) then - if( tag_ACBZO2_NO2_ndx > 0 ) then - rxt(:,k,usr_PBZNIT_M_ndx) = rxt(:,k,tag_ACBZO2_NO2_ndx) * 1.111e28_r8 * exp_fac(:) - else - rxt(:,k,usr_PBZNIT_M_ndx) = 0._r8 - end if - end if - -!----------------------------------------------------------------- -! ... xooh + oh -> h2o + oh -!----------------------------------------------------------------- - if( usr_XOOH_OH_ndx > 0 ) then - call comp_exp( exp_fac, 253._r8*tinv, ncol ) - rxt(:,k,usr_XOOH_OH_ndx) = temp(:ncol,k)**2._r8 * 7.69e-17_r8 * exp_fac(:) - end if - -!----------------------------------------------------------------- -! ... ch3coch3 + oh -> ro2 + h2o -!----------------------------------------------------------------- - if( usr_CH3COCH3_OH_ndx > 0 ) then - call comp_exp( exp_fac, -2000._r8*tinv, ncol ) - rxt(:,k,usr_CH3COCH3_OH_ndx) = 3.82e-11_r8 * exp_fac(:) + 1.33e-13_r8 - end if - -!----------------------------------------------------------------- -! ... DMS + OH --> .5 * SO2 -!----------------------------------------------------------------- - if( usr_DMS_OH_ndx > 0 ) then - call comp_exp( exp_fac, 7460._r8*tinv, ncol ) - ko(:) = 1._r8 + 5.5e-31_r8 * exp_fac * m(:,k) * 0.21_r8 - call comp_exp( exp_fac, 7810._r8*tinv, ncol ) - rxt(:,k,usr_DMS_OH_ndx) = 1.7e-42_r8 * exp_fac * m(:,k) * 0.21_r8 / ko(:) - end if - -!----------------------------------------------------------------- -! ... SO2 + OH --> SO4 (REFERENCE?? - not Liao) -!----------------------------------------------------------------- - if( usr_SO2_OH_ndx > 0 ) then - fc(:) = 3.0e-31_r8 *(300._r8*tinv(:))**3.3_r8 - ko(:) = fc(:)*m(:,k)/(1._r8 + fc(:)*m(:,k)/1.5e-12_r8) - rxt(:,k,usr_SO2_OH_ndx) = ko(:)*.6_r8**(1._r8 + (log10(fc(:)*m(:,k)/1.5e-12_r8))**2._r8)**(-1._r8) - end if -! -! reduced hydrocarbon scheme -! - if ( usr_C2O3_NO2_ndx > 0 ) then - ko(:) = 2.6e-28_r8 * m(:,k) - kinf(:) = 1.2e-11_r8 - rxt(:,k,usr_C2O3_NO2_ndx) = (ko/(1._r8+ko/kinf)) * 0.6_r8**(1._r8/(1._r8+(log10(ko/kinf))**2)) - end if - if ( usr_C2O3_XNO2_ndx > 0 ) then - ko(:) = 2.6e-28_r8 * m(:,k) - kinf(:) = 1.2e-11_r8 - rxt(:,k,usr_C2O3_XNO2_ndx) = (ko/(1._r8+ko/kinf)) * 0.6_r8**(1._r8/(1._r8+(log10(ko/kinf))**2)) - end if - if ( usr_C2H4_OH_ndx > 0 ) then - ko(:) = 1.0e-28_r8 * m(:,k) - kinf(:) = 8.8e-12_r8 - rxt(:,k,usr_C2H4_OH_ndx) = (ko/(1._r8+ko/kinf)) * 0.6_r8**(1._r8/(1._r8+(log(ko/kinf))**2)) - end if - if ( usr_XO2N_HO2_ndx > 0 ) then - rxt(:,k,usr_XO2N_HO2_ndx) = rxt(:,k,tag_XO2N_NO_ndx)*rxt(:,k,tag_XO2_HO2_ndx)/(rxt(:,k,tag_XO2_NO_ndx)+1.e-36_r8) - end if - -! -! hydrolysis reactions on wetted aerosols -! - if( usr_NO2_aer_ndx > 0 .or. usr_NO3_aer_ndx > 0 .or. usr_N2O5_aer_ndx > 0 .or. usr_HO2_aer_ndx > 0 & - .or. usr_GLYOXAL_aer_ndx > 0 ) then - - long_loop : do i = 1,ncol - - sfc => sfc_array(i,k,:) - dm_aer => dm_array(i,k,:) - - c_n2o5 = 1.40e3_r8 * sqrt_t(i) ! mean molecular speed of n2o5 - c_no3 = 1.85e3_r8 * sqrt_t(i) ! mean molecular speed of no3 - c_no2 = 2.15e3_r8 * sqrt_t(i) ! mean molecular speed of no2 - c_ho2 = 2.53e3_r8 * sqrt_t(i) ! mean molecular speed of ho2 - c_glyoxal = 1.455e4_r8 * sqrt_t_58(i) ! mean molecular speed of ho2 - c_isopnita = 1.20e3_r8 * sqrt_t(i) ! mean molecular speed of isopnita - c_isopnitb = 1.20e3_r8 * sqrt_t(i) ! mean molecular speed of isopnitb - c_onitr = 1.20e3_r8 * sqrt_t(i) ! mean molecular speed of onitr - c_honitr = 1.26e3_r8 * sqrt_t(i) ! mean molecular speed of honitr - c_terpnit = 0.992e3_r8 * sqrt_t(i) ! mean molecular speed of terpnit - c_nterpooh = 0.957e3_r8 * sqrt_t(i) ! mean molecular speed of nterpooh - c_nc4cho = 1.21e3_r8 * sqrt_t(i) ! mean molecular speed of nc4cho - c_nc4ch2oh = 1.20e3_r8 * sqrt_t(i) ! mean molecular speed of nc4ch2oh - - !------------------------------------------------------------------------- - ! Heterogeneous reaction rates for uptake of a gas on an aerosol: - ! rxt = sfc / ( (rad_aer/Dg_gas) + (4/(c_gas*gamma_gas))) - !------------------------------------------------------------------------- - !------------------------------------------------------------------------- - ! ... n2o5 -> 2 hno3 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_N2O5_aer_ndx > 0 ) then - rxt(i,k,usr_N2O5_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_n2o5, gamma_n2o5 ) - end if - if( usr_XNO2NO3_aer_ndx > 0 ) then - rxt(i,k,usr_XNO2NO3_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_n2o5, gamma_n2o5 ) - end if - if( usr_NO2XNO3_aer_ndx > 0 ) then - rxt(i,k,usr_NO2XNO3_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_n2o5, gamma_n2o5 ) - end if - !------------------------------------------------------------------------- - ! ... no3 -> hno3 (on sulfate, nh4no3, oc, soa) - !------------------------------------------------------------------------- - if( usr_NO3_aer_ndx > 0 ) then - rxt(i,k,usr_NO3_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_no3, gamma_no3 ) - end if - if( usr_XNO3_aer_ndx > 0 ) then - rxt(i,k,usr_XNO3_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_no3, gamma_no3 ) - end if - !------------------------------------------------------------------------- - ! ... no2 -> 0.5 * (ho+no+hno3) (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_NO2_aer_ndx > 0 ) then - rxt(i,k,usr_NO2_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_no2, gamma_no2 ) - end if - if( usr_XNO2_aer_ndx > 0 ) then - rxt(i,k,usr_XNO2_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_no2, gamma_no2 ) - end if - - !------------------------------------------------------------------------- - ! ... ho2 -> 0.5 * h2o2 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_HO2_aer_ndx > 0 ) then - rxt(i,k,usr_HO2_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_ho2, gamma_ho2 ) - end if - !------------------------------------------------------------------------- - ! ... glyoxal -> soag1 (on sulfate, nh4no3, oc2, soa) - ! first order uptake, Fuchs and Sutugin, 1971, dCg = 1/4 * gamma * ! A * |v_mol| * Cg * dt - !------------------------------------------------------------------------- - if( usr_GLYOXAL_aer_ndx > 0 ) then - rxt(i,k,usr_GLYOXAL_aer_ndx) = hetrxtrate_gly( sfc, c_glyoxal, gamma_glyoxal ) - end if - !------------------------------------------------------------------------- - ! ... ISOPNITA -> HNO3 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_ISOPNITA_aer_ndx > 0 ) then - rxt(i,k,usr_ISOPNITA_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_isopnita, gamma_isopnita ) - end if - !------------------------------------------------------------------------- - ! ... ISOPNITB -> HNO3 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_ISOPNITB_aer_ndx > 0 ) then - rxt(i,k,usr_ISOPNITB_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_isopnitb, gamma_isopnitb ) - end if - !------------------------------------------------------------------------- - ! ... ONITR -> HNO3 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_ONITR_aer_ndx > 0 ) then - rxt(i,k,usr_ONITR_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_onitr, gamma_onitr ) - end if - !------------------------------------------------------------------------- - ! ... HONITR -> HNO3 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_HONITR_aer_ndx > 0 ) then - rxt(i,k,usr_HONITR_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_honitr, gamma_honitr ) - end if - !------------------------------------------------------------------------- - ! ... TERPNIT -> HNO3 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_TERPNIT_aer_ndx > 0 ) then - rxt(i,k,usr_TERPNIT_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_terpnit, gamma_terpnit ) - end if - !------------------------------------------------------------------------- - ! ... NTERPOOH -> HNO3 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_NTERPOOH_aer_ndx > 0 ) then - rxt(i,k,usr_NTERPOOH_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_nterpooh, gamma_nterpooh ) - end if - !------------------------------------------------------------------------- - ! ... NC4CHO -> HNO3 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_NC4CHO_aer_ndx > 0 ) then - rxt(i,k,usr_NC4CHO_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_nc4cho, gamma_nc4cho ) - end if - !------------------------------------------------------------------------- - ! ... NC4CH2OH -> HNO3 (on sulfate, nh4no3, oc2, soa) - !------------------------------------------------------------------------- - if( usr_NC4CH2OH_aer_ndx > 0 ) then - rxt(i,k,usr_NC4CH2OH_aer_ndx) = hetrxtrate( sfc, dm_aer, dg, c_nc4ch2oh, gamma_nc4ch2oh ) - end if - - end do long_loop - end if - - ! LLNL super fast chem reaction rates - - !----------------------------------------------------------------------- - ! ... CO + OH --> CO2 + HO2 - !----------------------------------------------------------------------- - if ( usr_oh_co_ndx > 0 ) then - ko(:) = 5.9e-33_r8 * tp(:)**1.4_r8 - kinf(:) = 1.1e-12_r8 * (temp(:ncol,k) / 300._r8)**1.3_r8 - ko_m(:) = ko(:) * m(:,k) - k0(:) = 1.5e-13_r8 * (temp(:ncol,k) / 300._r8)**0.6_r8 - kinf_m(:) = (2.1e+09_r8 * (temp(:ncol,k) / 300._r8)**6.1_r8) / m(:,k) - rxt(:,k,usr_oh_co_ndx) = (ko_m(:)/(1._r8+(ko_m(:)/kinf(:)))) * & - 0.6_r8**(1._r8/(1._r8+(log10(ko_m(:)/kinf(:)))**2._r8)) + & - (k0(:)/(1._r8+(k0(:)/kinf_m(:)))) * & - 0.6_r8**(1._r8/(1._r8+(log10(k0(:)/kinf_m(:)))**2._r8)) - endif - !----------------------------------------------------------------------- - ! ... NO2 + H2O --> 0.5 HONO + 0.5 HNO3 - !----------------------------------------------------------------------- - if ( het_no2_h2o_ndx > 0 ) then - rxt(:,k,het_no2_h2o_ndx) = 4.0e-24_r8 - endif - !----------------------------------------------------------------------- - ! ... DMS + OH --> 0.75 SO2 + 0.25 MSA - !----------------------------------------------------------------------- - if ( usr_oh_dms_ndx > 0 ) then - o2(:ncol) = invariants(:ncol,k,inv_o2_ndx) - rxt(:,k,usr_oh_dms_ndx) = 2.000e-10_r8 * exp(5820.0_r8 * tinv(:)) / & - ((2.000e29_r8 / o2(:)) + exp(6280.0_r8 * tinv(:))) - endif - if ( aq_so2_h2o2_ndx > 0 .or. aq_so2_o3_ndx > 0 ) then - lwc(:) = cwat(:ncol,k) * invariants(:ncol,k,inv_m_ndx) * mbar(:ncol,k) /avo !PJC convert kg/kg to g/cm3 - !----------------------------------------------------------------------- - ! ... SO2 + H2O2 --> S(VI) - !----------------------------------------------------------------------- - if ( aq_so2_h2o2_ndx > 0 ) then - rxt(:,k,aq_so2_h2o2_ndx) = lwc(:) * 1.0e-03_r8 * avo * & - K_AQ * & - - exp(ER_AQ * ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & - HENRY298_SO2 * & - K298_SO2_HSO3 * & - HENRY298_H2O2 * & - exp(((H298_SO2 + H298_SO2_HSO3 + H298_H2O2) / R_CAL) * & - ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & - (R_CONC * temp(:ncol,k))**2.0e+00_r8 / & - - (1.0e+00_r8 + 13.0e+00_r8 * 10.0e+00_r8**(-pH)) - endif - !----------------------------------------------------------------------- - ! ... SO2 + O3 --> S(VI) - !----------------------------------------------------------------------- - if (aq_so2_o3_ndx >0) then - rxt(:,k,aq_so2_o3_ndx) = lwc(:) * 1.0e-03_r8 * avo * & - HENRY298_SO2 * exp((H298_SO2 / R_CAL) * & - ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & - (K0_AQ * exp(ER0_AQ * & - ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) + & - K298_SO2_HSO3 * exp((H298_SO2_HSO3 / R_CAL) * & - ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & - (K1_AQ * exp(ER1_AQ * & - ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) / & - 10.0e+00_r8**(-pH) + K2_AQ * exp(ER2_AQ * & - ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & - K298_HSO3_SO3 * exp((H298_HSO3_SO3 / R_CAL) * & - ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) / & - (10.0e+00_r8**(-pH))**2.0e+00_r8) ) * & - HENRY298_O3 * exp((H298_O3 / R_CAL) * & - ((1.0e+00_r8 / 298.0e+00_r8) - tinv(:))) * & - (R_CONC * temp(:ncol,k))**2.0e+00_r8 - endif - endif - - if ( has_d_chem ) then - - call comp_exp( exp_fac, -600._r8 * tinv, ncol ) - rxt(:,k,ean_ndx(1)) = 1.e-31_r8 * tp(:) * exp_fac(:) - rxt(:,k,ean_ndx(2)) = 9.1e-12_r8 * tp(:)**(-1.46_r8) - call comp_exp( exp_fac, -193._r8 * tinv, ncol ) - rxt(:,k,ean_ndx(3)) = (4.e-30_r8 * exp_fac(:)) * 0.21_r8 - - rxt(:,k,rpe_ndx(1)) = 4.2e-6_r8 * tp(:)**0.5_r8 - rxt(:,k,rpe_ndx(2)) = 6.3e-7_r8 * tp(:)**0.5_r8 - rxt(:,k,rpe_ndx(3)) = 2.5e-6_r8 * tp(:)**0.1_r8 - rxt(:,k,rpe_ndx(4)) = 2.48e-6_r8 * tp(:)**0.76_r8 - rxt(:,k,rpe_ndx(5)) = 1.4e-6_r8 * tp(:)**0.4_r8 - - rxt(:,k,pir_ndx(1)) = 4.e-30_r8 * tp(:)**2.93_r8 - rxt(:,k,pir_ndx(2)) = 4.6e-27_r8 * tp(:)**4._r8 - - call comp_exp( exp_fac, -15900._r8 * tinv, ncol ) - rxt(:,k,pir_ndx(3)) = (2.5e-2_r8 * tp(:)**5._r8) * exp_fac(:) - rxt(:,k,pir_ndx(4)) = 2.3e-27_r8 * tp(:)**7.5_r8 - - call comp_exp( exp_fac, -10272._r8 * tinv, ncol ) - rxt(:,k,pir_ndx(5)) = (2.6e-3_r8 * tp(:)**8.5_r8) * exp_fac(:) - rxt(:,k,pir_ndx(6)) = 3.6e-27_r8 * tp(:)**8.1_r8 - - call comp_exp( exp_fac, -9000._r8 * tinv, ncol ) - rxt(:,k,pir_ndx(7)) = (1.5e-1_r8 * tp(:)**9.1_r8) * exp_fac(:) - rxt(:,k,pir_ndx(8)) = 4.6e-28_r8 * tp(:)**14._r8 - - call comp_exp( exp_fac, -6400._r8 * tinv, ncol ) - rxt(:,k,pir_ndx(9)) = (1.7e-3_r8 * tp(:)**15._r8) * exp_fac(:) - rxt(:,k,pir_ndx(10)) = 1.35e-28_r8 * tp(:)**2.83_r8 - - rxt(:,k,pir_ndx(11)) = 1.e-27_r8 * (308._r8 * tinv(:))**4.7_r8 - rxt(:,k,pir_ndx(12)) = rxt(:,k,pir_ndx(11)) - rxt(:,k,pir_ndx(13)) = 1.4e-29_r8 * tp(:)**4._r8 - - call comp_exp( exp_fac, -3872._r8 * tinv, ncol ) - rxt(:,k,pir_ndx(14)) = (3.4e-7_r8 * tp(:)**5._r8) * exp_fac(:) - - rxt(:,k,pir_ndx(15)) = 3.0e-31_r8 * tp(:)**4.3_r8 - call comp_exp( exp_fac, -2093._r8 * tinv, ncol ) - rxt(:,k,pir_ndx(16)) = (1.5e-8_r8 * tp(:)**4.3_r8) * exp_fac(:) - - rxt(:,k,edn_ndx(1)) = 3.1e-10_r8 * tp(:)**0.83_r8 - call comp_exp( exp_fac, -4990._r8 * tinv, ncol ) - rxt(:,k,edn_ndx(2)) = (1.9e-12_r8 * tp(:)**(-1.5_r8)) * exp_fac(:) - - rxt(:,k,nir_ndx(1)) = 1.05e-12_r8 * tp(:)**2.15_r8 - rxt(:,k,nir_ndx(2)) = 2.5e-11_r8 * tp(:)**0.79_r8 - rxt(:,k,nir_ndx(3)) = 7.5e-11_r8 * tp(:)**0.79_r8 - rxt(:,k,nir_ndx(4)) = rxt(:,k,nir_ndx(1)) - rxt(:,k,nir_ndx(5)) = 1.3e-11_r8 * tp(:)**1.64_r8 - rxt(:,k,nir_ndx(6)) = 3.3e-11_r8 * tp(:)**2.38_r8 - - call comp_exp( exp_fac, -7300_r8 * tinv, ncol ) - rxt(:,k,nir_ndx(7)) = (1.0e-3_r8 * tp(:)) * exp_fac(:) - call comp_exp( exp_fac, -7050_r8 * tinv, ncol ) - rxt(:,k,nir_ndx(8)) = (7.2e-4_r8 * tp(:)) * exp_fac(:) - call comp_exp( exp_fac, -6800_r8 * tinv, ncol ) - rxt(:,k,nir_ndx(9)) = (6.5e-3_r8 * tp(:)) * exp_fac(:) - call comp_exp( exp_fac, -7600_r8 * tinv, ncol ) - rxt(:,k,nir_ndx(10)) = (5.7e-4_r8 * tp(:)) * exp_fac(:) - - call comp_exp( exp_fac, -7150_r8 * tinv, ncol ) - rxt(:,k,nir_ndx(11)) = (1.5e-2_r8 * tp(:)) * exp_fac(:) - - call comp_exp( exp_fac, -13130_r8 * tinv, ncol ) - rxt(:,k,nir_ndx(12)) = (6.0e-3_r8 * tp(:)) * exp_fac(:) - rxt(:,k,nir_ndx(13)) = 5.22e-28_r8 * tp(:)**2.62_r8 - - rxt(:,k,iira_ndx(1)) = 6.0e-8_r8 * tp(:)**.5_r8 - do i = 2,niira - rxt(:,k,iira_ndx(i)) = rxt(:,k,iira_ndx(i-1)) - enddo - - rxt(:,k,iirb_ndx(1)) = 1.25e-25_r8 * tp(:)**4._r8 - do i = 2,niirb - rxt(:,k,iirb_ndx(i)) = rxt(:,k,iirb_ndx(i-1)) - enddo - - call comp_exp( exp_fac, -6600._r8 * tinv, ncol ) - rxt(:,k,usr_clm_h2o_m_ndx) = 2.e-8_r8 * exp_fac(:) - - call comp_exp( exp_fac, -11926._r8 * tinv, ncol ) - rxt(:,k,usr_clm_hcl_m_ndx) = tinv(:) * exp_fac(:) - - endif - end do level_loop - -!----------------------------------------------------------------- -! ... the ionic rates -!----------------------------------------------------------------- - if ( has_ion_rxts ) then - level_loop2 : do k = 1,pver - tp(:ncol) = (2._r8*tempi(:ncol,k) + temp(:ncol,k)) / ( 3._r8 * t0 ) - tp(:) = max( min( tp(:),20._r8 ),1._r8 ) - rxt(:,k,ion1_ndx) = 2.82e-11_r8 + tp(:)*(-7.74e-12_r8 + tp(:)*(1.073e-12_r8 & - + tp(:)*(-5.17e-14_r8 + 9.65e-16_r8*tp(:)))) - tp(:ncol) = (.6363_r8*tempi(:ncol,k) + .3637_r8*temp(:ncol,k)) / t0 - tp(:) = max( min( tp(:),trlim2 ),1._r8 ) - rxt(:,k,ion2_ndx) = 1.533e-12_r8 + tp(:)*(-5.92e-13_r8 + tp(:)*8.6e-14_r8) - tp(:ncol) = 2._r8 * t0 /(tempi(:ncol,k) + temp(:ncol,k)) - where( tp(:ncol) < trlim3 ) - rxt(:,k,ion3_ndx) = 1.4e-10_r8 * tp(:)**.44_r8 - rxt(:,k,ion11_ndx) = 1.e-11_r8 * tp(:)**.23_r8 - elsewhere - rxt(:,k,ion3_ndx) = 5.2e-11_r8 / tp(:)**.2_r8 - rxt(:,k,ion11_ndx) = 3.6e-12_r8 / tp(:)**.41_r8 - end where - tp(:ncol) = t0 / tempe(:ncol,k) - rxt(:,k,elec1_ndx) = 4.e-7_r8 * tp(:)**.85_r8 - rxt(:,k,elec3_ndx) = 1.8e-7_r8 * tp(:)**.39_r8 - where( tp(:ncol) < 4._r8 ) - rxt(:,k,elec2_ndx) = 2.7e-7_r8 * tp(:)**.7_r8 - elsewhere - rxt(:,k,elec2_ndx) = 1.6e-7_r8 * tp(:)**.55_r8 - end where - end do level_loop2 - endif - - ! quenching of O+(2P) and O+(2D) by e to produce O+ - ! See TABLE 1 of Roble (1995) - ! drm 2015-07-27 - if (elec4_ndx > 0 .and. elec5_ndx > 0 .and. elec6_ndx > 0) then - do k=1,pver - tp(:ncol) = sqrt(300._r8 / tempe(:ncol,k)) - rxt(:,k,elec4_ndx) = 1.5e-7_r8 * tp(:) - rxt(:,k,elec5_ndx) = 4.0e-8_r8 * tp(:) - rxt(:,k,elec6_ndx) = 6.6e-8_r8 * tp(:) - end do - endif - -!----------------------------------------------------------------- -! ... tropospheric "aerosol" rate constants -!----------------------------------------------------------------- - if ( het1_ndx > 0 .AND. (.NOT. usr_N2O5_aer_ndx > 0) ) then - amas = 4._r8*pi*rm1**3*den/3._r8 ! each mean particle(r=0.1u) mass (g) - do k = 1,pver -!------------------------------------------------------------------------- -! ... estimate humidity effect on aerosols (from Shettle and Fenn, 1979) -! xr is a factor of the increase aerosol radii with hum (hum=0., factor=1) -!------------------------------------------------------------------------- - xr(:) = .999151_r8 + relhum(:ncol,k)*(1.90445_r8 + relhum(:ncol,k)*(-6.35204_r8 + relhum(:ncol,k)*5.32061_r8)) -!------------------------------------------------------------------------- -! ... estimate sulfate particles surface area (cm2/cm3) in each grid -!------------------------------------------------------------------------- - if ( carma_hetchem_feedback ) then - sur(:ncol) = strato_sad(:ncol,k) - else - sur(:) = sulfate(:,k)*m(:,k)/avo*wso4 & ! xform mixing ratio to g/cm3 - / amas & ! xform g/cm3 to num particels/cm3 - * fare & ! xform num particels/cm3 to cm2/cm3 - * xr(:)*xr(:) ! humidity factor - endif -!----------------------------------------------------------------- -! ... compute the "aerosol" reaction rates -!----------------------------------------------------------------- -! k = gam * A * velo/4 -! -! where velo = sqrt[ 8*bk*T/pi/(w/av) ] -! bk = 1.381e-16 -! av = 6.02e23 -! w = 108 (n2o5) HO2(33) CH2O (30) NH3(15) -! -! so that velo = 1.40e3*sqrt(T) (n2o5) gama=0.1 -! so that velo = 2.53e3*sqrt(T) (HO2) gama>0.2 -! so that velo = 2.65e3*sqrt(T) (CH2O) gama>0.022 -! so that velo = 3.75e3*sqrt(T) (NH3) gama=0.4 -!-------------------------------------------------------- -!----------------------------------------------------------------- -! ... use this n2o5 -> 2*hno3 only in tropopause -!----------------------------------------------------------------- - rxt(:,k,het1_ndx) = rxt(:,k,het1_ndx) & - +.25_r8 * gam1 * sur(:) * 1.40e3_r8 * sqrt( temp(:ncol,k) ) - end do - end if - -!lke++ -!----------------------------------------------------------------- -! ... CO tags -!----------------------------------------------------------------- - if( usr_CO_OH_b_ndx > 0 ) then - if( usr_COhc_OH_ndx > 0 ) then - rxt(:ncol,:,usr_COhc_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_COme_OH_ndx > 0 ) then - rxt(:ncol,:,usr_COme_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO01_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO01_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO02_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO02_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO03_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO03_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO04_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO04_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO05_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO05_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO06_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO06_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO07_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO07_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO08_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO08_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO09_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO09_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO10_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO10_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO11_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO11_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO12_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO12_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO13_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO13_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO14_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO14_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO15_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO15_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO16_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO16_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO17_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO17_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO18_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO18_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO19_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO19_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO20_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO20_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO21_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO21_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO22_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO22_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO23_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO23_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO24_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO24_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO25_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO25_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO26_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO26_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO27_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO27_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO28_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO28_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO29_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO29_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO30_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO30_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO31_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO31_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO32_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO32_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO33_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO33_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO34_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO34_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO35_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO35_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO36_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO36_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO37_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO37_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO38_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO38_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO39_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO39_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO40_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO40_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO41_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO41_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - if( usr_CO42_OH_ndx > 0 ) then - rxt(:ncol,:,usr_CO42_OH_ndx) = rxt(:ncol,:,usr_CO_OH_b_ndx) - end if - end if -!lke-- -! -! jfl : additional BAM removal reactions. Zero out below the tropopause -! - do l=1,num_strat_tau -! - if ( usr_strat_tau_ndx(l) > 0 ) then - do i=1,ncol - rxt(i,tropchemlev(i)+1:pver,usr_strat_tau_ndx(l)) = 0._r8 - end do - end if -! - end do -! - - deallocate( sfc_array, dm_array ) - - end subroutine usrrxt - - subroutine usrrxt_hrates( rxt, tempn, tempi, tempe, & - h2ovmr, m, ncol, kbot ) -!----------------------------------------------------------------- -! ... set the user specified reaction rates for heating -!----------------------------------------------------------------- - - use shr_kind_mod, only : r8 => shr_kind_r8 - use chem_mods, only : rxntot - use ppgrid, only : pver, pcols - - implicit none - -!----------------------------------------------------------------- -! ... dummy arguments -!----------------------------------------------------------------- - integer, intent(in) :: ncol ! number columns in chunk - integer, intent(in) :: kbot ! heating levels - real(r8), intent(in) :: tempn(pcols,pver) ! neutral temperature (K) - real(r8), intent(in) :: tempi(pcols,pver) ! ion temperature (K) - real(r8), intent(in) :: tempe(pcols,pver) ! electron temperature (K) - real(r8), intent(in) :: m(ncol,pver) ! total atm density (1/cm^3) - real(r8), intent(in) :: h2ovmr(ncol,pver) ! water vapor (vmr) - real(r8), intent(inout) :: rxt(ncol,pver,rxntot) ! gas phase rates - -!----------------------------------------------------------------- -! ... local variables -!----------------------------------------------------------------- - - integer :: k - real(r8), dimension(ncol) :: & - tp, & - tinv, & - ko, & - kinf, & - fc - -!----------------------------------------------------------------- -! ... o + o2 + m --> o3 + m -!----------------------------------------------------------------- - do k = 1,kbot - tinv(:ncol) = 1._r8 / tempn(:ncol,k) - tp(:) = 300._r8 * tinv(:) - rxt(:,k,usr_O_O2_ndx) = 6.e-34_r8 * tp(:)**2.4_r8 - -!----------------------------------------------------------------- -! ... o + o + m -> o2 + m -!----------------------------------------------------------------- - rxt(:,k,usr_O_O_ndx) = 2.76e-34_r8 * exp( 720.0_r8*tinv(:) ) - -!----------------------------------------------------------------- -! ... ho2 + ho2 --> h2o2 -! Note: this rate involves the water vapor number density -!----------------------------------------------------------------- - ko(:) = 3.0e-13_r8 * exp( 460._r8*tinv(:) ) - kinf(:) = 2.1e-33_r8 * m(:,k) * exp( 920._r8*tinv(:) ) - fc(:) = 1._r8 + 1.4e-21_r8 * m(:,k) * h2ovmr(:,k) * exp( 2200._r8*tinv(:) ) - rxt(:,k,usr_HO2_HO2_ndx) = (ko(:) + kinf(:)) * fc(:) - - end do - -!----------------------------------------------------------------- -! ... the ionic rates -!----------------------------------------------------------------- - if ( has_ion_rxts ) then - level_loop2 : do k = 1,kbot - tp(:ncol) = (2._r8*tempi(:ncol,k) + tempn(:ncol,k)) / ( 3._r8 * t0 ) - tp(:) = max( min( tp(:),20._r8 ),1._r8 ) - rxt(:,k,ion1_ndx) = 2.82e-11_r8 + tp(:)*(-7.74e-12_r8 + tp(:)*(1.073e-12_r8 & - + tp(:)*(-5.17e-14_r8 + 9.65e-16_r8*tp(:)))) - tp(:ncol) = (.6363_r8*tempi(:ncol,k) + .3637_r8*tempn(:ncol,k)) / t0 - tp(:) = max( min( tp(:),trlim2 ),1._r8 ) - rxt(:,k,ion2_ndx) = 1.533e-12_r8 + tp(:)*(-5.92e-13_r8 + tp(:)*8.6e-14_r8) - tp(:ncol) = 2._r8 * t0 /(tempi(:ncol,k) + tempn(:ncol,k)) - where( tp(:ncol) < trlim3 ) - rxt(:,k,ion3_ndx) = 1.4e-10_r8 * tp(:)**.44_r8 - elsewhere - rxt(:,k,ion3_ndx) = 5.2e-11_r8 / tp(:)**.2_r8 - endwhere - tp(:ncol) = t0 / tempe(:ncol,k) - rxt(:,k,elec1_ndx) = 4.e-7_r8 * tp(:)**.85_r8 - rxt(:,k,elec3_ndx) = 1.8e-7_r8 * tp(:)**.39_r8 - where( tp(:ncol) < 4._r8 ) - rxt(:,k,elec2_ndx) = 2.7e-7_r8 * tp(:)**.7_r8 - elsewhere - rxt(:,k,elec2_ndx) = 1.6e-7_r8 * tp(:)**.55_r8 - endwhere - end do level_loop2 - endif - end subroutine usrrxt_hrates - -!------------------------------------------------------------------------- -!------------------------------------------------------------------------- - subroutine comp_exp( x, y, n ) - - implicit none - - real(r8), intent(out) :: x(:) - real(r8), intent(in) :: y(:) - integer, intent(in) :: n - - x(:n) = exp( y(:n) ) - - end subroutine comp_exp - - !------------------------------------------------------------------------- - ! Heterogeneous reaction rates for uptake of a gas on an aerosol: - !------------------------------------------------------------------------- - function hetrxtrate( sfc, dm_aer, dg_gas, c_gas, gamma_gas ) result(rate) - - real(r8), intent(in) :: sfc(:) - real(r8), intent(in) :: dm_aer(:) - real(r8), intent(in) :: dg_gas - real(r8), intent(in) :: c_gas - real(r8), intent(in) :: gamma_gas - real(r8) :: rate - - real(r8),allocatable :: rxt(:) - integer :: n, i - - n = size(sfc) - - allocate(rxt(n)) - do i=1,n - rxt(i) = sfc(i) / (0.5_r8*dm_aer(i)/dg_gas + (4._r8/(c_gas*gamma_gas))) - enddo - - rate = sum(rxt) - - deallocate(rxt) - - endfunction hetrxtrate - - !------------------------------------------------------------------------- - ! Heterogeneous reaction rates for uptake of a glyoxal gas on an aerosol: - !------------------------------------------------------------------------- - function hetrxtrate_gly( sfc, c_gas, gamma_gas ) result(rate) - - real(r8), intent(in) :: sfc(:) - real(r8), intent(in) :: c_gas - real(r8), intent(in) :: gamma_gas - real(r8) :: rate - - real(r8),allocatable :: rxt(:) - integer :: n, i - - n = size(sfc) - - allocate(rxt(n)) - do i=1,n - rxt(i) = 0.25_r8 * c_gas * sfc(i) * gamma_gas - enddo - - rate = sum(rxt) - - deallocate(rxt) - - endfunction hetrxtrate_gly - - -end module mo_usrrxt From dea7325b8a62b8b16ed7ef8b391613cb41844249 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 1 Sep 2023 16:01:48 +0200 Subject: [PATCH 37/71] updates for ocean and seasalt --- src/NorESM/physpkg.F90 | 4 +- src/chemistry/mozart/mo_drydep.F90 | 3 + src/chemistry/mozart/mo_neu_wetdep.F90 | 157 +- src/chemistry/mozart/mo_srf_emissions.F90 | 20 + src/chemistry/oslo_aero/aero_model.F90 | 6 +- src/chemistry/oslo_aero/oslo_aero_ocean.F90 | 342 ++ src/chemistry/oslo_aero/oslo_aero_seasalt.F90 | 40 +- src/chemistry/oslo_aero/oslo_ocean_intr.F90 | 375 -- src/physics/cam_oslo/mo_drydep.F90 | 3303 ----------------- src/physics/cam_oslo/mo_neu_wetdep.F90 | 1793 --------- src/physics/cam_oslo/mo_srf_emissions.F90 | 463 --- 11 files changed, 482 insertions(+), 6024 deletions(-) create mode 100644 src/chemistry/oslo_aero/oslo_aero_ocean.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_ocean_intr.F90 delete mode 100644 src/physics/cam_oslo/mo_drydep.F90 delete mode 100644 src/physics/cam_oslo/mo_neu_wetdep.F90 delete mode 100644 src/physics/cam_oslo/mo_srf_emissions.F90 diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index af5fcda0ee..0cce4c67e1 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -2486,7 +2486,7 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) use iop_forcing, only: scam_use_iop_srf use nudging, only: Nudge_Model, nudging_timestep_init ! OSLO_AERO beg - use oslo_ocean_intr, only: oslo_ocean_time + use oslo_aero_ocean, only: oslo_aero_ocean_time ! OSLO_AERO end implicit none @@ -2523,7 +2523,7 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) call prescribed_volcaero_adv(phys_state, pbuf2d) call prescribed_strataero_adv(phys_state, pbuf2d) ! OSLO_AERO beg - call oslo_ocean_time(phys_state, pbuf2d) + call oslo_aero_ocean_time(phys_state, pbuf2d) ! OSLO_AERO end ! prescribed aerosol deposition fluxes diff --git a/src/chemistry/mozart/mo_drydep.F90 b/src/chemistry/mozart/mo_drydep.F90 index 9241af802e..e81f3d66f7 100644 --- a/src/chemistry/mozart/mo_drydep.F90 +++ b/src/chemistry/mozart/mo_drydep.F90 @@ -1616,6 +1616,9 @@ subroutine dvel_inti_xactive( depvel_lnd_file, clim_soilw_file, season_wes_file ! determine if modal aerosols are active so that fraction_landuse array is initialized for modal aerosal dry dep call phys_getopts(prog_modal_aero_out=prog_modal_aero) +#ifdef OSLO_AERO + prog_modal_aero = .TRUE. +#endif call dvel_inti_fromlnd() diff --git a/src/chemistry/mozart/mo_neu_wetdep.F90 b/src/chemistry/mozart/mo_neu_wetdep.F90 index b187b83e69..4238271eaa 100644 --- a/src/chemistry/mozart/mo_neu_wetdep.F90 +++ b/src/chemistry/mozart/mo_neu_wetdep.F90 @@ -14,6 +14,10 @@ module mo_neu_wetdep use cam_abortutils, only : endrun use seq_drydep_mod, only : n_species_table, species_name_table, dheff use gas_wetdep_opts, only : gas_wetdep_method, gas_wetdep_list, gas_wetdep_cnt +#ifdef OSLO_AERO + use mo_constants, only: rgrav + use phys_control, only: phys_getopts +#endif ! implicit none ! @@ -89,7 +93,7 @@ subroutine neu_wetdep_init select case( trim(test_name) ) ! ! CCMI: added SO2t and NH_50W -! +! case( 'HYAC', 'CH3COOH' , 'HCOOH', 'EOOH', 'IEPOX' ) test_name = 'CH2O' case ( 'SOGB','SOGI','SOGM','SOGT','SOGX' ) @@ -98,10 +102,10 @@ subroutine neu_wetdep_init test_name = 'SO2' case ( 'CLONO2','BRONO2','HCL','HOCL','HOBR','HBR', 'Pb', 'MACROOH', 'ISOPOOH', 'XOOH', 'H2SO4', 'HF', 'COF2', 'COFCL') test_name = 'HNO3' - case ( 'NH_50W', 'NDEP', 'NHDEP', 'NH4', 'NH4NO3' ) + case ( 'NH_50W', 'NDEP', 'NHDEP', 'NH4', 'NH4NO3' ) test_name = 'HNO3' case ( 'ALKOOH', 'MEKOOH', 'TOLOOH' ) - test_name = 'CH3OOH' + test_name = 'CH3OOH' case( 'PHENOOH', 'BENZOOH', 'C6H5OOH', 'BZOOH', 'XYLOLOOH', 'XYLENOOH', 'HPALD' ) test_name = 'CH3OOH' case( 'TERPOOH', 'TERP2OOH', 'MBOOOH' ) @@ -115,15 +119,15 @@ subroutine neu_wetdep_init case( 'NC4CHO', 'NC4CH2OH', 'TERPNIT', 'NTERPOOH' ) test_name = 'H2O2' case( 'SOAGbb0' ) ! Henry's Law coeff. added for VBS SOA's, biomass burning is the same as fossil fuels - test_name = 'SOAGff0' + test_name = 'SOAGff0' case( 'SOAGbb1' ) - test_name = 'SOAGff1' + test_name = 'SOAGff1' case( 'SOAGbb2' ) - test_name = 'SOAGff2' + test_name = 'SOAGff2' case( 'SOAGbb3' ) - test_name = 'SOAGff3' + test_name = 'SOAGff3' case( 'SOAGbb4' ) - test_name = 'SOAGff4' + test_name = 'SOAGff4' end select ! do l = 1,n_species_table @@ -154,7 +158,7 @@ subroutine neu_wetdep_init end if ! end do - + if (any ( mapping_to_heff(:) == -99 )) call endrun('mo_neu_wet->depwetdep_init: unmapped species error' ) ! if ( debug ) then @@ -227,7 +231,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & prain, nevapr, cld, cmfdqr, wd_tend, wd_tend_int) ! use ppgrid, only : pcols, pver -!!DEK +!!DEK use phys_grid, only : get_area_all_p, get_rlat_all_p use shr_const_mod, only : SHR_CONST_REARTH,SHR_CONST_G use cam_history, only : outfld @@ -276,6 +280,13 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & !!DEK real(r8) :: pi real(r8) :: lats(pcols) + +#ifdef OSLO_AERO + real(r8) :: wrk_wd(pcols) + logical history_aerosol +#endif + +call phys_getopts( history_aerosol_out = history_aerosol) ! ! from cam/src/physics/cam/stratiform.F90 ! @@ -340,7 +351,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & do k=pver-1,1,-1 rls (:,k) = max(0._r8,totprec(:,k)-totevap(:,k)+rls(:,k+1)) !evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+totprec(:,k)+1.e-36_r8)) - evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+1.e-36_r8)) + evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+1.e-36_r8)) end do ! ! compute effective Henry's law coefficients @@ -434,7 +445,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & ! tendency calculation (on model grid) ! dtwr(1:ncol,:,:) = wd_mmr(1:ncol,:,:) - dtwr(1:ncol,:,:) - dtwr(1:ncol,:,:) = dtwr(1:ncol,:,:) / delt + dtwr(1:ncol,:,:) = dtwr(1:ncol,:,:) / delt !!DEK polarward of 60S, 60N and <200hPa set to zero! call get_rlat_all_p(lchnk, pcols, lats ) @@ -443,7 +454,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & if ( abs( lats(i)*180._r8/pi ) > 60._r8 ) then if ( pmid(i,k) < 20000._r8) then dtwr(i,k,:) = 0._r8 - endif + endif endif end do end do @@ -453,7 +464,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & do m=1,gas_wetdep_cnt wd_tend(1:ncol,:,mapping_to_mmr(m)) = wd_tend(1:ncol,:,mapping_to_mmr(m)) + dtwr(1:ncol,:,m) call outfld( 'DTWR_'//trim(gas_wetdep_list(m)),dtwr(:,:,m),ncol,lchnk ) - + call outfld( 'HEFF_'//trim(gas_wetdep_list(m)),heff(:,pver:1:-1,m),ncol,lchnk ) ! ! vertical integrated wet deposition rate [kg/m2/s] @@ -471,6 +482,22 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & wd_tend_int(1:ncol,mapping_to_mmr(m)) = wk_out(1:ncol) ! end do + +!This is output normally in mo_chm_diags, but +!if neu wetdep, we have to output it here! +#ifdef OSLO_AERO + if(history_aerosol)then + do m=1,gas_wetdep_cnt + wrk_wd(:ncol) = 0.0_r8 + do k=1,pver + !Note sign: tendency is negative, so this becomes a positive flux! + wrk_wd(:ncol) = wrk_wd(:ncol) & + - wd_tend(1:ncol,k,mapping_to_mmr(m))*pdel(:ncol,k)*rgrav !kg/m2/sec + end do + call outfld('WD_A_'//trim(gas_wetdep_list(m)),wrk_wd(:ncol),ncol,lchnk) + end do + end if +#endif ! if ( do_diag ) then call outfld('QT_RAIN_HNO3', qt_rain, ncol, lchnk ) @@ -504,14 +531,14 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & !-LAER could be used as LWASHTYP !---WILL THIS WORK FOR T42->T21??????????? !----------------------------------------------------------------------- - + integer LPAR, NTRACE real(r8), intent(inout) :: QTTJFL(LPAR,NTRACE) real(r8), intent(in) :: DTSCAV, QM(LPAR),POFL(LPAR),DELZ(LPAR),GAREA real(r8), intent(in) :: RLS(LPAR),CLWC(LPAR),CIWC(LPAR),CFR(LPAR),TEM(LPAR), & EVAPRATE(LPAR) real(r8), intent(in) :: HSTAR(LPAR,NTRACE),TCMASS(NTRACE) - logical , intent(in) :: TCKAQB(NTRACE),TCNION(NTRACE) + logical , intent(in) :: TCKAQB(NTRACE),TCNION(NTRACE) ! real(r8), intent(inout) :: qt_rain(lpar) real(r8), intent(inout) :: qt_rime(lpar) @@ -546,7 +573,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & real(r8) QTNETLCXA,QTNETLCXB,QTNETLAX,QTNETL real(r8) QTDISSTAR - + real(r8), parameter :: CFMIN=0.1_r8 real(r8), parameter :: CWMIN=1.0e-5_r8 @@ -599,9 +626,9 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & end if !----------------------------------------------------------------------- - LE = LPAR-1 + LE = LPAR-1 ! - rls_flag(1:le) = rls(1:le) > zero + rls_flag(1:le) = rls(1:le) > zero freezing(1:le) = tem(1:le) < tice rlsog(1:le) = rls(1:le)/garea ! @@ -698,7 +725,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & QTWASHCXA = zero QTRAINCXA = zero QTRAINCXB = zero - + RAMPCT = zero RCXPCT = zero @@ -866,7 +893,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & endif !----------------------------------------------------------------------- ! If there is some in-cloud precip left, we have new precip formation -! Will be spread over whole cloud fraction +! Will be spread over whole cloud fraction !----------------------------------------------------------------------- ! Calculate precip rate in old and new cloud fractions !----------------------------------------------------------------------- @@ -922,14 +949,14 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & if( is_hno3 .and. l >= 15 ) then write(*,*) ' ' write(*,*) 'washout: rca,rcxa,deltarime,dor,rprecip,dnew @ l = ',l - write(*,'(1p,6g15.7)') rca,rcxa,deltarime,dor,rprecip,dnew + write(*,'(1p,6g15.7)') rca,rcxa,deltarime,dor,rprecip,dnew write(*,*) 'washout: dcxa,dcxb,wemp,remp,demp' write(*,'(1p,5g15.7)') dcxa,dcxb,wemp,remp,demp write(*,*) ' ' end if endif - if( QTT(L) > zero ) then + if( QTT(L) > zero ) then !----------------------------------------------------------------------- ! ICE SCAVENGING !----------------------------------------------------------------------- @@ -962,11 +989,11 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & endif endif !----------------------------------------------------------------------- -! For ice, accretion removal for hno3 and aerosols is propotional to riming, +! For ice, accretion removal for hno3 and aerosols is propotional to riming, ! no accretion removal for gases ! remove only in mixed portion of cloud ! Limit DELTARIMEMASS to RNEW*DTSCAV for ice - evaporation of rimed ice to match -! RNEW precip rate would result in HNO3 escaping from ice (no trapping) +! RNEW precip rate would result in HNO3 escaping from ice (no trapping) !----------------------------------------------------------------------- if( DELTARIME > zero ) then if( LICETYP == 1 ) then @@ -978,7 +1005,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & QTCXA = QTT(L)*FCXA call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTCXA, QTDISRIME ) + QM(L), QTCXA, QTDISRIME ) QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) if ( debug ) then if( is_hno3 .and. l >= 15 ) then @@ -990,9 +1017,9 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & endif QTRIMECXA = QTCXA* & (one - exp((-COLEFFSNOW/(DCA*1.e-3_r8))* & - (RCA/(2._r8*RHOSNOW))* & !uses GBA R + (RCA/(2._r8*RHOSNOW))* & !uses GBA R (QTDISSTAR/QTCXA)*DTSCAV)) - QTRIMECXA = min( QTRIMECXA, & + QTRIMECXA = min( QTRIMECXA, & ((RNEW*GAREA*DTSCAV)/(CLWX*QM(L)*(FCXA/CFXX(L))))*QTDISSTAR) elseif( LICETYP == 2 ) then QTRIMECXA = zero @@ -1031,13 +1058,13 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & DELTARIME = zero endif !----------------------------------------------------------------------- -! If there is some in-cloud precip left, we have new precip formation +! If there is some in-cloud precip left, we have new precip formation !----------------------------------------------------------------------- RPRECIP = (RNEW-(DELTARIME*FCXA))/CFXX(L) !GBA RCXA = RCA + DELTARIME + RPRECIP !kg/m2/s GBA RCXB = RPRECIP !kg/m2/s GBA - DCXA = FOUR + DCXA = FOUR if( FCXB > zero ) then DCXB = FOUR else @@ -1080,8 +1107,8 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) QTRIMECXA = QTCXA* & (one - exp(-0.24_r8*COLEFFRAIN* & - ((RCA)**0.75_r8)* & !local - (QTDISSTAR/QTCXA)*DTSCAV)) + ((RCA)**0.75_r8)* & !local + (QTDISSTAR/QTCXA)*DTSCAV)) QTRIMECXA = min( QTRIMECXA, & ((RNEW*GAREA*DTSCAV)/(CLWX*QM(L)*(FCXA/CFXX(L))))*QTDISSTAR) else @@ -1169,14 +1196,14 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & RAXADJ = RAXADJF/FAXADJ else RAXADJ = zero - endif + endif else RAXADJ = zero RAMPCT = zero FAXADJ = zero endif endif - + QTEVAPAXP = min( QTTOPAA,QTTOPAA - (RAMPCT*(QTTOPAA-QTEVAPAXP)) ) FAX = FAXADJ RAX = RAXADJ @@ -1206,9 +1233,9 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & ! T>Tmix, hno3&aerosols are incorporated into ice structure: ! do not release ! For rain, assume full evaporation of some raindrops -! proportional evaporation for all species -! washout for gases using Rbot -! impact washout for hno3/aerosol portion in gas phase +! proportional evaporation for all species +! washout for gases using Rbot +! impact washout for hno3/aerosol portion in gas phase !----------------------------------------------------------------------- ! if (TEM(L) < TICE ) then is_freezing_a : & @@ -1228,7 +1255,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & else QTEVAPCXA = zero endif - elseif( LICETYP == 2 ) then + elseif( LICETYP == 2 ) then QTEVAPCXA = zero endif else is_freezing_a @@ -1292,7 +1319,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & !----------------------------------------------------------------------- ! END SCAVENGING -! Require CF if our ambient evaporation rate would give less +! Require CF if our ambient evaporation rate would give less ! precip than R from model. !----------------------------------------------------------------------- if( do_diag .and. is_hno3 ) then @@ -1393,16 +1420,16 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & write(*,*) ' ' endif endif - + if (RCA > zero) then - DCA = (RCXA*FCXA*CLOLDPCT)/(RCA*FCA)*DCXA + & + DCA = (RCXA*FCXA*CLOLDPCT)/(RCA*FCA)*DCXA + & (RCXB*FCXB*CLNEWPCT)/(RCA*FCA)*DCXB + & (RAX*FAX*AMCLPCT)/(RCA*FCA)*DAX else DCA = zero FCA = zero endif - + else FCA = zero DCA = zero @@ -1472,13 +1499,13 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & !----------------------------------------------------------------------- QTNETLCXA = QTRAINCXA + QTRIMECXA + QTWASHCXA - QTEVAPCXA QTNETLCXA = min( QTT(L)*FCXA,QTNETLCXA ) - + QTNETLCXB =QTRAINCXB QTNETLCXB = min( QTT(L)*FCXB,QTNETLCXB ) QTNETLAX = QTWASHAX - QTEVAPAX QTNETLAX = min( QTT(L)*FAX,QTNETLAX ) - + QTTNEW(L) = QTT(L) - (QTNETLCXA + QTNETLCXB + QTNETLAX) if( do_diag .and. is_hno3 ) then @@ -1572,7 +1599,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & endif endif !----------------------------------------------------------------------- -! reload new tracer mass and rescale moments: check upper limits (LE) +! reload new tracer mass and rescale moments: check upper limits (LE) !----------------------------------------------------------------------- QTTJFL(:le,N) = QTTNEW(:le) @@ -1584,15 +1611,15 @@ end subroutine washo subroutine DISGAS (CLWX,CFX,MOLMASS,HSTAR,TM,PR,QM,QT,QTDIS) !--------------------------------------------------------------------- implicit none - real(r8), intent(in) :: CLWX,CFX !cloud water,cloud fraction + real(r8), intent(in) :: CLWX,CFX !cloud water,cloud fraction real(r8), intent(in) :: MOLMASS !molecular mass of tracer real(r8), intent(in) :: HSTAR !Henry's Law coeffs A*exp(-B/T) real(r8), intent(in) :: TM !temperature of box (K) real(r8), intent(in) :: PR !pressure of box (hPa) real(r8), intent(in) :: QM !air mass in box (kg) real(r8), intent(in) :: QT !tracer in box (kg) - real(r8), intent(out) :: QTDIS !tracer dissolved in aqueous phase - + real(r8), intent(out) :: QTDIS !tracer dissolved in aqueous phase + real(r8) MUEMP real(r8), parameter :: INV298 = 1._r8/298._r8 real(r8), parameter :: TMIX=258._r8 @@ -1620,10 +1647,10 @@ end subroutine DISGAS subroutine RAINGAS (RRAIN,DTSCAV,CLWX,CFX,QM,QT,QTDIS,QTRAIN) !----------------------------------------------------------------------- !---New trace-gas rainout from large-scale precip with two time scales, -!---one based on precip formation from cloud water and one based on +!---one based on precip formation from cloud water and one based on !---Henry's Law solubility: correct limit for delta-t -!--- -!---NB this code does not consider the aqueous dissociation (eg, C-q) +!--- +!---NB this code does not consider the aqueous dissociation (eg, C-q) !--- that makes uptake of HNO3 and H2SO4 so complete. To do so would !--- require that we keep track of the pH of the falling rain. !---THUS the Henry's Law coefficient KHA needs to be enhanced to incldue this! @@ -1637,9 +1664,9 @@ subroutine RAINGAS (RRAIN,DTSCAV,CLWX,CFX,QM,QT,QTDIS,QTRAIN) real(r8), intent(in) :: DTSCAV !time step (s) real(r8), intent(in) :: CLWX,CFX !cloud water and cloud fraction real(r8), intent(in) :: QM !air mass in box (kg) - real(r8), intent(in) :: QT !tracer in box (kg) - real(r8), intent(in) :: QTDIS !tracer in aqueous phase (kg) - real(r8), intent(out) :: QTRAIN !tracer picked up by new rain + real(r8), intent(in) :: QT !tracer in box (kg) + real(r8), intent(in) :: QTDIS !tracer in aqueous phase (kg) + real(r8), intent(out) :: QTRAIN !tracer picked up by new rain real(r8) QTLF,QTDISSTAR @@ -1648,12 +1675,12 @@ subroutine RAINGAS (RRAIN,DTSCAV,CLWX,CFX,QM,QT,QTDIS,QTRAIN) QTDISSTAR=(QTDIS*(QT*CFX))/(QTDIS+(QT*CFX)) - + !---Tracer Loss frequency (1/s) within cloud fraction: QTLF = (RRAIN*QTDISSTAR)/(CLWX*QM*QT*CFX) -!---in time = DTSCAV, the amount of QTT scavenged is calculated -!---from CF*AMOUNT OF UPTAKE +!---in time = DTSCAV, the amount of QTT scavenged is calculated +!---from CF*AMOUNT OF UPTAKE QTRAIN = QT*CFX*(1._r8 - exp(-DTSCAV*QTLF)) return @@ -1667,7 +1694,7 @@ subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & !---for most gases below-cloud washout assume Henry-Law equilib with precip !---assumes that precip is liquid, if frozen, do not call this sub !---since solubility is moderate, fraction of box with rain does not matter -!---NB this code does not consider the aqueous dissociation (eg, C-q) +!---NB this code does not consider the aqueous dissociation (eg, C-q) !--- that makes uptake of HNO3 and H2SO4 so complete. To do so would !--- require that we keep track of the pH of the falling rain. !---THUS the Henry's Law coefficient KHA needs to be enhanced to incldue this! @@ -1678,7 +1705,7 @@ subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & real(r8), intent(in) :: RWASH ! precip leaving bottom of box (kg/s) real(r8), intent(in) :: BOXF ! fraction of box with washout real(r8), intent(in) :: DTSCAV ! time step (s) - real(r8), intent(in) :: QTRTOP ! tracer-T in rain entering top of box + real(r8), intent(in) :: QTRTOP ! tracer-T in rain entering top of box ! over time step (kg) real(r8), intent(in) :: HSTAR ! Henry's Law coeffs A*exp(-B/T) real(r8), intent(in) :: TM ! temperature of box (K) @@ -1687,7 +1714,7 @@ subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & real(r8), intent(in) :: QM ! air mass in box (kg) real(r8), intent(out) :: QTWASH ! tracer picked up by precip (kg) real(r8), intent(out) :: QTEVAP ! tracer evaporated from precip (kg) - + real(r8), parameter :: INV298 = 1._r8/298._r8 real(r8) :: FWASH, QTMAX, QTDIF @@ -1720,7 +1747,7 @@ subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & QTWASH = 0._r8 QTEVAP = QTRTOP - QTMAX endif - + return end subroutine WASHGAS @@ -1730,14 +1757,14 @@ function DEMPIRICAL (CWATER,RRATE) use shr_spfn_mod, only: shr_spfn_gamma implicit none - real(r8), intent(in) :: CWATER + real(r8), intent(in) :: CWATER real(r8), intent(in) :: RRATE real(r8) :: DEMPIRICAL - + real(r8) RRATEX,WX,THETA,PHI,ETA,BETA,ALPHA,BEE real(r8) GAMTHETA,GAMBETA - + RRATEX=RRATE*3600._r8 !mm/hr @@ -1757,7 +1784,7 @@ function DEMPIRICAL (CWATER,RRATE) GAMBETA = shr_spfn_gamma(BETA+1._r8) DEMPIRICAL=(((WX*ETA*GAMTHETA)/(1.0e6_r8*ALPHA*PHI*GAMBETA))** & (-1._r8/BEE))*10._r8 ! in mm (wx/1e6 for cgs) - + return end function DEMPIRICAL diff --git a/src/chemistry/mozart/mo_srf_emissions.F90 b/src/chemistry/mozart/mo_srf_emissions.F90 index f1cc056d9c..722ee0997b 100644 --- a/src/chemistry/mozart/mo_srf_emissions.F90 +++ b/src/chemistry/mozart/mo_srf_emissions.F90 @@ -12,6 +12,9 @@ module mo_srf_emissions use ppgrid, only : pcols, begchunk, endchunk use cam_logfile, only : iulog use tracer_data, only : trfld,trfile +#ifdef OSLO_AERO + use oslo_aero_ocean, only: oslo_aero_dms_inq +#endif implicit none @@ -39,6 +42,9 @@ module mo_srf_emissions type(emission), allocatable :: emissions(:) integer :: n_emis_files integer :: c10h16_ndx, isop_ndx +#ifdef OSLO_AERO + integer :: dms_ndx +#endif contains @@ -257,6 +263,10 @@ subroutine srf_emissions_inti( srf_emis_specifier, emis_type_in, emis_cycle_yr, c10h16_ndx = get_spc_ndx('C10H16') isop_ndx = get_spc_ndx('ISOP') +#ifdef OSLO_AERO + dms_ndx = get_spc_ndx('DMS') +#endif + end subroutine srf_emissions_inti subroutine set_srf_emissions_time( pbuf2d, state ) @@ -373,6 +383,16 @@ subroutine set_srf_emissions( lchnk, ncol, sflx ) declination = dec_max * cos((doy_loc - 172._r8)*twopi/dayspy) tod = (calday - doy_loc) + .5_r8 +#ifdef OSLO_AERO + ! Remove DMS emissions if option is not "from file" + ! Online emissions are treated in seasalt module + if (.not. oslo_aero_dms_inq()) then ! Returns "True" if "emissions from file" + if (dms_ndx .gt. 0)then + sflx(:,dms_ndx) = 0.0_r8 + end if + end if +#endif + do i = 1,ncol ! polar_day = .false. diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 810d610d67..a2ebbf6d97 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -39,7 +39,7 @@ module aero_model use oslo_aero_interp_log, only: initlogn use oslo_aero_seasalt, only: oslo_aero_seasalt_init, oslo_aero_seasalt_emis, seasalt_active use oslo_aero_dust, only: oslo_aero_dust_init, oslo_aero_dust_emis, dust_active - use oslo_ocean_intr, only: oslo_ocean_init, oslo_dms_emis_intr + use oslo_aero_ocean, only: oslo_aero_ocean_init, oslo_aero_dms_emis use oslo_aero_sw_tables, only: initopt, initopt_lw use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers @@ -162,7 +162,7 @@ subroutine aero_model_init( pbuf2d ) call initlogn call initopt_lw call initializeCondensation() - call oslo_ocean_init() + call oslo_aero_ocean_init() call oslo_aero_depos_init(pbuf2d) call oslo_aero_dust_init() call oslo_aero_seasalt_init() !seasalt_emis_scale) @@ -598,7 +598,7 @@ subroutine aero_model_emissions( state, cam_in ) endif !Pick up correct DMS emissions (replace values from file if requested) - call oslo_dms_emis_intr(state, cam_in) + call oslo_aero_dms_emis(state, cam_in) end subroutine aero_model_emissions diff --git a/src/chemistry/oslo_aero/oslo_aero_ocean.F90 b/src/chemistry/oslo_aero/oslo_aero_ocean.F90 new file mode 100644 index 0000000000..c2a5a135ec --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_aero_ocean.F90 @@ -0,0 +1,342 @@ +module oslo_aero_ocean + + !------------------------------------------------------------------- + ! Marine DMS and POM emissions module + ! Documentation: Implementation of interactive DMS and marine organic + ! emission schemes in NorESM2, Lewinschal, 2015 + ! Manages reading and interpolation of ocean tracer concentrations from file + ! and calculates DMS and marine POM emissions. + ! Parameterisations available: + ! - Nightingale et al. Global biogeochemical cycles 2000 (DMS) + ! - Nilsson, unpublished (POM) + ! - O'Dowd et al. GRL 2008 (POM) + ! - Based on prescribed_volcaero created by Francis Vitt and mo_srf_emissions + !------------------------------------------------------------------- + + use shr_kind_mod, only : r8 => shr_kind_r8 + use ppgrid, only : pcols, pver, pverp, begchunk, endchunk + use constituents, only : cnst_get_ind, cnst_mw !molecular weight for physics constituents + use spmd_utils, only : masterproc + use cam_abortutils, only : endrun + use cam_logfile, only : iulog + use cam_history, only : addfld, add_default, horiz_only, outfld + use camsrfexch, only : cam_in_t + use physics_types, only : physics_state + use physics_buffer, only : physics_buffer_desc + use tracer_data, only : trfld, trfile, trcdata_init, advance_trcdata + ! + use oslo_control, only: oslo_getopts + + implicit none + private + + type :: oceanspc + character(len=16) :: species(1) ! Species name + type(trfld), pointer :: fields(:) ! where the data ends up fields%data + type(trfile) :: file + end type oceanspc + + type(oceanspc), allocatable :: oceanspcs(:) + + ! Public interfaces + public :: oslo_aero_ocean_init ! initializing, reading file + public :: oslo_aero_ocean_time ! time interpolation + public :: oslo_aero_dms_emis ! calculate dms surface emissions + public :: oslo_aero_dms_inq ! logical function which tells mo_srf_emis what to do + public :: oslo_aero_opom_emis ! calculate opom surface emissions + public :: oslo_aero_opom_inq ! logical function which tells oslo_salt what to do + + ! Private interfaces + private:: oslo_aero_ocean_getnl + + + ! These variables are settable via the namelist (with longer names) + ! For reading concentration file + character(len=16) :: dmsl_fld_name = 'dms' !not set from namelist, hard coded, name of nc var + character(len=16) :: dmsk_fld_name = 'dms_Kettle' !not set from namelist, hard coded, name of nc var + character(len=32) :: dms_data_type = 'CYCLICAL' !will be collected from NAMELIST + integer :: dms_cycle_yr = 0 !will be collected from NAMELIST + character(len=20) :: dms_source = 'emission_file' !will be collected from NAMELIST + ! + character(len=16) :: opomo_fld_name = 'chlor_a' !not set from namelist, hard coded, name of nc var + character(len=16) :: opomn_fld_name = 'poc' !not set from namelist, hard coded, name of nc var + character(len=32) :: opom_data_type= 'CYCLICAL' !will be collected from NAMELIST + integer :: opom_cycle_yr = 0 !will be collected from NAMELIST + character(len=20) :: opom_source = 'no_file' !will be collected from NAMELIST + ! + integer :: pndx_fdms !DMS surface flux physics index + integer :: n_ocean_species !Number of variables read from ocean file + character(len=256) :: filename = '' !will be collected from NAMELIST + character(len=256) :: filelist = '' !not needed? + character(len=256) :: datapath = '' !will be collected from NAMELIST + integer :: fixed_ymd = 0 !running one date only? + integer :: fixed_tod = 0 !running one time of day only? + logical :: rmv_file = .false. !delete file when finished with it + +!=============================================================================== +contains +!=============================================================================== + + subroutine oslo_aero_ocean_getnl() + + ! Read oslo namelist variables using oslo_getops + character(len=256) :: in_filename + character(len=256) :: in_datapath + character(len=20) :: in_dms_data_source + character(len=32) :: in_dms_data_type + integer :: in_dms_cycle_yr + character(len=20) :: in_opom_data_source + character(len=32) :: in_opom_data_type + integer :: in_opom_cycle_yr + + ! Initialize namelist variables from local module variables. + in_filename = filename + in_datapath = datapath + in_dms_data_type = dms_data_type + in_dms_cycle_yr = dms_cycle_yr + in_dms_data_source = dms_source + in_opom_data_type = opom_data_type + in_opom_cycle_yr = opom_cycle_yr + in_opom_data_source = opom_source + + ! Read namelist. + call oslo_getopts(dms_source_out = in_dms_data_source, & + dms_source_type_out = in_dms_data_type, & + dms_cycle_year_out = in_dms_cycle_yr, & + opom_source_out = in_opom_data_source, & + opom_source_type_out= in_opom_data_type, & + opom_cycle_year_out = in_opom_cycle_yr, & + ocean_filename_out = in_filename, & + ocean_filepath_out = in_datapath) + + ! Update module variables with user settings. + filename = in_filename + datapath = in_datapath + dms_data_type = in_dms_data_type + dms_cycle_yr = in_dms_cycle_yr + dms_source = in_dms_data_source + opom_data_type= in_opom_data_type + opom_cycle_yr = in_opom_cycle_yr + opom_source = in_opom_data_source + + end subroutine oslo_aero_ocean_getnl + + !=============================================================================== + subroutine oslo_aero_ocean_init() + + ! local variables + integer :: astat + integer :: m + integer :: cycle_yr(2) + character(len=32) :: data_type(2) + character(len=16) :: emis_species(2) + + ! Collect and save namelist information in module + call oslo_aero_ocean_getnl() + + !get physics index for dms surface flux. Index for cflx + call cnst_get_ind('DMS', pndx_fdms, abort=.true.) + + if (dms_source=='lana')then + emis_species(1) = dmsl_fld_name + else + emis_species(1) = dmsk_fld_name + endif + if (opom_source=='odowd')then + emis_species(2) = opomo_fld_name + else + emis_species(2) = opomn_fld_name + endif + cycle_yr(1)= dms_cycle_yr + cycle_yr(2)= opom_cycle_yr + data_type(1) = dms_data_type + data_type(2) = opom_data_type + n_ocean_species = 2 + + if (masterproc) then + write(iulog,*) 'oslo_dms_inti: n_ocean_species = ',n_ocean_species + end if + + allocate( oceanspcs(n_ocean_species), stat=astat ) + if( astat/= 0 ) then + write(iulog,*) 'oslo_dms_inti: failed to allocate oceanspcs array; error = ',astat + call endrun + end if + + ! Setup the oceanspcs type array + ! Add support for selective reading with saved units etc.? + ! one for now... start with dms + do m = 1,n_ocean_species + ! oceanspcs(m)%spc_ndx = emis_indexes(m) ! physics index + ! oceanspcs(m)%units = 'nmol/L' + oceanspcs(m)%species = emis_species(m) ! nc var name + enddo + + ! Ocean concentrations are not stored in pbuf + do m = 1,n_ocean_species + allocate(oceanspcs(m)%file%in_pbuf(1)) + oceanspcs(m)%file%in_pbuf(:) = .false. + + call trcdata_init( oceanspcs(m)%species, filename, filelist, datapath, & + oceanspcs(m)%fields, oceanspcs(m)%file, rmv_file, & + cycle_yr(m), fixed_ymd, fixed_tod, data_type(m) ) + enddo + call addfld( 'odms', horiz_only, 'A', 'nmol/L', 'DMS upper ocean concentration' ) + call add_default('odms', 1, ' ') + + endsubroutine oslo_aero_ocean_init + + !=============================================================================== + subroutine oslo_aero_ocean_time(state, pbuf2d) + + ! arguments + type(physics_state), intent(in) :: state(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + ! local variables + integer :: m + + do m = 1,n_ocean_species + call advance_trcdata( oceanspcs(m)%fields, oceanspcs(m)%file, state, pbuf2d ) + end do + + endsubroutine oslo_aero_ocean_time + + !=============================================================================== + subroutine oslo_aero_dms_emis(state, cam_in) + + ! arguments + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), target, intent(inout) :: cam_in ! import state + + ! local variables + real(r8) :: u10m(pcols) ![m/s] + real(r8), pointer :: ocnfrc(:) ! [frc] ocean fraction + real(r8), pointer :: icefrc(:) ! [frc] ice fraction + integer :: ncol ! [nbr] number of columns in use + integer :: lchnk ! chunk index + real(r8) :: rk600(pcols) ! ocean/atmos. DMS exchange factor [cm/hr] + real(r8) :: flux(pcols) ! Local flux array: DMS emission rate [kg m-2 s-1] + real(r8) :: odms(pcols) ! Ocean dms concentration [nmol/L] from file + real(r8) :: open_ocn(pcols) ! Open Ocean + real(r8) :: t(pcols) + real(r8) :: scdms(pcols) + real(r8) :: kwdms(pcols) + real(r8), parameter :: z0= 0.0001_r8 ! [m] roughness length over ocean + real(r8), parameter :: Xconvxa= 6.97e-07 ! Wanninkhof's a=0.251 converted to ms-1/(ms-1)^2 + logical , parameter :: method_oslo = .false. + logical , parameter :: method_hamocc = .true. + + !pointers to land model variables + ocnfrc => cam_in%ocnfrac + icefrc => cam_in%icefrac + ncol = state%ncol + lchnk = state%lchnk + + if (dms_source=='lana' .or. dms_source=='kettle') then + + ! if concentration file - obtain dms data from file + flux(:) = 0._r8 + odms(:) = 0._r8 + odms(:ncol) = oceanspcs(1)%fields(1)%data(:ncol,1,lchnk) + + ! open ocean + open_ocn(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) + + !start with midpoint wind speed + u10m(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) + + if (method_oslo) then + ! move the winds to 10m high from the midpoint of the gridbox: + u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) + rk600(:ncol) = (0.222_r8*(u10m(:ncol)*u10m(:ncol))) + (0.333_r8*u10m(:ncol)) ! [cm/hr] + flux (:ncol) = 2.778e-15*cnst_mw(pndx_fdms)*rk600(:ncol)*open_ocn(:ncol)*odms(:ncol) ! [kg m-2 s-1] + else if (method_hamocc) then + t(:ncol)=cam_in%sst(:ncol)-273.15_r8 + u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) + scdms(:ncol) = 2855.7+ (-177.63 + (6.0438 + (-0.11645 + 0.00094743*t(:ncol))*t(:ncol))*t(:ncol))*t(:ncol) + kwdms(:ncol) = open_ocn(:ncol) * Xconvxa *u10m(:ncol)**2*(660./scdms(:ncol))**0.5 + flux (:ncol) = 62.13*kwdms(:ncol)*1e-9*odms(:ncol) + endif + cam_in%cflx(:ncol, pndx_fdms ) = flux(:ncol) + + call outfld('odms', odms(:ncol), ncol, lchnk) + + elseif (dms_source=='ocean_flux') then + + ! if ocean flux + cam_in%cflx(:ncol, pndx_fdms) = cam_in%fdms(:ncol) + endif + + ! IF EMISSION FILE + ! return without changing cflx + + endsubroutine oslo_aero_dms_emis + + !=============================================================================== + subroutine oslo_aero_opom_emis(em_ss1,em_ss2,em_ss3,open_ocn,ncol,lchnk, opomem_out) + + ! arguments + integer , intent(in) :: ncol ![nbr] number of columns in use + integer , intent(in) :: lchnk !current chunk + real(r8), intent(in) :: em_ss1(pcols) !sea salt emission mode a1 + real(r8), intent(in) :: em_ss2(pcols) !sea salt emission mode a2 + real(r8), intent(in) :: em_ss3(pcols) !sea salt emission mode a3 + real(r8), intent(in) :: open_ocn(pcols) !open ocean + real(r8), intent(out) :: opomem_out(pcols) !ocean POM emission rate [kg m-2 s-1] + + ! local variables + real(r8) :: omFrac(ncol) ! OM fraction of total seaspray mass + real(r8) :: ochlor(ncol) ! Ocean chlorophyll concentration [nmol/L] + real(r8) :: flux(ncol) ! Local flux array: ocean POM emission rate [kg m-2 s-1] + + ! Variables for Nilsson parameterisation + real(r8), parameter :: c_n = 0.000507456_r8 ! OM tuning constant (Tuned for NorESM2) + real(r8), parameter :: c_a1 = 2.06_r8 ! OM fraction in a1 mode + real(r8), parameter :: c_a2 = 0.355_r8 ! OM fraction in a2 mode + real(r8), parameter :: c_a3 = 0.0623_r8 ! OM fraction in a3 mode + real(r8), parameter :: c_o = 0.5238_r8 ! Arbritraty scaling factor to make the emissions match Spracklen. + real(r8) :: opoc(ncol) ! Ocean POC concentration [mg m-3] + + if (opom_source=='nilsson') then + ! Nilsson parameterisation - collect POC data from file + flux(:) = 0._r8 + opoc(:) = 0._r8 + opoc(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) + flux(:ncol) = c_n*open_ocn(:ncol)*opoc(:ncol)* (c_a1*em_ss1(:ncol)+c_a2*em_ss2(:ncol)+c_a3*em_ss3(:ncol)) + opomem_out(:ncol) = flux(:ncol) + + elseif (opom_source=='odowd') then + ! O'Dowd parameterisation - collect dms data from file + flux(:) = 0._r8 + ochlor(:) = 0._r8 + ochlor(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) + + ! OM fraction saturates at 90% according to O'Dowd 2008 + omFrac(:ncol) = min(0.01_r8*(43.5_r8 * ochlor(:ncol) + 13.805_r8),0.76_r8) + omFrac(:ncol) = omFrac(:ncol) / (1._r8 - omFrac(:ncol)) + flux(:ncol) = c_o*omFrac(:ncol) * em_ss1(:ncol) + opomem_out(:ncol) = flux(:ncol) + endif + + end subroutine oslo_aero_opom_emis + + !=============================================================================== + logical function oslo_aero_dms_inq() + if (dms_source =='emission_file') then + oslo_aero_dms_inq = .true. + else + oslo_aero_dms_inq = .false. + endif + end function oslo_aero_dms_inq + + !=============================================================================== + logical function oslo_aero_opom_inq() + if (opom_source=='nilsson' .or. opom_source=='odowd') then + oslo_aero_opom_inq = .true. + else + oslo_aero_opom_inq = .false. + endif + end function oslo_aero_opom_inq + +end module oslo_aero_ocean diff --git a/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 b/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 index 95f30d2d21..a2e7be1106 100644 --- a/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 @@ -1,7 +1,19 @@ module oslo_aero_seasalt - use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl - use ppgrid, only: pcols, pver + !----------------------------------------------------------------------- + ! compute emission of sea salt + !----------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl + use ppgrid, only: pcols, pver + use constituents, only: cnst_name + use camsrfexch, only: cam_in_t + use physics_types, only: physics_state + ! + use const, only: volumeToNumber + use oslo_aero_ocean, only: oslo_aero_opom_inq, oslo_aero_opom_emis + use aerosoldef, only: rhopart, l_om_ni, l_ss_a1, l_ss_a2, l_ss_a3 + use aerosoldef, only: MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 implicit none private @@ -24,10 +36,6 @@ module oslo_aero_seasalt subroutine oslo_aero_seasalt_init() - use constituents, only: cnst_name - use aerosoldef, only: l_ss_a1, l_ss_a2, l_ss_a3 - use aerosoldef, only: MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3, rhopart - integer :: i modeMap(1) = MODE_IDX_SS_A1 @@ -48,16 +56,6 @@ end subroutine oslo_aero_seasalt_init !=============================================================================== subroutine oslo_aero_seasalt_emis(state, cam_in) - !----------------------------------------------------------------------- - ! Purpose: Interface to emission of sea salt - !----------------------------------------------------------------------- - - use camsrfexch, only: cam_in_t - use physics_types, only: physics_state - use const, only: volumeToNumber - use aerosoldef, only: rhopart, l_om_ni - use oslo_ocean_intr, only: oslo_opom_inq, oslo_opom_emis_intr - ! Arguments: type(physics_state), intent(in) :: state ! Physics state variables type(cam_in_t), target, intent(inout) :: cam_in ! import state @@ -113,9 +111,11 @@ subroutine oslo_aero_seasalt_emis(state, cam_in) ! (Note the uncertainty in the factor 2, written as 2 pluss/minus 1 in Eq. 6 -> possible tuning factor) whitecapAreaFraction(:ncol) = (2.0_r8*10.0_r8**(-8.0_r8))*(u10m(:ncol)**3.74_r8) whitecapAreaFraction(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) * whitecapAreaFraction(:ncol) + + ! Determine open ocean fraction on gridcell open_ocean(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) - !Eqn. 9 in Salter et al. (2015) + ! Eqn. 9 in Salter et al. (2015) do n=1,numberOfSaltModes numberFlux(:ncol,n) = whitecapAreaFraction(:ncol)* & ( coeffA(n)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8) & @@ -131,10 +131,10 @@ subroutine oslo_aero_seasalt_emis(state, cam_in) end do spracklenOMOceanSource(:ncol) = cam_in%cflx(:ncol, tracerMap(1))*seasaltToSpracklenOM2 - if (oslo_opom_inq())then - call oslo_opom_emis_intr(cam_in%cflx(:ncol, tracerMap(1)), & + if (oslo_aero_opom_inq())then + call oslo_aero_opom_emis(cam_in%cflx(:ncol, tracerMap(1)), & cam_in%cflx(:ncol,tracerMap(2)), cam_in%cflx(:ncol,tracerMap(3)), & - open_ocean, ncol,lchnk, onOMOceanSource ) + open_ocean, ncol, lchnk, onOMOceanSource ) OMOceanSource(:ncol) = onOMOceanSource(:ncol) else OMOceanSource(:ncol) = spracklenOMOceanSource(:ncol) diff --git a/src/chemistry/oslo_aero/oslo_ocean_intr.F90 b/src/chemistry/oslo_aero/oslo_ocean_intr.F90 deleted file mode 100644 index af25b61881..0000000000 --- a/src/chemistry/oslo_aero/oslo_ocean_intr.F90 +++ /dev/null @@ -1,375 +0,0 @@ -!------------------------------------------------------------------- -! Marine DMS and POM emissions module -! Documentation: Implementation of interactive DMS and marine organic -! emission schemes in NorESM2, Lewinschal, 2015 -! Manages reading and interpolation of ocean tracer concentrations from file -! and calculates DMS and marine POM emissions. -! Parameterisations available: -! Nightingale et al. Global biogeochemical cycles 2000 (DMS) -! Nilsson, unpublished (POM) -! O'Dowd et al. GRL 2008 (POM) -! Based on prescribed_volcaero created by Francis Vitt and mo_srf_emissions -!------------------------------------------------------------------- -module oslo_ocean_intr - - use shr_kind_mod, only : r8 => shr_kind_r8 - use cam_abortutils, only : endrun - use spmd_utils, only : masterproc - use tracer_data, only : trfld, trfile - use cam_logfile, only : iulog - use ppgrid, only : pcols, pver,pverp - use camsrfexch, only : cam_in_t !, cam_out_t ? - - implicit none - private - - ! new type for ocean species - - type :: oceanspc - character(len=16) :: species(1) ! Species name - type(trfld), pointer :: fields(:) ! where the data ends up fields%data - type(trfile) :: file - end type oceanspc - - type(oceanspc), allocatable :: oceanspcs(:) - - ! List of subroutines that can be accesed from outside module - - public :: oslo_ocean_getnl ! should this be public. Only used locally... - public :: oslo_ocean_init ! initializing, reading file - public :: oslo_ocean_time ! time interpolation - public :: oslo_dms_emis_intr ! calculate dms surface emissions - public :: oslo_dms_inq ! logical function which tells mo_srf_emis what to do - public :: oslo_opom_emis_intr ! calculate opom surface emissions - public :: oslo_opom_inq ! logical function which tells oslo_salt what to do - - ! These variables are settable via the namelist (with longer names) - ! For reading concentration file - character(len=16) :: dmsl_fld_name = 'dms' !not set from namelist, hard coded, name of nc var - character(len=16) :: dmsk_fld_name = 'dms_Kettle' !not set from namelist, hard coded, name of nc var - character(len=16) :: opomo_fld_name = 'chlor_a' !not set from namelist, hard coded, name of nc var - character(len=16) :: opomn_fld_name = 'poc' !not set from namelist, hard coded, name of nc var - character(len=256) :: filename = '' !will be collected from NAMELIST - character(len=256) :: filelist = '' !not needed? - character(len=256) :: datapath = '' !will be collected from NAMELIST - character(len=32) :: dms_data_type = 'CYCLICAL' !will be collected from NAMELIST - character(len=32) :: opom_data_type= 'CYCLICAL' !will be collected from NAMELIST - logical :: rmv_file = .false. !delete file when finished with it - integer :: dms_cycle_yr = 0 !will be collected from NAMELIST - integer :: opom_cycle_yr = 0 !will be collected from NAMELIST - integer :: fixed_ymd = 0 !running one date only? - integer :: fixed_tod = 0 !running one time of day only? - character(len=20) :: dms_source = 'emission_file' !will be collected from NAMELIST - character(len=20) :: opom_source = 'no_file' !will be collected from NAMELIST - integer :: n_ocean_species !Number of variables read from ocean file - integer :: pndx_fdms !DMS surface flux physics index - -contains - !--------------------------------------------------------------------- - !--------------------------------------------------------------------- - subroutine oslo_ocean_getnl() - ! Read namelist variables. For oslo namelist variables this is done through oslo_getopts - - use oslo_control, only: oslo_getopts - - implicit none - - ! declaration of variables collected from namelist - character(len=256) :: in_filename - character(len=256) :: in_datapath - character(len=20) :: in_dms_data_source - character(len=32) :: in_dms_data_type - integer :: in_dms_cycle_yr - character(len=20) :: in_opom_data_source - character(len=32) :: in_opom_data_type - integer :: in_opom_cycle_yr - - - ! Initialize namelist variables from local module variables. - in_filename = filename - in_datapath = datapath - in_dms_data_type = dms_data_type - in_dms_cycle_yr = dms_cycle_yr - in_dms_data_source = dms_source - in_opom_data_type = opom_data_type - in_opom_cycle_yr = opom_cycle_yr - in_opom_data_source = opom_source - - ! Read namelist. - call oslo_getopts(dms_source_out = in_dms_data_source, & - dms_source_type_out = in_dms_data_type, & - dms_cycle_year_out = in_dms_cycle_yr, & - opom_source_out = in_opom_data_source, & - opom_source_type_out= in_opom_data_type, & - opom_cycle_year_out = in_opom_cycle_yr, & - ocean_filename_out = in_filename, & - ocean_filepath_out = in_datapath) - - - ! Update module variables with user settings. - filename = in_filename - datapath = in_datapath - dms_data_type = in_dms_data_type - dms_cycle_yr = in_dms_cycle_yr - dms_source = in_dms_data_source - opom_data_type= in_opom_data_type - opom_cycle_yr = in_opom_cycle_yr - opom_source = in_opom_data_source - - ! Write new value set from namelist to log - ! write(iulog,*)"test pom namelist 2: " // trim(opom_source) - - endsubroutine oslo_ocean_getnl - !--------------------------------------------------------------------- - !--------------------------------------------------------------------- - subroutine oslo_ocean_init() - ! no in parameters all information is local - - use tracer_data, only : trcdata_init - use constituents, only : cnst_get_ind - use cam_history, only : addfld, add_default, horiz_only - - implicit none - - integer :: astat - integer :: m - integer :: cycle_yr(2) - character(len=32) :: data_type(2) - character(len=16) :: emis_species(2) - - ! Collect and save namelist information in module - call oslo_ocean_getnl() - - !get physics index for dms surface flux. Index for cflx - call cnst_get_ind('DMS', pndx_fdms, abort=.true.) - - ! write(iulog,*)"test dms p index: " ,pndx_fdms - - if (dms_source=='lana')then - emis_species(1) = dmsl_fld_name - else - emis_species(1) = dmsk_fld_name - endif - if (opom_source=='odowd')then - emis_species(2) = opomo_fld_name - else - emis_species(2) = opomn_fld_name - endif - cycle_yr(1)= dms_cycle_yr - cycle_yr(2)= opom_cycle_yr - data_type(1) = dms_data_type - data_type(2) = opom_data_type - n_ocean_species = 2 - - if (masterproc) write(iulog,*) 'oslo_dms_inti: n_ocean_species = ',n_ocean_species - - allocate( oceanspcs(n_ocean_species), stat=astat ) - if( astat/= 0 ) then - write(iulog,*) 'oslo_dms_inti: failed to allocate oceanspcs array; error = ',astat - call endrun - end if - - !----------------------------------------------------------------------- - ! ... setup the oceanspcs type array - !----------------------------------------------------------------------- - ! Add support for selective reading with saved units etc.? - do m=1,n_ocean_species ! one for now... start with dms - ! oceanspcs(m)%spc_ndx = emis_indexes(m) ! physics index - ! oceanspcs(m)%units = 'nmol/L' - oceanspcs(m)%species = emis_species(m) ! nc var name - - enddo - - do m=1,n_ocean_species - - ! Ocean concentrations are not stored in pbuf - allocate(oceanspcs(m)%file%in_pbuf(1)) - oceanspcs(m)%file%in_pbuf(:) = .false. - - call trcdata_init( oceanspcs(m)%species, & - filename, filelist, datapath, & - oceanspcs(m)%fields, & - oceanspcs(m)%file, & - rmv_file, cycle_yr(m), fixed_ymd, fixed_tod, data_type(m) ) - - enddo - ! write(iulog,*) 'oslo_ocean_init: read file ' - - call addfld( 'odms', horiz_only, 'A', 'nmol/L', 'DMS upper ocean concentration' ) - - call add_default('odms', 1, ' ') - - endsubroutine oslo_ocean_init - !------------------------------------------------------------------------------------------ - !------------------------------------------------------------------------------------------ - subroutine oslo_ocean_time(state, pbuf2d) - - use physics_types, only : physics_state - use ppgrid, only : begchunk, endchunk - use tracer_data, only : advance_trcdata - use physics_buffer, only : physics_buffer_desc - - implicit none - - type(physics_state), intent(in) :: state(begchunk:endchunk) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - !----------------------------------------------------------------------- - ! ... local variables - !----------------------------------------------------------------------- - integer :: m - - do m = 1,n_ocean_species - call advance_trcdata( oceanspcs(m)%fields, oceanspcs(m)%file, state, pbuf2d ) - end do - - endsubroutine oslo_ocean_time - - !------------------------------------------------------------------------------------------ - !------------------------------------------------------------------------------------------ - subroutine oslo_dms_emis_intr(state, cam_in) - - use physics_types, only: physics_state - use constituents, only: cnst_mw !molecular weight for physics constituents - use cam_history, only: outfld - - ! Arguments - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), target, intent(inout) :: cam_in ! import state - - ! Local variables - real(r8) :: u10m(pcols) ![m/s] - real(r8), pointer :: ocnfrc(:) ! [frc] ocean fraction - real(r8), pointer :: icefrc(:) ! [frc] ice fraction - integer :: ncol ! [nbr] number of columns in use - integer :: lchnk ! chunk index - real(r8) :: rk600(pcols) ! ocean/atmos. DMS exchange factor [cm/hr] - real(r8) :: flux(pcols) ! Local flux array: DMS emission rate [kg m-2 s-1] - real(r8) :: odms(pcols) ! Ocean dms concentration [nmol/L] from file - real(r8) :: open_ocn(pcols) ! Open Ocean - real(r8) :: t(pcols) - real(r8) :: scdms(pcols) - real(r8) :: kwdms(pcols) - real(r8), parameter :: z0= 0.0001_r8 ! [m] roughness length over ocean - real(r8), parameter :: Xconvxa= 6.97e-07 ! Wanninkhof's a=0.251 converted to ms-1/(ms-1)^2 - logical , parameter :: method_oslo =.false. - logical , parameter :: method_hamocc=.true. - - !pointers to land model variables - ocnfrc => cam_in%ocnfrac - icefrc => cam_in%icefrac - ncol = state%ncol - lchnk = state%lchnk - - ! IF CONCENTRATION FILE - if (dms_source=='lana' .or. dms_source=='kettle') then - - ! collect dms data from file - flux(:) = 0._r8 - odms(:) = 0._r8 - odms(:ncol) = oceanspcs(1)%fields(1)%data(:ncol,1,lchnk) - - ! open ocean - open_ocn(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) - !start with midpoint wind speed - u10m(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) - - if (method_oslo) then - ! move the winds to 10m high from the midpoint of the gridbox: - u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) - rk600(:ncol) = (0.222_r8*(u10m(:ncol)*u10m(:ncol))) + (0.333_r8*u10m(:ncol)) ! [cm/hr] - flux (:ncol) = 2.778e-15*cnst_mw(pndx_fdms)*rk600(:ncol)*open_ocn(:ncol)*odms(:ncol) ! [kg m-2 s-1] - else if (method_hamocc) then - t(:ncol)=cam_in%sst(:ncol)-273.15_r8 - u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) - scdms(:ncol) = 2855.7+ (-177.63 + (6.0438 + (-0.11645 + 0.00094743*t(:ncol))*t(:ncol))*t(:ncol))*t(:ncol) - kwdms(:ncol) = open_ocn(:ncol) * Xconvxa *u10m(:ncol)**2*(660./scdms(:ncol))**0.5 - flux (:ncol) = 62.13*kwdms(:ncol)*1e-9*odms(:ncol) - endif - cam_in%cflx(:ncol, pndx_fdms ) = flux(:ncol) - - call outfld('odms', odms(:ncol), ncol, lchnk) - - ! IF OCEAN FLUX - elseif(dms_source=='ocean_flux') then - cam_in%cflx(:ncol, pndx_fdms) = cam_in%fdms(:ncol) - endif - - ! IF EMISSION FILE - ! return without changing cflx - - endsubroutine oslo_dms_emis_intr - - !------------------------------------------------------------------------------------------ - !------------------------------------------------------------------------------------------ - subroutine oslo_opom_emis_intr(em_ss1,em_ss2,em_ss3,open_ocn,ncol,lchnk, opomem_out) - - - integer , intent(in) :: ncol ![nbr] number of columns in use - integer , intent(in) :: lchnk !current chunk - real(r8), intent(in) :: em_ss1(pcols) !sea salt emission mode a1 - real(r8), intent(in) :: em_ss2(pcols) !sea salt emission mode a2 - real(r8), intent(in) :: em_ss3(pcols) !sea salt emission mode a3 - real(r8), intent(in) :: open_ocn(pcols) !open ocean - real(r8), intent(out) :: opomem_out(pcols) !ocean POM emission rate [kg m-2 s-1] - - real(r8) :: flux(ncol) ! Local flux array: ocean POM emission rate [kg m-2 s-1] - - ! Variables for Nilsson parameterisation - real(r8) :: opoc(ncol) ! Ocean POC concentration [mg m-3] - real(r8), parameter :: c_n = 0.000507456_r8 ! OM tuning constant (Tuned for NorESM2) - real(r8), parameter :: c_a1 = 2.06_r8 ! OM fraction in a1 mode - real(r8), parameter :: c_a2 = 0.355_r8 ! OM fraction in a2 mode - real(r8), parameter :: c_a3 = 0.0623_r8 ! OM fraction in a3 mode - real(r8) :: omFrac(ncol) ! OM fraction of total seaspray mass - real(r8) :: ochlor(ncol) ! Ocean chlorophyll concentration [nmol/L] - real(r8),parameter :: c_o = 0.5238_r8 ! Arbritraty scaling factor to make the emissions match Spracklen. - - if (opom_source=='nilsson') then - ! Nilsson parameterisation - collect POC data from file - flux(:) = 0._r8 - opoc(:) = 0._r8 - opoc(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) - flux(:ncol) = c_n*open_ocn(:ncol)*opoc(:ncol)* (c_a1*em_ss1(:ncol)+c_a2*em_ss2(:ncol)+c_a3*em_ss3(:ncol)) - opomem_out(:ncol) = flux(:ncol) - - elseif (opom_source=='odowd') then - ! O'Dowd parameterisation - collect dms data from file - flux(:) = 0._r8 - ochlor(:) = 0._r8 - ochlor(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) - - ! OM fraction saturates at 90% according to O'Dowd 2008 - omFrac(:ncol) = min(0.01_r8*(43.5_r8 * ochlor(:ncol) + 13.805_r8),0.76_r8) - omFrac(:ncol) = omFrac(:ncol) / (1._r8 - omFrac(:ncol)) - flux(:ncol) = c_o*omFrac(:ncol) * em_ss1(:ncol) - opomem_out(:ncol) = flux(:ncol) - endif - - endsubroutine oslo_opom_emis_intr - - !------------------------------------------------------------------------------------------ - !------------------------------------------------------------------------------------------ - logical function oslo_dms_inq() - - if (dms_source=='emission_file') then - oslo_dms_inq = .true. - else - oslo_dms_inq = .false. - endif - - end function oslo_dms_inq - - !------------------------------------------------------------------------------------------ - !------------------------------------------------------------------------------------------ - logical function oslo_opom_inq() - - if (opom_source=='nilsson' .or. opom_source=='odowd') then - oslo_opom_inq = .true. - else - oslo_opom_inq = .false. - endif - - end function oslo_opom_inq - -end module oslo_ocean_intr diff --git a/src/physics/cam_oslo/mo_drydep.F90 b/src/physics/cam_oslo/mo_drydep.F90 deleted file mode 100644 index e81f3d66f7..0000000000 --- a/src/physics/cam_oslo/mo_drydep.F90 +++ /dev/null @@ -1,3303 +0,0 @@ -module mo_drydep - - !--------------------------------------------------------------------- - ! ... Dry deposition velocity input data and code for netcdf input - !--------------------------------------------------------------------- - -!LKE (10/11/2010): added HCN, CH3CN, HCOOH -!LKE (7/30/2015): added new TS1 species (phenooh, iepox, noa, etc.) - - use shr_kind_mod, only : r8 => shr_kind_r8, shr_kind_cl - use chem_mods, only : gas_pcnst - use pmgrid, only : plev, plevp - use spmd_utils, only : masterproc, iam - use ppgrid, only : pcols, begchunk, endchunk - use mo_tracname, only : solsym - use cam_abortutils, only : endrun - use ioFileMod, only : getfil - use pio - use cam_pio_utils, only : cam_pio_openfile, cam_pio_closefile - use cam_logfile, only : iulog - use dyn_grid, only : get_dyn_grid_parm, get_horiz_grid_d - use scamMod, only : single_column - - use seq_drydep_mod, only : nddvels => n_drydep, drydep_list, mapping - use physconst, only : karman - - implicit none - - save - - interface drydep_inti - module procedure dvel_inti_table - module procedure dvel_inti_xactive - module procedure dvel_inti_fromlnd - end interface - - interface drydep - module procedure drydep_table - module procedure drydep_xactive - module procedure drydep_fromlnd - end interface - - private - public :: drydep_inti, drydep, set_soilw, chk_soilw, has_drydep - public :: drydep_update - public :: n_land_type, fraction_landuse, drydep_srf_file - - real(r8) :: dels - real(r8), allocatable :: days(:) ! day of year for soilw - real(r8), allocatable :: dvel(:,:,:,:) ! depvel array interpolated to model grid - real(r8), allocatable :: dvel_interp(:,:,:) ! depvel array interpolated to grid and time - integer :: last, next ! day indicies - integer :: ndays ! # of days in soilw file - integer :: map(gas_pcnst) ! indices for drydep species - integer :: nspecies ! number of depvel species in input file - - integer :: pan_ndx, mpan_ndx, no2_ndx, hno3_ndx, o3_ndx, & - h2o2_ndx, onit_ndx, onitr_ndx, ch4_ndx, ch2o_ndx, & - ch3ooh_ndx, pooh_ndx, ch3coooh_ndx, c2h5ooh_ndx, eooh_ndx, & - c3h7ooh_ndx, rooh_ndx, ch3cocho_ndx, co_ndx, ch3coch3_ndx, & - no_ndx, ho2no2_ndx, glyald_ndx, hyac_ndx, ch3oh_ndx, c2h5oh_ndx, & - hydrald_ndx, h2_ndx, Pb_ndx, o3s_ndx, o3inert_ndx, macrooh_ndx, & - xooh_ndx, ch3cho_ndx, isopooh_ndx - integer :: alkooh_ndx, mekooh_ndx, tolooh_ndx, terpooh_ndx, ch3cooh_ndx - integer :: soa_ndx, so4_ndx, cb1_ndx, cb2_ndx, oc1_ndx, oc2_ndx, nh3_ndx, nh4no3_ndx, & - sa1_ndx, sa2_ndx, sa3_ndx, sa4_ndx, nh4_ndx - integer :: soam_ndx, soai_ndx, soat_ndx, soab_ndx, soax_ndx, & - sogm_ndx, sogi_ndx, sogt_ndx, sogb_ndx, sogx_ndx - - logical :: alkooh_dd, mekooh_dd, tolooh_dd, terpooh_dd, ch3cooh_dd - logical :: soa_dd, so4_dd, cb1_dd, cb2_dd, oc1_dd, oc2_dd, nh3_dd, nh4no3_dd, & - sa1_dd, sa2_dd, sa3_dd, sa4_dd, nh4_dd - logical :: soam_dd, soai_dd, soat_dd, soab_dd, soax_dd, & - sogm_dd, sogi_dd, sogt_dd, sogb_dd, sogx_dd - - logical :: pan_dd, mpan_dd, no2_dd, hno3_dd, o3_dd, isopooh_dd, ch4_dd,& - h2o2_dd, onit_dd, onitr_dd, ch2o_dd, macrooh_dd, xooh_dd, & - ch3ooh_dd, pooh_dd, ch3coooh_dd, c2h5ooh_dd, eooh_dd, ch3cho_dd, c2h5oh_dd, & - c3h7ooh_dd, rooh_dd, ch3cocho_dd, co_dd, ch3coch3_dd, & - glyald_dd, hyac_dd, ch3oh_dd, hydrald_dd, h2_dd, Pb_dd, o3s_dd, o3inert_dd - - integer :: so2_ndx - integer :: ch3cn_ndx, hcn_ndx, hcooh_ndx - logical :: ch3cn_dd, hcn_dd, hcooh_dd - - integer :: o3a_ndx,xpan_ndx,xmpan_ndx,xno2_ndx,xhno3_ndx,xonit_ndx,xonitr_ndx,xno_ndx,xho2no2_ndx,xnh4no3_ndx - logical :: o3a_dd, xpan_dd, xmpan_dd, xno2_dd, xhno3_dd, xonit_dd, xonitr_dd, xno_dd, xho2no2_dd, xnh4no3_dd - -!lke-TS1 - integer :: phenooh_ndx, benzooh_ndx, c6h5ooh_ndx, bzooh_ndx, xylolooh_ndx, xylenooh_ndx - integer :: terp2ooh_ndx, terprod1_ndx, terprod2_ndx, hmprop_ndx, mboooh_ndx, hpald_ndx, iepox_ndx - integer :: noa_ndx, alknit_ndx, isopnita_ndx, isopnitb_ndx, honitr_ndx, isopnooh_ndx - integer :: nc4cho_ndx, nc4ch2oh_ndx, terpnit_ndx, nterpooh_ndx - logical :: phenooh_dd, benzooh_dd, c6h5ooh_dd, bzooh_dd, xylolooh_dd, xylenooh_dd - logical :: terp2ooh_dd, terprod1_dd, terprod2_dd, hmprop_dd, mboooh_dd, hpald_dd, iepox_dd - logical :: noa_dd, alknit_dd, isopnita_dd, isopnitb_dd, honitr_dd, isopnooh_dd - logical :: nc4cho_dd, nc4ch2oh_dd, terpnit_dd, nterpooh_dd - - integer :: cohc_ndx=-1, come_ndx=-1 - integer, parameter :: NTAGS = 50 - integer :: cotag_ndx(NTAGS) - integer :: tag_cnt - - integer :: & - o3_tab_ndx = -1, & - h2o2_tab_ndx = -1, & - ch3ooh_tab_ndx = -1, & - co_tab_ndx = -1, & - ch3cho_tab_ndx = -1 - logical :: & - o3_in_tab = .false., & - h2o2_in_tab = .false., & - ch3ooh_in_tab = .false., & - co_in_tab = .false., & - ch3cho_in_tab = .false. - - real(r8), parameter :: small_value = 1.e-36_r8 - real(r8), parameter :: large_value = 1.e36_r8 - real(r8), parameter :: diffm = 1.789e-5_r8 - real(r8), parameter :: diffk = 1.461e-5_r8 - real(r8), parameter :: difft = 2.060e-5_r8 - real(r8), parameter :: vonkar = karman - real(r8), parameter :: ric = 0.2_r8 - real(r8), parameter :: r = 287.04_r8 - real(r8), parameter :: cp = 1004._r8 - real(r8), parameter :: grav = 9.81_r8 - real(r8), parameter :: p00 = 100000._r8 - real(r8), parameter :: wh2o = 18.0153_r8 - real(r8), parameter :: ph = 1.e-5_r8 - real(r8), parameter :: ph_inv = 1._r8/ph - real(r8), parameter :: rovcp = r/cp - - integer, pointer :: index_season_lai(:,:) - - logical, public :: has_dvel(gas_pcnst) = .false. - integer :: map_dvel(gas_pcnst) = 0 - real(r8) , allocatable :: soilw_3d(:,:,:) - - logical, parameter :: dyn_soilw = .false. - - real(r8), allocatable :: fraction_landuse(:,:,:) - real(r8), allocatable, dimension(:,:,:) :: dep_ra ! [s/m] aerodynamic resistance - real(r8), allocatable, dimension(:,:,:) :: dep_rb ! [s/m] resistance across sublayer - integer, parameter :: n_land_type = 11 - - integer, allocatable :: spc_ndx(:) ! nddvels - real(r8), public :: crb - - type lnd_dvel_type - real(r8), pointer :: dvel(:,:) ! deposition velocity over land (cm/s) - end type lnd_dvel_type - - type(lnd_dvel_type), allocatable :: lnd(:) - character(len=SHR_KIND_CL) :: drydep_srf_file - -contains - - !--------------------------------------------------------------------------- - !--------------------------------------------------------------------------- - subroutine dvel_inti_fromlnd - use mo_chem_utls, only : get_spc_ndx - use cam_abortutils, only : endrun - use chem_mods, only : adv_mass - use seq_drydep_mod, only : dfoxd - - implicit none - - integer :: ispc, l - - allocate(spc_ndx(nddvels)) - allocate( lnd(begchunk:endchunk) ) - - do ispc = 1,nddvels - - spc_ndx(ispc) = get_spc_ndx(drydep_list(ispc)) - if (spc_ndx(ispc) < 1) then - write(*,*) 'drydep_inti: '//trim(drydep_list(ispc))//' is not included in species set' - call endrun('drydep_init: invalid dry deposition species') - endif - - enddo - - crb = (difft/diffm)**(2._r8/3._r8) !.666666_r8 - - endsubroutine dvel_inti_fromlnd - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine drydep_update( state, cam_in ) - use physics_types, only : physics_state - use camsrfexch, only : cam_in_t - use seq_drydep_mod, only : drydep_method, DD_XLND - - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), intent(in) :: cam_in - - if (nddvels<1) return - if (drydep_method /= DD_XLND) return - - lnd(state%lchnk)%dvel => cam_in%depvel - - end subroutine drydep_update - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine drydep_fromlnd( ocnfrac, icefrac, ncdate, sfc_temp, pressure_sfc, & - wind_speed, spec_hum, air_temp, pressure_10m, rain, & - snow, solar_flux, dvelocity, dflx, mmr, & - tv, soilw, rh, ncol, lonndx, latndx, lchnk ) - - !------------------------------------------------------------------------------------- - ! combines the deposition velocities provided by the land model with deposition - ! velocities over ocean and sea ice - !------------------------------------------------------------------------------------- - - use ppgrid, only : pcols - use chem_mods, only : gas_pcnst - -#if (defined OFFLINE_DYN) - use metdata, only: get_met_fields -#endif - - implicit none - - !------------------------------------------------------------------------------------- - ! ... dummy arguments - !------------------------------------------------------------------------------------- - - real(r8), intent(in) :: icefrac(pcols) - real(r8), intent(in) :: ocnfrac(pcols) - - integer, intent(in) :: ncol - integer, intent(in) :: ncdate ! present date (yyyymmdd) - real(r8), intent(in) :: sfc_temp(pcols) ! surface temperature (K) - real(r8), intent(in) :: pressure_sfc(pcols) ! surface pressure (Pa) - real(r8), intent(in) :: wind_speed(pcols) ! 10 meter wind speed (m/s) - real(r8), intent(in) :: spec_hum(pcols) ! specific humidity (kg/kg) - real(r8), intent(in) :: rh(ncol,1) ! relative humidity - real(r8), intent(in) :: air_temp(pcols) ! surface air temperature (K) - real(r8), intent(in) :: pressure_10m(pcols) ! 10 meter pressure (Pa) - real(r8), intent(in) :: rain(pcols) - real(r8), intent(in) :: snow(pcols) ! snow height (m) - real(r8), intent(in) :: soilw(pcols) ! soil moisture fraction - real(r8), intent(in) :: solar_flux(pcols) ! direct shortwave radiation at surface (W/m^2) - real(r8), intent(in) :: tv(pcols) ! potential temperature - real(r8), intent(in) :: mmr(pcols,plev,gas_pcnst) ! constituent concentration (kg/kg) - real(r8), intent(out) :: dvelocity(ncol,gas_pcnst) ! deposition velocity (cm/s) - real(r8), intent(inout) :: dflx(pcols,gas_pcnst) ! deposition flux (/cm^2/s) - - integer, intent(in) :: latndx(pcols) ! chunk latitude indicies - integer, intent(in) :: lonndx(pcols) ! chunk longitude indicies - integer, intent(in) :: lchnk ! chunk number - - !------------------------------------------------------------------------------------- - ! ... local variables - !------------------------------------------------------------------------------------- - real(r8) :: ocnice_dvel(ncol,gas_pcnst) - real(r8) :: ocnice_dflx(pcols,gas_pcnst) - - real(r8), dimension(ncol) :: term ! work array - integer :: ispec - real(r8) :: lndfrac(pcols) -#if (defined OFFLINE_DYN) - real(r8) :: met_ocnfrac(pcols) - real(r8) :: met_icefrac(pcols) -#endif - integer :: i - - lndfrac(:ncol) = 1._r8 - ocnfrac(:ncol) - icefrac(:ncol) - - where( lndfrac(:ncol) < 0._r8 ) - lndfrac(:ncol) = 0._r8 - endwhere - -#if (defined OFFLINE_DYN) - call get_met_fields(lndfrac, met_ocnfrac, met_icefrac, lchnk, ncol) -#endif - - !------------------------------------------------------------------------------------- - ! ... initialize - !------------------------------------------------------------------------------------- - dvelocity(:,:) = 0._r8 - - !------------------------------------------------------------------------------------- - ! ... compute the dep velocities over ocean and sea ice - ! land type 7 is used for ocean - ! land type 8 is used for sea ice - !------------------------------------------------------------------------------------- - call drydep_xactive( ncdate, sfc_temp, pressure_sfc, & - wind_speed, spec_hum, air_temp, pressure_10m, rain, & - snow, solar_flux, ocnice_dvel, ocnice_dflx, mmr, & - tv, soilw, rh, ncol, lonndx, latndx, lchnk, & -#if (defined OFFLINE_DYN) - ocnfrc=met_ocnfrac,icefrc=met_icefrac, beglandtype=7, endlandtype=8 ) -#else - ocnfrc=ocnfrac,icefrc=icefrac, beglandtype=7, endlandtype=8 ) -#endif - term(:ncol) = 1.e-2_r8 * pressure_10m(:ncol) / (r*tv(:ncol)) - - do ispec = 1,nddvels - !------------------------------------------------------------------------------------- - ! ... merge the land component with the non-land component - ! ocn and ice already have fractions factored in - !------------------------------------------------------------------------------------- - dvelocity(:ncol,spc_ndx(ispec)) = lnd(lchnk)%dvel(:ncol,ispec)*lndfrac(:ncol) & - + ocnice_dvel(:ncol,spc_ndx(ispec)) - enddo - - !------------------------------------------------------------------------------------- - ! ... special adjustments - !------------------------------------------------------------------------------------- - if( mpan_ndx>0 ) then - dvelocity(:ncol,mpan_ndx) = dvelocity(:ncol,mpan_ndx)/3._r8 - endif - if( xmpan_ndx>0 ) then - dvelocity(:ncol,xmpan_ndx) = dvelocity(:ncol,xmpan_ndx)/3._r8 - endif - if( hcn_ndx>0 ) then - dvelocity(:ncol,hcn_ndx) = ocnice_dvel(:ncol,hcn_ndx) ! should be zero over land - endif - if( ch3cn_ndx>0 ) then - dvelocity(:ncol,ch3cn_ndx) = ocnice_dvel(:ncol,ch3cn_ndx) ! should be zero over land - endif - - ! HCOOH, use CH3COOH dep.vel - if( hcooh_ndx > 0 .and. ch3cooh_ndx > 0 ) then - if( has_dvel(hcooh_ndx) ) then - dvelocity(:ncol,hcooh_ndx) = dvelocity(:ncol,ch3cooh_ndx) - end if - end if - - !------------------------------------------------------------------------------------- - ! ... assign CO tags to CO - ! put this kludge in for now ... - ! -- should be able to set all these via the table mapping in seq_drydep_mod - !------------------------------------------------------------------------------------- - if( cohc_ndx>0 .and. co_ndx>0 ) then - dvelocity(:ncol,cohc_ndx) = dvelocity(:ncol,co_ndx) - dflx(:ncol,cohc_ndx) = dvelocity(:ncol,co_ndx) * term(:ncol) * mmr(:ncol,plev,cohc_ndx) - endif - if( come_ndx>0 .and. co_ndx>0 ) then - dvelocity(:ncol,come_ndx) = dvelocity(:ncol,co_ndx) - dflx(:ncol,come_ndx) = dvelocity(:ncol,co_ndx) * term(:ncol) * mmr(:ncol,plev,come_ndx) - endif - - if ( co_ndx>0 ) then - do i=1,tag_cnt - dvelocity(:ncol,cotag_ndx(i)) = dvelocity(:ncol,co_ndx) - dflx(:ncol,cotag_ndx(i)) = dvelocity(:ncol,co_ndx) * term(:ncol) * mmr(:ncol,plev,cotag_ndx(i)) - enddo - endif - - do ispec = 1,nddvels - !------------------------------------------------------------------------------------- - ! ... compute the deposition flux - !------------------------------------------------------------------------------------- - dflx(:ncol,spc_ndx(ispec)) = dvelocity(:ncol,spc_ndx(ispec)) * term(:ncol) * mmr(:ncol,plev,spc_ndx(ispec)) - end do - - end subroutine drydep_fromlnd - - !--------------------------------------------------------------------------- - !--------------------------------------------------------------------------- - subroutine dvel_inti_table( depvel_file ) - !--------------------------------------------------------------------------- - ! ... Initialize module, depvel arrays, and a few other variables. - ! The depvel fields will be linearly interpolated to the correct time - !--------------------------------------------------------------------------- - - use mo_constants, only : d2r, r2d - use ioFileMod, only : getfil - use string_utils, only : to_lower, GLC - use mo_chem_utls, only : get_spc_ndx - use constituents, only : pcnst - use interpolate_data, only : lininterp_init, lininterp, lininterp_finish,interp_type - use mo_constants, only : pi - use phys_grid, only : get_ncols_p, get_rlat_all_p, get_rlon_all_p - - implicit none - - character(len=*), intent(in) :: depvel_file - - !--------------------------------------------------------------------------- - ! ... Local variables - !--------------------------------------------------------------------------- - integer :: nlat, nlon, nmonth, ndims - integer :: dimid_lat, dimid_lon, dimid_species, dimid_time - integer :: dimid(4), count(4), start(4) - integer :: m, ispecies, nchar, ierr - real(r8) :: scale_factor - - real(r8), allocatable :: dvel_lats(:), dvel_lons(:) - real(r8), allocatable :: dvel_in(:,:,:,:) ! input depvel array - character(len=50) :: units - character(len=20), allocatable :: species_names(:) ! names of depvel species - logical :: found - type(file_desc_t) :: piofile - type(var_desc_t) :: vid, vid_dvel - - character(len=shr_kind_cl) :: locfn - integer :: mm,n - - integer :: i, c, ncols - real(r8) :: to_lats(pcols), to_lons(pcols) - type(interp_type) :: lon_wgts, lat_wgts - real(r8), parameter :: zero=0._r8, twopi=2._r8*pi - - mm = 1 - do m = 1,pcnst - if ( len_trim(drydep_list(m))==0 ) exit - n = get_spc_ndx(drydep_list(m)) - if ( n < 1 ) then - write(iulog,*) 'drydep_inti: '//drydep_list(m)//' is not included in species set' - call endrun('drydep_init: invalid dry deposition species') - endif - enddo - - if( masterproc ) then - write(iulog,*) 'drydep_inti: following species have dry deposition' - do i=1,nddvels - if( len_trim(drydep_list(i)) > 0 ) then - write(iulog,*) 'drydep_inti: '//trim(drydep_list(i))//' is requested to have dry dep' - endif - enddo - write(iulog,*) 'drydep_inti:' - endif - - if ( nddvels < 1 ) return - - !--------------------------------------------------------------------------- - ! ... Setup species maps - !--------------------------------------------------------------------------- - o3a_ndx = get_spc_ndx( 'O3A') - xpan_ndx = get_spc_ndx( 'XPAN') - xmpan_ndx = get_spc_ndx( 'XMPAN') - xno2_ndx = get_spc_ndx( 'XNO2') - xhno3_ndx = get_spc_ndx( 'XHNO3') - xonit_ndx = get_spc_ndx( 'XONIT') - xonitr_ndx = get_spc_ndx( 'XONITR') - xno_ndx = get_spc_ndx( 'XNO') - xho2no2_ndx = get_spc_ndx( 'XHO2NO2') - o3a_dd = has_drydep( 'O3A') - xpan_dd = has_drydep( 'XPAN') - xmpan_dd = has_drydep( 'XMPAN') - xno2_dd = has_drydep( 'XNO2') - xhno3_dd = has_drydep( 'XHNO3') - xonit_dd = has_drydep( 'XONIT') - xonitr_dd = has_drydep( 'XONITR') - xno_dd = has_drydep( 'XNO') - xho2no2_dd = has_drydep( 'XHO2NO2') - - pan_ndx = get_spc_ndx( 'PAN') - mpan_ndx = get_spc_ndx( 'MPAN') - no2_ndx = get_spc_ndx( 'NO2') - hno3_ndx = get_spc_ndx( 'HNO3') - co_ndx = get_spc_ndx( 'CO') - o3_ndx = get_spc_ndx( 'O3') - if( o3_ndx < 1 ) then - o3_ndx = get_spc_ndx( 'OX') - end if - h2o2_ndx = get_spc_ndx( 'H2O2') - onit_ndx = get_spc_ndx( 'ONIT') - onitr_ndx = get_spc_ndx( 'ONITR') - ch4_ndx = get_spc_ndx( 'CH4') - ch2o_ndx = get_spc_ndx( 'CH2O') - ch3ooh_ndx = get_spc_ndx( 'CH3OOH') - ch3cho_ndx = get_spc_ndx( 'CH3CHO') - ch3cocho_ndx = get_spc_ndx( 'CH3COCHO') - pooh_ndx = get_spc_ndx( 'POOH') - ch3coooh_ndx = get_spc_ndx( 'CH3COOOH') - c2h5ooh_ndx = get_spc_ndx( 'C2H5OOH') - eooh_ndx = get_spc_ndx( 'EOOH') - c3h7ooh_ndx = get_spc_ndx( 'C3H7OOH') - rooh_ndx = get_spc_ndx( 'ROOH') - ch3coch3_ndx = get_spc_ndx( 'CH3COCH3') - no_ndx = get_spc_ndx( 'NO') - ho2no2_ndx = get_spc_ndx( 'HO2NO2') - glyald_ndx = get_spc_ndx( 'GLYALD') - hyac_ndx = get_spc_ndx( 'HYAC') - ch3oh_ndx = get_spc_ndx( 'CH3OH') - c2h5oh_ndx = get_spc_ndx( 'C2H5OH') - macrooh_ndx = get_spc_ndx( 'MACROOH') - isopooh_ndx = get_spc_ndx( 'ISOPOOH') - xooh_ndx = get_spc_ndx( 'XOOH') - hydrald_ndx = get_spc_ndx( 'HYDRALD') - h2_ndx = get_spc_ndx( 'H2') - Pb_ndx = get_spc_ndx( 'Pb') - o3s_ndx = get_spc_ndx( 'O3S') - o3inert_ndx = get_spc_ndx( 'O3INERT') - alkooh_ndx = get_spc_ndx( 'ALKOOH') - mekooh_ndx = get_spc_ndx( 'MEKOOH') - tolooh_ndx = get_spc_ndx( 'TOLOOH') - terpooh_ndx = get_spc_ndx( 'TERPOOH') - ch3cooh_ndx = get_spc_ndx( 'CH3COOH') - soam_ndx = get_spc_ndx( 'SOAM' ) - soai_ndx = get_spc_ndx( 'SOAI' ) - soat_ndx = get_spc_ndx( 'SOAT' ) - soab_ndx = get_spc_ndx( 'SOAB' ) - soax_ndx = get_spc_ndx( 'SOAX' ) - sogm_ndx = get_spc_ndx( 'SOGM' ) - sogi_ndx = get_spc_ndx( 'SOGI' ) - sogt_ndx = get_spc_ndx( 'SOGT' ) - sogb_ndx = get_spc_ndx( 'SOGB' ) - sogx_ndx = get_spc_ndx( 'SOGX' ) - soa_ndx = get_spc_ndx( 'SOA' ) - so4_ndx = get_spc_ndx( 'SO4' ) - cb1_ndx = get_spc_ndx( 'CB1' ) - cb2_ndx = get_spc_ndx( 'CB2' ) - oc1_ndx = get_spc_ndx( 'OC1' ) - oc2_ndx = get_spc_ndx( 'OC2' ) - nh3_ndx = get_spc_ndx( 'NH3' ) - nh4no3_ndx = get_spc_ndx( 'NH4NO3' ) - xnh4no3_ndx = get_spc_ndx( 'XNH4NO3' ) - sa1_ndx = get_spc_ndx( 'SA1' ) - sa2_ndx = get_spc_ndx( 'SA2' ) - sa3_ndx = get_spc_ndx( 'SA3' ) - sa4_ndx = get_spc_ndx( 'SA4' ) - nh4_ndx = get_spc_ndx( 'NH4' ) - alkooh_dd = has_drydep( 'ALKOOH') - mekooh_dd = has_drydep( 'MEKOOH') - tolooh_dd = has_drydep( 'TOLOOH') - terpooh_dd = has_drydep( 'TERPOOH') - ch3cooh_dd = has_drydep( 'CH3COOH') - soam_dd = has_drydep( 'SOAM' ) - soai_dd = has_drydep( 'SOAI' ) - soat_dd = has_drydep( 'SOAT' ) - soab_dd = has_drydep( 'SOAB' ) - soax_dd = has_drydep( 'SOAX' ) - sogm_dd = has_drydep( 'SOGM' ) - sogi_dd = has_drydep( 'SOGI' ) - sogt_dd = has_drydep( 'SOGT' ) - sogb_dd = has_drydep( 'SOGB' ) - sogx_dd = has_drydep( 'SOGX' ) - soa_dd = has_drydep( 'SOA' ) - so4_dd = has_drydep( 'SO4' ) - cb1_dd = has_drydep( 'CB1' ) - cb2_dd = has_drydep( 'CB2' ) - oc1_dd = has_drydep( 'OC1' ) - oc2_dd = has_drydep( 'OC2' ) - nh3_dd = has_drydep( 'NH3' ) - nh4no3_dd = has_drydep( 'NH4NO3' ) - xnh4no3_dd = has_drydep( 'XNH4NO3' ) - sa1_dd = has_drydep( 'SA1' ) - sa2_dd = has_drydep( 'SA2' ) - sa3_dd = has_drydep( 'SA3' ) - sa4_dd = has_drydep( 'SA4' ) - nh4_dd = has_drydep( 'NH4' ) - pan_dd = has_drydep( 'PAN') - mpan_dd = has_drydep( 'MPAN') - no2_dd = has_drydep( 'NO2') - hno3_dd = has_drydep( 'HNO3') - co_dd = has_drydep( 'CO') - o3_dd = has_drydep( 'O3') - if( .not. o3_dd ) then - o3_dd = has_drydep( 'OX') - end if - h2o2_dd = has_drydep( 'H2O2') - onit_dd = has_drydep( 'ONIT') - onitr_dd = has_drydep( 'ONITR') - ch4_dd = has_drydep( 'CH4') - ch2o_dd = has_drydep( 'CH2O') - ch3ooh_dd = has_drydep( 'CH3OOH') - ch3cho_dd = has_drydep( 'CH3CHO') - c2h5oh_dd = has_drydep( 'C2H5OH') - eooh_dd = has_drydep( 'EOOH') - ch3cocho_dd = has_drydep( 'CH3COCHO') - pooh_dd = has_drydep( 'POOH') - ch3coooh_dd = has_drydep( 'CH3COOOH') - c2h5ooh_dd = has_drydep( 'C2H5OOH') - c3h7ooh_dd = has_drydep( 'C3H7OOH') - rooh_dd = has_drydep( 'ROOH') - ch3coch3_dd = has_drydep( 'CH3COCH3') - glyald_dd = has_drydep( 'GLYALD') - hyac_dd = has_drydep( 'HYAC') - ch3oh_dd = has_drydep( 'CH3OH') - macrooh_dd = has_drydep( 'MACROOH') - isopooh_dd = has_drydep( 'ISOPOOH') - xooh_dd = has_drydep( 'XOOH') - hydrald_dd = has_drydep( 'HYDRALD') - h2_dd = has_drydep( 'H2') - Pb_dd = has_drydep( 'Pb') - o3s_dd = has_drydep( 'O3S') - o3inert_dd = has_drydep( 'O3INERT') - ch3cn_dd = has_drydep( 'CH3CN') - hcn_dd = has_drydep( 'HCN') - hcooh_dd = has_drydep( 'HCOOH') - ch3cn_ndx = get_spc_ndx( 'CH3CN') - hcn_ndx = get_spc_ndx( 'HCN') - hcooh_ndx = get_spc_ndx( 'HCOOH' ) - - if( masterproc ) then - write(iulog,*) 'dvel_inti: diagnostics' - write(iulog,'(10i5)') pan_ndx, mpan_ndx, no2_ndx, hno3_ndx, o3_ndx, & - h2o2_ndx, onit_ndx, onitr_ndx, ch4_ndx, ch2o_ndx, & - ch3ooh_ndx, pooh_ndx, ch3coooh_ndx, c2h5ooh_ndx, eooh_ndx, & - c3h7ooh_ndx, rooh_ndx, ch3cocho_ndx, co_ndx, ch3coch3_ndx, & - no_ndx, ho2no2_ndx, glyald_ndx, hyac_ndx, ch3oh_ndx, c2h5oh_ndx, & - hydrald_ndx, h2_ndx, Pb_ndx, o3s_ndx, o3inert_ndx, macrooh_ndx, & - xooh_ndx, ch3cho_ndx, isopooh_ndx, noa_ndx, alknit_ndx, isopnita_ndx, & - honitr_ndx, isopnooh_ndx, nc4cho_ndx, nc4ch2oh_ndx, terpnit_ndx, nterpooh_ndx - write(iulog,*) pan_dd, mpan_dd, no2_dd, hno3_dd, o3_dd, isopooh_dd, ch4_dd,& - h2o2_dd, onit_dd, onitr_dd, ch2o_dd, macrooh_dd, xooh_dd, & - ch3ooh_dd, pooh_dd, ch3coooh_dd, c2h5ooh_dd, eooh_dd, ch3cho_dd, c2h5oh_dd, & - c3h7ooh_dd, rooh_dd, ch3cocho_dd, co_dd, ch3coch3_dd, & - glyald_dd, hyac_dd, ch3oh_dd, hydrald_dd, h2_dd, Pb_dd, o3s_dd, o3inert_dd, & - noa_dd, alknit_dd, isopnita_dd, & - honitr_dd, isopnooh_dd, nc4cho_dd, nc4ch2oh_dd, terpnit_dd, nterpooh_dd - endif - !--------------------------------------------------------------------------- - ! ... Open NetCDF file - !--------------------------------------------------------------------------- - call getfil (depvel_file, locfn, 0) - call cam_pio_openfile (piofile, trim(locfn), PIO_NOWRITE) - - !--------------------------------------------------------------------------- - ! ... Get variable ID for dep vel array - !--------------------------------------------------------------------------- - ierr = pio_inq_varid( piofile, 'dvel', vid_dvel ) - - !--------------------------------------------------------------------------- - ! ... Inquire about dimensions - !--------------------------------------------------------------------------- - ierr = pio_inq_dimid( piofile, 'lon', dimid_lon ) - ierr = pio_inq_dimlen( piofile, dimid_lon, nlon ) - ierr = pio_inq_dimid( piofile, 'lat', dimid_lat ) - ierr = pio_inq_dimlen( piofile, dimid_lat, nlat ) - ierr = pio_inq_dimid( piofile, 'species', dimid_species ) - ierr = pio_inq_dimlen( piofile, dimid_species, nspecies ) - ierr = pio_inq_dimid( piofile, 'time', dimid_time ) - ierr = pio_inq_dimlen( piofile, dimid_time, nmonth ) - if(masterproc) write(iulog,*) 'dvel_inti: dimensions (nlon,nlat,nspecies,nmonth) = ',nlon,nlat,nspecies,nmonth - - !--------------------------------------------------------------------------- - ! ... Check dimensions of dvel variable. Must be (lon, lat, species, month). - !--------------------------------------------------------------------------- - ierr = pio_inq_varndims( piofile, vid_dvel, ndims ) - - if( masterproc .and. ndims /= 4 ) then - write(iulog,*) 'dvel_inti: dvel has ',ndims,' dimensions. Expecting 4.' - call endrun - end if - ierr = pio_inq_vardimid( piofile, vid_dvel, dimid ) - - if( dimid(1) /= dimid_lon .or. dimid(2) /= dimid_lat .or. & - dimid(3) /= dimid_species .or. dimid(4) /= dimid_time ) then - write(iulog,*) 'dvel_inti: Dimensions in wrong order for dvel' - write(iulog,*) '... Expecting (lon, lat, species, month)' - call endrun - end if - - !--------------------------------------------------------------------------- - ! ... Allocate depvel lats, lons and read - !--------------------------------------------------------------------------- - allocate( dvel_lats(nlat), stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'dvel_inti: Failed to allocate dvel_lats vector' - call endrun - end if - allocate( dvel_lons(nlon), stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'dvel_inti: Failed to allocate dvel_lons vector' - call endrun - end if - - ierr = pio_inq_varid( piofile, 'lat', vid ) - ierr = pio_get_var( piofile, vid, dvel_lats ) - ierr = pio_inq_varid( piofile, 'lon', vid ) - ierr = pio_get_var( piofile, vid, dvel_lons ) - - !--------------------------------------------------------------------------- - ! ... Set the transform from inputs lats to simulation lats - !--------------------------------------------------------------------------- - dvel_lats(:nlat) = d2r * dvel_lats(:nlat) - dvel_lons(:nlon) = d2r * dvel_lons(:nlon) - - !--------------------------------------------------------------------------- - ! ... Allocate dvel and read data from file - !--------------------------------------------------------------------------- - allocate( dvel_in(nlon, nlat ,nspecies, nmonth), stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'dvel_inti: Failed to allocate dvel_in' - call endrun - end if - start = (/ 1, 1, 1, 1 /) - count = (/ nlon, nlat, nspecies, nmonth /) - - ierr = pio_get_var( piofile, vid_dvel, start, count, dvel_in ) - - - !--------------------------------------------------------------------------- - ! ... Check units of deposition velocity. If necessary, convert to cm/s. - !--------------------------------------------------------------------------- - units(:) = ' ' - ierr = pio_get_att( piofile, vid_dvel, 'units', units ) - if( to_lower(trim(units(:GLC(units)))) == 'm/s' ) then -#ifdef DEBUG - if(masterproc) write(iulog,*) 'dvel_inti: depvel units = m/s. Converting to cm/s' -#endif - scale_factor = 100._r8 - elseif( to_lower(trim(units(:GLC(units)))) == 'cm/s' ) then -#ifdef DEBUG - if(masterproc) write(iulog,*) 'dvel_inti: depvel units = cm/s' -#endif - scale_factor = 1._r8 - else -#ifdef DEBUG - if(masterproc) then - write(iulog,*) 'dvel_inti: Warning! depvel units unknown = ', to_lower(trim(units)) - write(iulog,*) ' ... proceeding with scale_factor=1' - end if -#endif - scale_factor = 1._r8 - end if - - dvel_in(:,:,:,:) = scale_factor*dvel_in(:,:,:,:) - - !--------------------------------------------------------------------------- - ! ... Regrid deposition velocities - !--------------------------------------------------------------------------- - allocate( dvel(pcols,begchunk:endchunk,nspecies,nmonth),stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'dvel_inti: Failed to allocate dvel' - call endrun - end if - - do c=begchunk,endchunk - ncols = get_ncols_p(c) - call get_rlat_all_p(c, pcols, to_lats) - call get_rlon_all_p(c, pcols, to_lons) - call lininterp_init(dvel_lons, nlon, to_lons, ncols, 2, lon_wgts, zero, twopi) - call lininterp_init(dvel_lats, nlat, to_lats, ncols, 1, lat_wgts) - - do ispecies = 1,nspecies - do m = 1,12 - call lininterp( dvel_in( :,:,ispecies,m ), nlon, nlat, dvel(:,c,ispecies,m), ncols,lon_wgts,lat_wgts) - end do - end do - - call lininterp_finish(lat_wgts) - call lininterp_finish(lon_wgts) - end do - - deallocate( dvel_in ) - deallocate( dvel_lats, dvel_lons ) - - !--------------------------------------------------------------------------- - ! ... Read in species names and determine mapping to tracer numbers - !--------------------------------------------------------------------------- - allocate( species_names(nspecies), stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'dvel_inti: species_names allocation error = ',ierr - call endrun - end if - ierr = pio_inq_varid( piofile, 'species_name', vid ) - ierr = pio_inq_varndims( piofile, vid, ndims ) - - ierr = pio_inq_vardimid( piofile, vid, dimid ) - - ierr = pio_inq_dimlen( piofile, dimid(1), nchar ) - map(:) = 0 - do ispecies = 1,nspecies - start(:2) = (/ 1, ispecies /) - count(:2) = (/ nchar, 1 /) - species_names(ispecies)(:) = ' ' - ierr = pio_get_var( piofile, vid, start(1:2), count(1:2), species_names(ispecies:ispecies) ) - if( species_names(ispecies) == 'O3' ) then - o3_in_tab = .true. - o3_tab_ndx = ispecies - else if( species_names(ispecies) == 'H2O2' ) then - h2o2_in_tab = .true. - h2o2_tab_ndx = ispecies - else if( species_names(ispecies) == 'CH3OOH' ) then - ch3ooh_in_tab = .true. - ch3ooh_tab_ndx = ispecies - else if( species_names(ispecies) == 'CO' ) then - co_in_tab = .true. - co_tab_ndx = ispecies - else if( species_names(ispecies) == 'CH3CHO' ) then - ch3cho_in_tab = .true. - ch3cho_tab_ndx = ispecies - end if - found = .false. - do m = 1,gas_pcnst - if( species_names(ispecies) == solsym(m) .or. & - (species_names(ispecies) == 'O3' .and. solsym(m) == 'OX') .or. & - (species_names(ispecies) == 'HNO4' .and. solsym(m) == 'HO2NO2') ) then - if ( has_drydep( solsym(m) ) ) then - map(m) = ispecies - found = .true. -#ifdef DEBUG - if( masterproc ) then - write(iulog,*) 'dvel_inti: ispecies, m, tracnam = ',ispecies,m,trim(solsym(m)) - end if -#endif - exit - end if - end if - end do - if( .not. found ) then - write(iulog,*) 'dvel_inti: Warning! DVEL species ',trim(species_names(ispecies)),' not found' - endif - end do - deallocate( species_names ) - - call cam_pio_closefile( piofile ) - - !--------------------------------------------------------------------------- - ! ... Allocate dvel_interp array - !--------------------------------------------------------------------------- - allocate( dvel_interp(pcols,begchunk:endchunk,nspecies),stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'dvel_inti: Failed to allocate dvel_interp; error = ',ierr - call endrun - end if - - end subroutine dvel_inti_table - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine interpdvel( calday, ncol, lchnk ) - !--------------------------------------------------------------------------- - ! ... Interpolate the fields whose values are required at the - ! begining of a timestep. - !--------------------------------------------------------------------------- - - use time_manager, only : get_calday - - implicit none - - !--------------------------------------------------------------------------- - ! ... Dummy arguments - !--------------------------------------------------------------------------- - real(r8), intent(in) :: calday ! Interpolate the input data to calday - integer, intent(in) :: ncol, lchnk - - !--------------------------------------------------------------------------- - ! ... Local variables - !--------------------------------------------------------------------------- - integer :: m, last, next - integer :: dates(12) = (/ 116, 214, 316, 415, 516, 615, & - 716, 816, 915, 1016, 1115, 1216 /) - real(r8) :: calday_loc, last_days, next_days - real(r8), save :: dys(12) - logical, save :: entered = .false. - - if( .not. entered ) then - do m = 1,12 - dys(m) = get_calday( dates(m), 0 ) - end do - entered = .true. - end if - - if( calday < dys(1) ) then - next = 1 - last = 12 - else if( calday >= dys(12) ) then - next = 1 - last = 12 - else - do m = 11,1,-1 - if( calday >= dys(m) ) then - exit - end if - end do - last = m - next = m + 1 - end if - - last_days = dys( last ) - next_days = dys( next ) - calday_loc = calday - - if( next_days < last_days ) then - next_days = next_days + 365._r8 - end if - if( calday_loc < last_days ) then - calday_loc = calday_loc + 365._r8 - end if - - do m = 1,nspecies - call intp2d( last_days, next_days, calday_loc, ncol, lchnk, & - dvel(:,lchnk,m,last), & - dvel(:,lchnk,m,next), & - dvel_interp(:,lchnk,m) ) - end do - - end subroutine interpdvel - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine intp2d( t1, t2, tint, ncol, lchnk, f1, f2, fint ) - !----------------------------------------------------------------------- - ! ... Linearly interpolate between f1(t1) and f2(t2) to fint(tint). - !----------------------------------------------------------------------- - - implicit none - - !----------------------------------------------------------------------- - ! ... Dummy arguments - !----------------------------------------------------------------------- - real(r8), intent(in) :: & - t1, & ! time level of f1 - t2, & ! time level of f2 - tint ! interpolant time - real(r8), dimension(pcols), intent(in) :: & - f1, & ! field at time t1 - f2 ! field at time t2 - - integer, intent(in) :: ncol, lchnk - - real(r8), intent(out) :: & - fint(pcols) ! field at time tint - - - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - real(r8) :: factor - - factor = (tint - t1)/(t2 - t1) - - fint(:ncol) = f1(:ncol) + (f2(:ncol) - f1(:ncol))*factor - - end subroutine intp2d - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine drydep_table( calday, tsurf, zen_angle, & - depvel, dflx, q, p, & - tv, ncol, icefrac, ocnfrac, lchnk ) - !-------------------------------------------------------- - ! ... Form the deposition velocities for this - ! latitude slice - !-------------------------------------------------------- - - use physconst, only : rair,pi - use dycore, only : dycore_is - - implicit none - - !-------------------------------------------------------- - ! ... Dummy arguments - !-------------------------------------------------------- - integer, intent(in) :: ncol ! columns in chunk - real(r8), intent(in) :: q(pcols,plev,gas_pcnst) ! tracer mmr (kg/kg) - real(r8), intent(in) :: p(pcols) ! midpoint pressure in surface layer (Pa) - real(r8), intent(in) :: tv(pcols) ! virtual temperature in surface layer (K) - real(r8), intent(in) :: calday ! time of year in days - real(r8), intent(in) :: tsurf(pcols) ! surface temperature (K) - real(r8), intent(in) :: zen_angle(ncol) ! zenith angle (radians) - real(r8), intent(inout) :: dflx(pcols,gas_pcnst) ! flux due to dry deposition (kg/m^2/sec) - real(r8), intent(out) :: depvel(ncol,gas_pcnst) ! deposition vel (cm/s) - - real(r8), intent(in) :: icefrac(pcols) ! sea-ice areal fraction - real(r8), intent(in) :: ocnfrac(pcols) ! ocean areal fraction - - integer, intent(in) :: lchnk - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - integer :: m, i - real(r8), dimension(ncol) :: vel, glace, temp_fac, wrk, tmp - real(r8), dimension(ncol) :: o3_tab_dvel - real(r8), dimension(ncol) :: ocean - - real(r8), parameter :: pid2 = .5_r8 * pi - - if(dycore_is('UNSTRUCTURED')) then - call endrun( 'Option not supported for unstructured atmosphere grids ') - end if - - !----------------------------------------------------------------------- - ! ... Note the factor 1.e-2 in the wrk array calculation is - ! to transform the incoming dep vel from cm/s to m/s - !----------------------------------------------------------------------- - wrk(:ncol) = 1.e-2_r8 * p(:ncol) / (rair * tv(:ncol)) - - !-------------------------------------------------------- - ! ... Initialize all deposition velocities to zero - !-------------------------------------------------------- - depvel(:,:) = 0._r8 - - !-------------------------------------------------------- - ! ... Time interpolate primary depvel array - ! (also seaice and npp) - !-------------------------------------------------------- - call interpdvel( calday, ncol, lchnk ) - - if( o3_in_tab ) then - do i=1,ncol - o3_tab_dvel(i) = dvel_interp(i,lchnk,o3_tab_ndx) - enddo - end if - - !-------------------------------------------------------- - ! ... Set deposition velocities - !-------------------------------------------------------- - do m = 1,gas_pcnst - if( map(m) /= 0 ) then - do i = 1,ncol - depvel(i,m) = dvel_interp(i,lchnk,map(m)) - dflx(i,m) = wrk(i) * depvel(i,m) * q(i,plev,m) - enddo - end if - end do - - !-------------------------------------------------------- - ! ... Set some variables needed for some dvel calculations - !-------------------------------------------------------- - temp_fac(:ncol) = min( 1._r8, max( 0._r8, (tsurf(:ncol) - 268._r8) / 5._r8 ) ) - ocean(:ncol) = icefrac(:ncol)+ocnfrac(:ncol) - glace(:ncol) = icefrac(:ncol) + (1._r8 - ocean(:ncol)) * (1._r8 - temp_fac(:ncol)) - glace(:ncol) = min( 1._r8,glace(:ncol) ) - - !-------------------------------------------------------- - ! ... Set pan & mpan - !-------------------------------------------------------- - if( o3_in_tab ) then - tmp(:ncol) = o3_tab_dvel(:ncol) / 3._r8 - else - tmp(:) = 0._r8 - end if - if( pan_dd ) then - if( map(pan_ndx) == 0 ) then - depvel(:ncol,pan_ndx) = tmp(:ncol) - dflx(:ncol,pan_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,pan_ndx) - end if - end if - if( mpan_dd ) then - if( map(mpan_ndx) == 0 ) then - depvel(:ncol,mpan_ndx) = tmp(:ncol) - dflx(:ncol,mpan_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,mpan_ndx) - end if - end if - - !-------------------------------------------------------- - ! ... Set no2 dvel - !-------------------------------------------------------- - if( no2_dd ) then - if( map(no2_ndx) == 0 .and. o3_in_tab ) then - depvel(:ncol,no2_ndx) = (.6_r8*o3_tab_dvel(:ncol) + .055_r8*ocean(:ncol)) * .9_r8 - dflx(:ncol,no2_ndx) = wrk(:) * depvel(:ncol,no2_ndx) * q(:ncol,plev,no2_ndx) - end if - end if - - !-------------------------------------------------------- - ! ... Set hno3 dvel - !-------------------------------------------------------- - tmp(:ncol) = (2._r8 - ocnfrac(:ncol)) * (1._r8 - glace(:ncol)) + .05_r8 * glace(:ncol) - if( hno3_dd ) then - if( map(hno3_ndx) == 0 ) then - depvel(:ncol,hno3_ndx) = tmp(:ncol) - dflx(:ncol,hno3_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,hno3_ndx) - else - tmp(:ncol) = depvel(:ncol,hno3_ndx) - end if - end if - if( onitr_dd ) then - if( map(onitr_ndx) == 0 ) then - depvel(:ncol,onitr_ndx) = tmp(:ncol) - dflx(:ncol,onitr_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,onitr_ndx) - end if - end if - if( isopooh_dd ) then - if( map(isopooh_ndx) == 0 ) then - depvel(:ncol,isopooh_ndx) = tmp(:ncol) - dflx(:ncol,isopooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,isopooh_ndx) - end if - end if - - !-------------------------------------------------------- - ! ... Set h2o2 dvel - !-------------------------------------------------------- - if( .not. h2o2_in_tab ) then - if( o3_in_tab ) then - tmp(:ncol) = .05_r8*glace(:ncol) + ocean(:ncol) - icefrac(:ncol) & - + (1._r8 - (glace(:) + ocean(:ncol)) + icefrac(:ncol)) & - *max( 1._r8,1._r8/(.5_r8 + 1._r8/(6._r8*o3_tab_dvel(:ncol))) ) - else - tmp(:ncol) = 0._r8 - end if - else - do i=1,ncol - tmp(i) = dvel_interp(i,lchnk,h2o2_tab_ndx) - enddo - end if - if( h2o2_dd ) then - if( map(h2o2_ndx) == 0 ) then - depvel(:ncol,h2o2_ndx) = tmp(:ncol) - dflx(:ncol,h2o2_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,h2o2_ndx) - end if - end if - !-------------------------------------------------------- - ! ... Set hcn dvel - !-------------------------------------------------------- - if( hcn_dd ) then - if( map(hcn_ndx) == 0 ) then - depvel(:ncol,hcn_ndx) = ocnfrac(:ncol)*0.2_r8 - endif - endif - !-------------------------------------------------------- - ! ... Set ch3cn dvel - !-------------------------------------------------------- - if( ch3cn_dd ) then - if( map(ch3cn_ndx) == 0 ) then - depvel(:,ch3cn_ndx) = ocnfrac(:ncol)*0.2_r8 - endif - endif - !-------------------------------------------------------- - ! ... Set onit - !-------------------------------------------------------- - if( onit_dd ) then - if( map(onit_ndx) == 0 ) then - depvel(:ncol,onit_ndx) = tmp(:ncol) - dflx(:ncol,onit_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,onit_ndx) - end if - end if - if( ch3cocho_dd ) then - if( map(ch3cocho_ndx) == 0 ) then - depvel(:ncol,ch3cocho_ndx) = tmp(:ncol) - dflx(:ncol,ch3cocho_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3cocho_ndx) - end if - end if - if( ch3ooh_in_tab ) then - do i=1,ncol - tmp(i) = dvel_interp(i,lchnk,ch3ooh_tab_ndx) - enddo - else - tmp(:ncol) = .5_r8 * tmp(:ncol) - end if - if( ch3ooh_dd ) then - if( map(ch3ooh_ndx) == 0 ) then - depvel(:ncol,ch3ooh_ndx) = tmp(:ncol) - dflx(:ncol,ch3ooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3ooh_ndx) - end if - end if - if( pooh_dd ) then - if( map(pooh_ndx) == 0 ) then - depvel(:ncol,pooh_ndx) = tmp(:ncol) - dflx(:ncol,pooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,pooh_ndx) - end if - end if - if( ch3coooh_dd ) then - if( map(ch3coooh_ndx) == 0 ) then - depvel(:ncol,ch3coooh_ndx) = tmp(:ncol) - dflx(:ncol,ch3coooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3coooh_ndx) - end if - end if - if( c2h5ooh_dd ) then - if( map(c2h5ooh_ndx) == 0 ) then - depvel(:ncol,c2h5ooh_ndx) = tmp(:ncol) - dflx(:ncol,c2h5ooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,c2h5ooh_ndx) - end if - end if - if( c3h7ooh_dd ) then - if( map(c3h7ooh_ndx) == 0 ) then - depvel(:ncol,c3h7ooh_ndx) = tmp(:ncol) - dflx(:ncol,c3h7ooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,c3h7ooh_ndx) - end if - end if - if( rooh_dd ) then - if( map(rooh_ndx) == 0 ) then - depvel(:ncol,rooh_ndx) = tmp(:ncol) - dflx(:ncol,rooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,rooh_ndx) - end if - end if - if( macrooh_dd ) then - if( map(macrooh_ndx) == 0 ) then - depvel(:ncol,macrooh_ndx) = tmp(:ncol) - dflx(:ncol,macrooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,macrooh_ndx) - end if - end if - if( xooh_dd ) then - if( map(xooh_ndx) == 0 ) then - depvel(:ncol,xooh_ndx) = tmp(:ncol) - dflx(:ncol,xooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,xooh_ndx) - end if - end if - if( ch3oh_dd ) then - if( map(ch3oh_ndx) == 0 ) then - depvel(:ncol,ch3oh_ndx) = tmp(:ncol) - dflx(:ncol,ch3oh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3oh_ndx) - end if - end if - if( c2h5oh_dd ) then - if( map(c2h5oh_ndx) == 0 ) then - depvel(:ncol,c2h5oh_ndx) = tmp(:ncol) - dflx(:ncol,c2h5oh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,c2h5oh_ndx) - end if - end if - if( alkooh_dd ) then - if( map(alkooh_ndx) == 0 ) then - depvel(:ncol,alkooh_ndx) = tmp(:ncol) - dflx(:ncol,alkooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,alkooh_ndx) - end if - end if - if( mekooh_dd ) then - if( map(mekooh_ndx) == 0 ) then - depvel(:ncol,mekooh_ndx) = tmp(:ncol) - dflx(:ncol,mekooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,mekooh_ndx) - end if - end if - if( tolooh_dd ) then - if( map(tolooh_ndx) == 0 ) then - depvel(:ncol,tolooh_ndx) = tmp(:ncol) - dflx(:ncol,tolooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,tolooh_ndx) - end if - end if - if( o3_in_tab ) then - tmp(:ncol) = o3_tab_dvel(:ncol) - else - tmp(:ncol) = 0._r8 - end if - if( ch2o_dd ) then - if( map(ch2o_ndx) == 0 ) then - depvel(:ncol,ch2o_ndx) = tmp(:ncol) - dflx(:ncol,ch2o_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch2o_ndx) - end if - end if - - if( hydrald_dd ) then - if( map(hydrald_ndx) == 0 ) then - depvel(:ncol,hydrald_ndx) = tmp(:ncol) - dflx(:ncol,hydrald_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,hydrald_ndx) - end if - end if - if( ch3cooh_dd ) then - if( map(ch3cooh_ndx) == 0 ) then - depvel(:ncol,ch3cooh_ndx) = depvel(:ncol,ch2o_ndx) - dflx(:ncol,ch3cooh_ndx) = wrk(:ncol) * depvel(:ncol,ch3cooh_ndx) * q(:ncol,plev,ch3cooh_ndx) - end if - end if - if( eooh_dd ) then - if( map(eooh_ndx) == 0 ) then - depvel(:ncol,eooh_ndx) = depvel(:ncol,ch2o_ndx) - dflx(:ncol,eooh_ndx) = wrk(:ncol) * depvel(:ncol,eooh_ndx) * q(:ncol,plev,eooh_ndx) - end if - end if - ! HCOOH - set to CH3COOH - if( hcooh_dd ) then - if( map(hcooh_ndx) == 0 ) then - depvel(:ncol,hcooh_ndx) = depvel(:ncol,ch2o_ndx) - dflx(:ncol,hcooh_ndx) = wrk(:ncol) * depvel(:ncol,hcooh_ndx) * q(:ncol,plev,hcooh_ndx) - end if - end if - - !-------------------------------------------------------- - ! ... Set co and related species dep vel - !-------------------------------------------------------- - if( co_in_tab ) then - do i=1,ncol - tmp(i) = dvel_interp(i,lchnk,co_tab_ndx) - enddo - else - tmp(:) = 0._r8 - end if - if( co_dd ) then - if( map(co_ndx) == 0 ) then - depvel(:ncol,co_ndx) = tmp(:ncol) - dflx(:ncol,co_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,co_ndx) - end if - end if - if( ch3coch3_dd ) then - if( map(ch3coch3_ndx) == 0 ) then - depvel(:ncol,ch3coch3_ndx) = tmp(:ncol) - dflx(:ncol,ch3coch3_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,ch3coch3_ndx) - end if - end if - if( hyac_dd ) then - if( map(hyac_ndx) == 0 ) then - depvel(:ncol,hyac_ndx) = tmp(:ncol) - dflx(:ncol,hyac_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,hyac_ndx) - end if - end if - if( h2_dd ) then - if( map(h2_ndx) == 0 ) then - depvel(:ncol,h2_ndx) = tmp(:ncol) * 1.5_r8 ! Hough(1991) - dflx(:ncol,h2_ndx) = wrk(:ncol) * depvel(:ncol,h2_ndx) * q(:ncol,plev,h2_ndx) - end if - end if - - !-------------------------------------------------------- - ! ... Set glyald - !-------------------------------------------------------- - if( glyald_dd ) then - if( map(glyald_ndx) == 0 ) then - if( ch3cho_dd ) then - depvel(:ncol,glyald_ndx) = depvel(:ncol,ch3cho_ndx) - else if( ch3cho_in_tab ) then - do i=1,ncol - depvel(i,glyald_ndx) = dvel_interp(i,lchnk,ch3cho_tab_ndx) - enddo - else - depvel(:ncol,glyald_ndx) = 0._r8 - end if - dflx(:ncol,glyald_ndx) = wrk(:ncol) * depvel(:ncol,glyald_ndx) * q(:ncol,plev,glyald_ndx) - end if - end if - - !-------------------------------------------------------- - ! ... Lead deposition - !-------------------------------------------------------- - if( Pb_dd ) then - if( map(Pb_ndx) == 0 ) then - depvel(:ncol,Pb_ndx) = ocean(:ncol) * .05_r8 + (1._r8 - ocean(:ncol)) * .2_r8 - dflx(:ncol,Pb_ndx) = wrk(:ncol) * depvel(:ncol,Pb_ndx) * q(:ncol,plev,Pb_ndx) - end if - end if - - !-------------------------------------------------------- - ! ... diurnal dependence for OX dvel - !-------------------------------------------------------- - if( o3_dd .or. o3s_dd .or. o3inert_dd ) then - if( o3_dd .or. o3_in_tab ) then - if( o3_dd ) then - tmp(:ncol) = max( 1._r8,sqrt( (depvel(:ncol,o3_ndx) - .2_r8)**3/.27_r8 + 4._r8*depvel(:ncol,o3_ndx) + .67_r8 ) ) - vel(:ncol) = depvel(:ncol,o3_ndx) - else if( o3_in_tab ) then - tmp(:ncol) = max( 1._r8,sqrt( (o3_tab_dvel(:ncol) - .2_r8)**3/.27_r8 + 4._r8*o3_tab_dvel(:ncol) + .67_r8 ) ) - vel(:ncol) = o3_tab_dvel(:ncol) - end if - where( abs( zen_angle(:) ) > pid2 ) - vel(:) = vel(:) / tmp(:) - elsewhere - vel(:) = vel(:) * tmp(:) - endwhere - - else - vel(:ncol) = 0._r8 - end if - if( o3_dd ) then - depvel(:ncol,o3_ndx) = vel(:ncol) - dflx(:ncol,o3_ndx) = wrk(:ncol) * vel(:ncol) * q(:ncol,plev,o3_ndx) - end if - !-------------------------------------------------------- - ! ... Set stratospheric O3 deposition - !-------------------------------------------------------- - if( o3s_dd ) then - depvel(:ncol,o3s_ndx) = vel(:ncol) - dflx(:ncol,o3s_ndx) = wrk(:ncol) * vel(:ncol) * q(:ncol,plev,o3s_ndx) - end if - if( o3inert_dd ) then - depvel(:ncol,o3inert_ndx) = vel(:ncol) - dflx(:ncol,o3inert_ndx) = wrk(:ncol) * vel(:ncol) * q(:ncol,plev,o3inert_ndx) - end if - end if - - if( xno2_dd ) then - if( map(xno2_ndx) == 0 ) then - depvel(:ncol,xno2_ndx) = depvel(:ncol,no2_ndx) - dflx(:ncol,xno2_ndx) = wrk(:ncol) * depvel(:ncol,xno2_ndx) * q(:ncol,plev,xno2_ndx) - end if - endif - if( o3a_dd ) then - if( map(o3a_ndx) == 0 ) then - depvel(:ncol,o3a_ndx) = depvel(:ncol,o3_ndx) - dflx(:ncol,o3a_ndx) = wrk(:ncol) * depvel(:ncol,o3a_ndx) * q(:ncol,plev,o3a_ndx) - end if - endif - if( xhno3_dd ) then - if( map(xhno3_ndx) == 0 ) then - depvel(:ncol,xhno3_ndx) = depvel(:ncol,hno3_ndx) - dflx(:ncol,xhno3_ndx) = wrk(:ncol) * depvel(:ncol,xhno3_ndx) * q(:ncol,plev,xhno3_ndx) - end if - endif - if( xnh4no3_dd ) then - if( map(xnh4no3_ndx) == 0 ) then - depvel(:ncol,xnh4no3_ndx) = depvel(:ncol,nh4no3_ndx) - dflx(:ncol,xnh4no3_ndx) = wrk(:ncol) * depvel(:ncol,xnh4no3_ndx) * q(:ncol,plev,xnh4no3_ndx) - end if - endif - if( xpan_dd ) then - if( map(xpan_ndx) == 0 ) then - depvel(:ncol,xpan_ndx) = depvel(:ncol,pan_ndx) - dflx(:ncol,xpan_ndx) = wrk(:ncol) * depvel(:ncol,xpan_ndx) * q(:ncol,plev,xpan_ndx) - end if - endif - if( xmpan_dd ) then - if( map(xmpan_ndx) == 0 ) then - depvel(:ncol,xmpan_ndx) = depvel(:ncol,mpan_ndx) - dflx(:ncol,xmpan_ndx) = wrk(:ncol) * depvel(:ncol,xmpan_ndx) * q(:ncol,plev,xmpan_ndx) - end if - endif - if( xonit_dd ) then - if( map(xonit_ndx) == 0 ) then - depvel(:ncol,xonit_ndx) = depvel(:ncol,onit_ndx) - dflx(:ncol,xonit_ndx) = wrk(:ncol) * depvel(:ncol,xonit_ndx) * q(:ncol,plev,xonit_ndx) - end if - endif - if( xonitr_dd ) then - if( map(xonitr_ndx) == 0 ) then - depvel(:ncol,xonitr_ndx) = depvel(:ncol,onitr_ndx) - dflx(:ncol,xonitr_ndx) = wrk(:ncol) * depvel(:ncol,xonitr_ndx) * q(:ncol,plev,xonitr_ndx) - end if - endif - if( xno_dd ) then - if( map(xno_ndx) == 0 ) then - depvel(:ncol,xno_ndx) = depvel(:ncol,no_ndx) - dflx(:ncol,xno_ndx) = wrk(:ncol) * depvel(:ncol,xno_ndx) * q(:ncol,plev,xno_ndx) - end if - endif - if( xho2no2_dd ) then - if( map(xho2no2_ndx) == 0 ) then - depvel(:ncol,xho2no2_ndx) = depvel(:ncol,ho2no2_ndx) - dflx(:ncol,xho2no2_ndx) = wrk(:ncol) * depvel(:ncol,xho2no2_ndx) * q(:ncol,plev,xho2no2_ndx) - end if - endif - !lke-TS1 - if( phenooh_dd ) then - if( map(phenooh_ndx) == 0 ) then - depvel(:ncol,phenooh_ndx) = depvel(:ncol,ch3ooh_ndx) - dflx(:ncol,phenooh_ndx) = wrk(:ncol) * depvel(:ncol,phenooh_ndx) * q(:ncol,plev,phenooh_ndx) - end if - endif - if( benzooh_dd ) then - if( map(benzooh_ndx) == 0 ) then - depvel(:ncol,benzooh_ndx) = depvel(:ncol,ch3ooh_ndx) - dflx(:ncol,benzooh_ndx) = wrk(:ncol) * depvel(:ncol,benzooh_ndx) * q(:ncol,plev,benzooh_ndx) - end if - endif - if( c6h5ooh_dd ) then - if( map(c6h5ooh_ndx) == 0 ) then - depvel(:ncol,c6h5ooh_ndx) = depvel(:ncol,ch3ooh_ndx) - dflx(:ncol,c6h5ooh_ndx) = wrk(:ncol) * depvel(:ncol,c6h5ooh_ndx) * q(:ncol,plev,c6h5ooh_ndx) - end if - endif - if( bzooh_dd ) then - if( map(bzooh_ndx) == 0 ) then - depvel(:ncol,bzooh_ndx) = depvel(:ncol,ch3ooh_ndx) - dflx(:ncol,bzooh_ndx) = wrk(:ncol) * depvel(:ncol,bzooh_ndx) * q(:ncol,plev,bzooh_ndx) - end if - endif - if( xylolooh_dd ) then - if( map(xylolooh_ndx) == 0 ) then - depvel(:ncol,xylolooh_ndx) = depvel(:ncol,ch3ooh_ndx) - dflx(:ncol,xylolooh_ndx) = wrk(:ncol) * depvel(:ncol,xylolooh_ndx) * q(:ncol,plev,xylolooh_ndx) - end if - endif - if( xylenooh_dd ) then - if( map(xylenooh_ndx) == 0 ) then - depvel(:ncol,xylenooh_ndx) = depvel(:ncol,ch3ooh_ndx) - dflx(:ncol,xylenooh_ndx) = wrk(:ncol) * depvel(:ncol,xylenooh_ndx) * q(:ncol,plev,xylenooh_ndx) - end if - endif - if( terpooh_dd ) then - if( map(terpooh_ndx) == 0 ) then - depvel(:ncol,terpooh_ndx) = depvel(:ncol,isopooh_ndx) - dflx(:ncol,terpooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,terpooh_ndx) - end if - end if - if( terp2ooh_dd ) then - if( map(terp2ooh_ndx) == 0 ) then - depvel(:ncol,terp2ooh_ndx) = depvel(:ncol,isopooh_ndx) - dflx(:ncol,terp2ooh_ndx) = wrk(:ncol) * tmp(:ncol) * q(:ncol,plev,terp2ooh_ndx) - end if - end if - if( terprod1_dd ) then - if( map(terprod1_ndx) == 0 ) then - depvel(:ncol,terprod1_ndx) = depvel(:ncol,hyac_ndx) - dflx(:ncol,terprod1_ndx) = wrk(:ncol) * depvel(:ncol,terprod1_ndx) * q(:ncol,plev,terprod1_ndx) - end if - endif - if( terprod2_dd ) then - if( map(terprod2_ndx) == 0 ) then - depvel(:ncol,terprod2_ndx) = depvel(:ncol,hyac_ndx) - dflx(:ncol,terprod2_ndx) = wrk(:ncol) * depvel(:ncol,terprod2_ndx) * q(:ncol,plev,terprod2_ndx) - end if - endif - if( hmprop_dd ) then - if( map(hmprop_ndx) == 0 ) then - depvel(:ncol,hmprop_ndx) = depvel(:ncol,glyald_ndx) - dflx(:ncol,hmprop_ndx) = wrk(:ncol) * depvel(:ncol,hmprop_ndx) * q(:ncol,plev,hmprop_ndx) - end if - endif - if( mboooh_dd ) then - if( map(mboooh_ndx) == 0 ) then - depvel(:ncol,mboooh_ndx) = depvel(:ncol,isopooh_ndx) - dflx(:ncol,mboooh_ndx) = wrk(:ncol) * depvel(:ncol,mboooh_ndx) * q(:ncol,plev,mboooh_ndx) - end if - endif - if( hpald_dd ) then - if( map(hpald_ndx) == 0 ) then - depvel(:ncol,hpald_ndx) = depvel(:ncol,ch3ooh_ndx) - dflx(:ncol,hpald_ndx) = wrk(:ncol) * depvel(:ncol,hpald_ndx) * q(:ncol,plev,hpald_ndx) - end if - endif - if( iepox_dd ) then - if( map(iepox_ndx) == 0 ) then - depvel(:ncol,iepox_ndx) = depvel(:ncol,hyac_ndx) - dflx(:ncol,iepox_ndx) = wrk(:ncol) * depvel(:ncol,iepox_ndx) * q(:ncol,plev,iepox_ndx) - end if - endif - if( noa_dd ) then - if( map(noa_ndx) == 0 ) then - depvel(:ncol,noa_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,noa_ndx) = wrk(:ncol) * depvel(:ncol,noa_ndx) * q(:ncol,plev,noa_ndx) - end if - endif - if( alknit_dd ) then - if( map(alknit_ndx) == 0 ) then - depvel(:ncol,alknit_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,alknit_ndx) = wrk(:ncol) * depvel(:ncol,alknit_ndx) * q(:ncol,plev,alknit_ndx) - end if - endif - if( isopnita_dd ) then - if( map(isopnita_ndx) == 0 ) then - depvel(:ncol,isopnita_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,isopnita_ndx) = wrk(:ncol) * depvel(:ncol,isopnita_ndx) * q(:ncol,plev,isopnita_ndx) - end if - endif - if( isopnitb_dd ) then - if( map(isopnitb_ndx) == 0 ) then - depvel(:ncol,isopnitb_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,isopnitb_ndx) = wrk(:ncol) * depvel(:ncol,isopnitb_ndx) * q(:ncol,plev,isopnitb_ndx) - end if - endif - if( honitr_dd ) then - if( map(honitr_ndx) == 0 ) then - depvel(:ncol,honitr_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,honitr_ndx) = wrk(:ncol) * depvel(:ncol,honitr_ndx) * q(:ncol,plev,honitr_ndx) - end if - endif - if( isopnooh_dd ) then - if( map(isopnooh_ndx) == 0 ) then - depvel(:ncol,isopnooh_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,isopnooh_ndx) = wrk(:ncol) * depvel(:ncol,isopnooh_ndx) * q(:ncol,plev,isopnooh_ndx) - end if - endif - if( nc4cho_dd ) then - if( map(nc4cho_ndx) == 0 ) then - depvel(:ncol,nc4cho_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,nc4cho_ndx) = wrk(:ncol) * depvel(:ncol,nc4cho_ndx) * q(:ncol,plev,nc4cho_ndx) - end if - endif - if( nc4ch2oh_dd ) then - if( map(nc4ch2oh_ndx) == 0 ) then - depvel(:ncol,nc4ch2oh_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,nc4ch2oh_ndx) = wrk(:ncol) * depvel(:ncol,nc4ch2oh_ndx) * q(:ncol,plev,nc4ch2oh_ndx) - end if - endif - if( terpnit_dd ) then - if( map(terpnit_ndx) == 0 ) then - depvel(:ncol,terpnit_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,terpnit_ndx) = wrk(:ncol) * depvel(:ncol,terpnit_ndx) * q(:ncol,plev,terpnit_ndx) - end if - endif - if( nterpooh_dd ) then - if( map(nterpooh_ndx) == 0 ) then - depvel(:ncol,nterpooh_ndx) = depvel(:ncol,h2o2_ndx) - dflx(:ncol,nterpooh_ndx) = wrk(:ncol) * depvel(:ncol,nterpooh_ndx) * q(:ncol,plev,nterpooh_ndx) - end if - endif - - - end subroutine drydep_table - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine dvel_inti_xactive( depvel_lnd_file, clim_soilw_file, season_wes_file ) - !------------------------------------------------------------------------------------- - ! ... intialize interactive drydep - !------------------------------------------------------------------------------------- - use dycore, only : dycore_is - use mo_constants, only : r2d - use chem_mods, only : adv_mass - use mo_chem_utls, only : get_spc_ndx - use seq_drydep_mod,only : drydep_method, DD_XATM, DD_XLND - use phys_control, only : phys_getopts - - implicit none - - !------------------------------------------------------------------------------------- - ! ... dummy arguments - !------------------------------------------------------------------------------------- - character(len=*), intent(in) :: depvel_lnd_file, clim_soilw_file, season_wes_file - - !------------------------------------------------------------------------------------- - ! ... local variables - !------------------------------------------------------------------------------------- - integer :: i, j, ii, jj, jl, ju - integer :: nlon_veg, nlat_veg, npft_veg - integer :: nlat_lai, npft_lai, pos_min, imin - integer :: dimid - integer :: m, n, l, id - integer :: length1, astat - integer, allocatable :: wk_lai(:,:,:) - integer, allocatable :: index_season_lai_j(:,:) - integer :: k, num_max, k_max - integer :: num_seas(5) - integer :: plon, plat - integer :: ierr, ndx - - real(r8) :: spc_mass - real(r8) :: diff_min, target_lat - real(r8), allocatable :: vegetation_map(:,:,:) - real(r8), pointer :: soilw_map(:,:,:) - real(r8), allocatable :: work(:,:) - real(r8), allocatable :: landmask(:,:) - real(r8), allocatable :: urban(:,:) - real(r8), allocatable :: lake(:,:) - real(r8), allocatable :: wetland(:,:) - real(r8), allocatable :: lon_veg(:) - real(r8), allocatable :: lon_veg_edge(:) - real(r8), allocatable :: lat_veg(:) - real(r8), allocatable :: lat_veg_edge(:) - real(r8), allocatable :: lat_lai(:) - real(r8), allocatable :: clat(:) - character(len=32) :: test_name - character(len=4) :: tag_name - type(file_desc_t) :: piofile - type(var_desc_t) :: vid - logical :: do_soilw - - character(len=shr_kind_cl) :: locfn - logical :: prog_modal_aero - - ! determine if modal aerosols are active so that fraction_landuse array is initialized for modal aerosal dry dep - call phys_getopts(prog_modal_aero_out=prog_modal_aero) -#ifdef OSLO_AERO - prog_modal_aero = .TRUE. -#endif - - call dvel_inti_fromlnd() - - if( masterproc ) then - write(iulog,*) 'drydep_inti: following species have dry deposition' - do i=1,nddvels - if( len_trim(drydep_list(i)) > 0 ) then - write(iulog,*) 'drydep_inti: '//trim(drydep_list(i))//' is requested to have dry dep' - endif - enddo - write(iulog,*) 'drydep_inti:' - endif - - !------------------------------------------------------------------------------------- - ! ... get species indices - !------------------------------------------------------------------------------------- - xpan_ndx = get_spc_ndx( 'XPAN' ) - xmpan_ndx = get_spc_ndx( 'XMPAN' ) - o3a_ndx = get_spc_ndx( 'O3A' ) - - ch4_ndx = get_spc_ndx( 'CH4' ) - h2_ndx = get_spc_ndx( 'H2' ) - co_ndx = get_spc_ndx( 'CO' ) - Pb_ndx = get_spc_ndx( 'Pb' ) - pan_ndx = get_spc_ndx( 'PAN' ) - mpan_ndx = get_spc_ndx( 'MPAN' ) - o3_ndx = get_spc_ndx( 'OX' ) - if( o3_ndx < 0 ) then - o3_ndx = get_spc_ndx( 'O3' ) - end if - so2_ndx = get_spc_ndx( 'SO2' ) - alkooh_ndx = get_spc_ndx( 'ALKOOH') - mekooh_ndx = get_spc_ndx( 'MEKOOH') - tolooh_ndx = get_spc_ndx( 'TOLOOH') - terpooh_ndx = get_spc_ndx( 'TERPOOH') - ch3cooh_ndx = get_spc_ndx( 'CH3COOH') - soa_ndx = get_spc_ndx( 'SOA' ) - so4_ndx = get_spc_ndx( 'SO4' ) - cb1_ndx = get_spc_ndx( 'CB1' ) - cb2_ndx = get_spc_ndx( 'CB2' ) - oc1_ndx = get_spc_ndx( 'OC1' ) - oc2_ndx = get_spc_ndx( 'OC2' ) - nh3_ndx = get_spc_ndx( 'NH3' ) - nh4no3_ndx = get_spc_ndx( 'NH4NO3' ) - sa1_ndx = get_spc_ndx( 'SA1' ) - sa2_ndx = get_spc_ndx( 'SA2' ) - sa3_ndx = get_spc_ndx( 'SA3' ) - sa4_ndx = get_spc_ndx( 'SA4' ) - nh4_ndx = get_spc_ndx( 'NH4' ) - alkooh_dd = has_drydep( 'ALKOOH') - mekooh_dd = has_drydep( 'MEKOOH') - tolooh_dd = has_drydep( 'TOLOOH') - terpooh_dd = has_drydep( 'TERPOOH') - ch3cooh_dd = has_drydep( 'CH3COOH') - soa_dd = has_drydep( 'SOA' ) - so4_dd = has_drydep( 'SO4' ) - cb1_dd = has_drydep( 'CB1' ) - cb2_dd = has_drydep( 'CB2' ) - oc1_dd = has_drydep( 'OC1' ) - oc2_dd = has_drydep( 'OC2' ) - nh3_dd = has_drydep( 'NH3' ) - nh4no3_dd = has_drydep( 'NH4NO3' ) - sa1_dd = has_drydep( 'SA1' ) - sa2_dd = has_drydep( 'SA2' ) - sa3_dd = has_drydep( 'SA3' ) - sa4_dd = has_drydep( 'SA4' ) - nh4_dd = has_drydep( 'NH4' ) -! - soam_ndx = get_spc_ndx( 'SOAM' ) - soai_ndx = get_spc_ndx( 'SOAI' ) - soat_ndx = get_spc_ndx( 'SOAT' ) - soab_ndx = get_spc_ndx( 'SOAB' ) - soax_ndx = get_spc_ndx( 'SOAX' ) - sogm_ndx = get_spc_ndx( 'SOGM' ) - sogi_ndx = get_spc_ndx( 'SOGI' ) - sogt_ndx = get_spc_ndx( 'SOGT' ) - sogb_ndx = get_spc_ndx( 'SOGB' ) - sogx_ndx = get_spc_ndx( 'SOGX' ) - soam_dd = has_drydep ( 'SOAM' ) - soai_dd = has_drydep ( 'SOAI' ) - soat_dd = has_drydep ( 'SOAT' ) - soab_dd = has_drydep ( 'SOAB' ) - soax_dd = has_drydep ( 'SOAX' ) - sogm_dd = has_drydep ( 'SOGM' ) - sogi_dd = has_drydep ( 'SOGI' ) - sogt_dd = has_drydep ( 'SOGT' ) - sogb_dd = has_drydep ( 'SOGB' ) - sogx_dd = has_drydep ( 'SOGX' ) -! - hcn_ndx = get_spc_ndx( 'HCN') - ch3cn_ndx = get_spc_ndx( 'CH3CN') - -!lke-TS1 - phenooh_ndx = get_spc_ndx( 'PHENOOH') - benzooh_ndx = get_spc_ndx( 'BENZOOH') - c6h5ooh_ndx = get_spc_ndx( 'C6H5OOH') - bzooh_ndx = get_spc_ndx( 'BZOOH') - xylolooh_ndx = get_spc_ndx( 'XYLOLOOH') - xylenooh_ndx = get_spc_ndx( 'XYLENOOH') - terp2ooh_ndx = get_spc_ndx( 'TERP2OOH') - terprod1_ndx = get_spc_ndx( 'TERPROD1') - terprod2_ndx = get_spc_ndx( 'TERPROD2') - hmprop_ndx = get_spc_ndx( 'HMPROP') - mboooh_ndx = get_spc_ndx( 'MBOOOH') - hpald_ndx = get_spc_ndx( 'HPALD') - iepox_ndx = get_spc_ndx( 'IEPOX') - noa_ndx = get_spc_ndx( 'NOA') - alknit_ndx = get_spc_ndx( 'ALKNIT') - isopnita_ndx = get_spc_ndx( 'ISOPNITA') - isopnitb_ndx = get_spc_ndx( 'ISOPNITB') - honitr_ndx = get_spc_ndx( 'HONITR') - isopnooh_ndx = get_spc_ndx( 'ISOPNOOH') - nc4cho_ndx = get_spc_ndx( 'NC4CHO') - nc4ch2oh_ndx = get_spc_ndx( 'NC4CH2OH') - terpnit_ndx = get_spc_ndx( 'TERPNIT') - nterpooh_ndx = get_spc_ndx( 'NTERPOOH') - phenooh_dd = has_drydep( 'PHENOOH') - benzooh_dd = has_drydep( 'BENZOOH') - c6h5ooh_dd = has_drydep( 'C6H5OOH') - bzooh_dd = has_drydep( 'BZOOH') - xylolooh_dd = has_drydep( 'XYLOLOOH') - xylenooh_dd = has_drydep( 'XYLENOOH') - terp2ooh_dd = has_drydep( 'TERP2OOH') - terprod1_dd = has_drydep( 'TERPROD1') - terprod2_dd = has_drydep( 'TERPROD2') - hmprop_dd = has_drydep( 'HMPROP') - mboooh_dd = has_drydep( 'MBOOOH') - hpald_dd = has_drydep( 'HPALD') - iepox_dd = has_drydep( 'IEPOX') - noa_dd = has_drydep( 'NOA') - alknit_dd = has_drydep( 'ALKNIT') - isopnita_dd = has_drydep( 'ISOPNITA') - isopnitb_dd = has_drydep( 'ISOPNITB') - honitr_dd = has_drydep( 'HONITR') - isopnooh_dd = has_drydep( 'ISOPNOOH') - nc4cho_dd = has_drydep( 'NC4CHO') - nc4ch2oh_dd = has_drydep( 'NC4CH2OH') - terpnit_dd = has_drydep( 'TERPNIT') - nterpooh_dd = has_drydep( 'NTERPOOH') -! - cohc_ndx = get_spc_ndx( 'COhc' ) - come_ndx = get_spc_ndx( 'COme' ) - - tag_cnt=0 - cotag_ndx(:)=-1 - do i = 1,NTAGS - write(tag_name,'(a2,i2.2)') 'CO',i - ndx = get_spc_ndx(tag_name) - if (ndx>0) then - tag_cnt = tag_cnt+1 - cotag_ndx(tag_cnt) = ndx - endif - enddo - - o3s_ndx = get_spc_ndx( 'O3S' ) - - do i=1,nddvels - if ( mapping(i) > 0 ) then - test_name = drydep_list(i) - m = get_spc_ndx( test_name ) - has_dvel(m) = .true. - map_dvel(m) = i - endif - enddo - - if( all( .not. has_dvel(:) ) ) then - return - end if - - !--------------------------------------------------------------------------- - ! ... allocate module variables - !--------------------------------------------------------------------------- - allocate( dep_ra(pcols,n_land_type,begchunk:endchunk),stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate dep_ra; error = ',astat - call endrun - end if - allocate( dep_rb(pcols,n_land_type,begchunk:endchunk),stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate dep_rb; error = ',astat - call endrun - end if - - if (drydep_method == DD_XLND .and. (.not.prog_modal_aero)) then - return - endif - - do_soilw = .not. dyn_soilw .and. (has_drydep( 'H2' ) .or. has_drydep( 'CO' )) - allocate( fraction_landuse(pcols,n_land_type, begchunk:endchunk),stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate fraction_landuse; error = ',astat - call endrun - end if - if(do_soilw) then - allocate(soilw_3d(pcols,12,begchunk:endchunk),stat=astat) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate soilw_3d error = ',astat - call endrun - end if - end if - - plon = get_dyn_grid_parm('plon') - plat = get_dyn_grid_parm('plat') - allocate( index_season_lai_j(n_land_type,12),stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate index_season_lai_j; error = ',astat - call endrun - end if - if(dycore_is('UNSTRUCTURED') ) then - call get_landuse_and_soilw_from_file(do_soilw) - allocate( index_season_lai(plon,12),stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate index_season_lai; error = ',astat - call endrun - end if - else - allocate( index_season_lai(plat,12),stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate index_season_lai; error = ',astat - call endrun - end if - !--------------------------------------------------------------------------- - ! ... read landuse map - !--------------------------------------------------------------------------- - call getfil (depvel_lnd_file, locfn, 0) - call cam_pio_openfile (piofile, trim(locfn), PIO_NOWRITE) - !--------------------------------------------------------------------------- - ! ... get the dimensions - !--------------------------------------------------------------------------- - ierr = pio_inq_dimid( piofile, 'lon', dimid ) - ierr = pio_inq_dimlen( piofile, dimid, nlon_veg ) - ierr = pio_inq_dimid( piofile, 'lat', dimid ) - ierr = pio_inq_dimlen( piofile, dimid, nlat_veg ) - ierr = pio_inq_dimid( piofile, 'pft', dimid ) - ierr = pio_inq_dimlen( piofile, dimid, npft_veg ) - !--------------------------------------------------------------------------- - ! ... allocate arrays - !--------------------------------------------------------------------------- - allocate( vegetation_map(nlon_veg,nlat_veg,npft_veg), work(nlon_veg,nlat_veg), stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate vegation_map; error = ',astat - call endrun - end if - allocate( urban(nlon_veg,nlat_veg), lake(nlon_veg,nlat_veg), & - landmask(nlon_veg,nlat_veg), wetland(nlon_veg,nlat_veg), stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate vegation_map; error = ',astat - call endrun - end if - allocate( lon_veg(nlon_veg), lat_veg(nlat_veg), & - lon_veg_edge(nlon_veg+1), lat_veg_edge(nlat_veg+1), stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate vegation lon, lat arrays; error = ',astat - call endrun - end if - !--------------------------------------------------------------------------- - ! ... read the vegetation map and landmask - !--------------------------------------------------------------------------- - ierr = pio_inq_varid( piofile, 'PCT_PFT', vid ) - ierr = pio_get_var( piofile, vid, vegetation_map ) - - ierr = pio_inq_varid( piofile, 'LANDMASK', vid ) - ierr = pio_get_var( piofile, vid, landmask ) - - ierr = pio_inq_varid( piofile, 'PCT_URBAN', vid ) - ierr = pio_get_var( piofile, vid, urban ) - - ierr = pio_inq_varid( piofile, 'PCT_LAKE', vid ) - ierr = pio_get_var( piofile, vid, lake ) - - ierr = pio_inq_varid( piofile, 'PCT_WETLAND', vid ) - ierr = pio_get_var( piofile, vid, wetland ) - - call cam_pio_closefile( piofile ) - - !--------------------------------------------------------------------------- - ! scale vegetation, urban, lake, and wetland to fraction - !--------------------------------------------------------------------------- - vegetation_map(:,:,:) = .01_r8 * vegetation_map(:,:,:) - wetland(:,:) = .01_r8 * wetland(:,:) - lake(:,:) = .01_r8 * lake(:,:) - urban(:,:) = .01_r8 * urban(:,:) -#ifdef DEBUG - if(masterproc) then - write(iulog,*) 'minmax vegetation_map ',minval(vegetation_map),maxval(vegetation_map) - write(iulog,*) 'minmax wetland ',minval(wetland),maxval(wetland) - write(iulog,*) 'minmax landmask ',minval(landmask),maxval(landmask) - end if -#endif - !--------------------------------------------------------------------------- - ! ... define lat-lon of vegetation map (1x1) - !--------------------------------------------------------------------------- - lat_veg(:) = (/ (-89.5_r8 + (i-1),i=1,nlat_veg ) /) - lon_veg(:) = (/ ( 0.5_r8 + (i-1),i=1,nlon_veg ) /) - lat_veg_edge(:) = (/ (-90.0_r8 + (i-1),i=1,nlat_veg+1) /) - lon_veg_edge(:) = (/ ( 0.0_r8 + (i-1),i=1,nlon_veg+1) /) - !--------------------------------------------------------------------------- - ! ... read soilw table if necessary - !--------------------------------------------------------------------------- - - if( do_soilw ) then - call soilw_inti( clim_soilw_file, nlon_veg, nlat_veg, soilw_map ) - end if - - !--------------------------------------------------------------------------- - ! ... regrid to model grid - !--------------------------------------------------------------------------- - - call interp_map( plon, plat, nlon_veg, nlat_veg, npft_veg, lat_veg, lat_veg_edge, & - lon_veg, lon_veg_edge, landmask, urban, lake, & - wetland, vegetation_map, soilw_map, do_soilw ) - - deallocate( vegetation_map, work, stat=astat ) - deallocate( lon_veg, lat_veg, lon_veg_edge, lat_veg_edge, stat=astat ) - deallocate( landmask, urban, lake, wetland, stat=astat ) - if( do_soilw ) then - deallocate( soilw_map, stat=astat ) - end if - endif ! Unstructured grid - - if (drydep_method == DD_XLND) then - return - endif - - !--------------------------------------------------------------------------- - ! ... read LAI based season indeces - !--------------------------------------------------------------------------- - call getfil (season_wes_file, locfn, 0) - call cam_pio_openfile (piofile, trim(locfn), PIO_NOWRITE) - !--------------------------------------------------------------------------- - ! ... get the dimensions - !--------------------------------------------------------------------------- - ierr = pio_inq_dimid( piofile, 'lat', dimid ) - ierr = pio_inq_dimlen( piofile, dimid, nlat_lai ) - ierr = pio_inq_dimid( piofile, 'pft', dimid ) - ierr = pio_inq_dimlen( piofile, dimid, npft_lai ) - !--------------------------------------------------------------------------- - ! ... allocate arrays - !--------------------------------------------------------------------------- - allocate( lat_lai(nlat_lai), wk_lai(nlat_lai,npft_lai,12), stat=astat ) - if( astat /= 0 ) then - write(iulog,*) 'dvel_inti: failed to allocate vegation_map; error = ',astat - call endrun - end if - !--------------------------------------------------------------------------- - ! ... read the latitude and the season indicies - !--------------------------------------------------------------------------- - ierr = pio_inq_varid( piofile, 'lat', vid ) - ierr = pio_get_var( piofile, vid, lat_lai ) - - ierr = pio_inq_varid( piofile, 'season_wes', vid ) - ierr = pio_get_var( piofile, vid, wk_lai ) - - call cam_pio_closefile( piofile ) - - - if(dycore_is('UNSTRUCTURED') ) then - ! For unstructured grids plon is the 1d horizontal grid size and plat=1 - allocate(clat(plon)) - call get_horiz_grid_d(plon, clat_d_out=clat) - jl = 1 - ju = plon - else - allocate(clat(plat)) - call get_horiz_grid_d(plat, clat_d_out=clat) - jl = 1 - ju = plat - end if - imin = 1 - do j = 1,ju - diff_min = 10._r8 - pos_min = -99 - target_lat = clat(j)*r2d - do i = imin,nlat_lai - if( abs(lat_lai(i) - target_lat) < diff_min ) then - diff_min = abs(lat_lai(i) - target_lat) - pos_min = i - end if - end do - if( pos_min < 0 ) then - write(iulog,*) 'dvel_inti: cannot find ',target_lat,' at j,pos_min,diff_min = ',j,pos_min,diff_min - write(iulog,*) 'dvel_inti: imin,nlat_lai = ',imin,nlat_lai - write(iulog,*) 'dvel_inti: lat_lai' - write(iulog,'(1p,10g12.5)') lat_lai(:) - call endrun - end if - if(dycore_is('UNSTRUCTURED') ) then - imin=1 - else - imin = pos_min - end if - index_season_lai_j(:,:) = wk_lai(pos_min,:,:) - - !--------------------------------------------------------------------------- - ! specify the season as the most frequent in the 11 vegetation classes - ! this was done to remove a banding problem in dvel (JFL Oct 04) - !--------------------------------------------------------------------------- - do m = 1,12 - num_seas = 0 - do l = 1,11 - do k = 1,5 - if( index_season_lai_j(l,m) == k ) then - num_seas(k) = num_seas(k) + 1 - exit - end if - end do - end do - - num_max = -1 - do k = 1,5 - if( num_seas(k) > num_max ) then - num_max = num_seas(k) - k_max = k - endif - end do - - index_season_lai(j,m) = k_max - end do - end do - - deallocate( lat_lai, wk_lai, clat, index_season_lai_j) - - end subroutine dvel_inti_xactive - - !------------------------------------------------------------------------------------- - subroutine get_landuse_and_soilw_from_file(do_soilw) - use ncdio_atm, only : infld - logical, intent(in) :: do_soilw - logical :: readvar - - type(file_desc_t) :: piofile - character(len=shr_kind_cl) :: locfn - logical :: lexist - - call getfil (drydep_srf_file, locfn, 1, lexist) - if(lexist) then - call cam_pio_openfile(piofile, locfn, PIO_NOWRITE) - - call infld('fraction_landuse', piofile, 'ncol','class',1,pcols,1,n_land_type, begchunk,endchunk, & - fraction_landuse, readvar, gridname='physgrid') - if (.not. readvar) then - write(iulog,*)'**************************************' - write(iulog,*)'get_landuse_and_soilw_from_file: INFO:' - write(iulog,*)' fraction_landuse not read from file: ' - write(iulog,*)' ', trim(locfn) - write(iulog,*)' setting all values to zero' - write(iulog,*)'**************************************' - fraction_landuse = 0._r8 - end if - - if(do_soilw) then - call infld('soilw', piofile, 'ncol','month',1,pcols,1,12, begchunk,endchunk, & - soilw_3d, readvar, gridname='physgrid') - end if - - call cam_pio_closefile(piofile) - else - call endrun('Unstructured grids require drydep_srf_file ') - end if - - - end subroutine get_landuse_and_soilw_from_file - - !------------------------------------------------------------------------------------- - subroutine interp_map( plon, plat, nlon_veg, nlat_veg, npft_veg, lat_veg, lat_veg_edge, & - lon_veg, lon_veg_edge, landmask, urban, lake, & - wetland, vegetation_map, soilw_map, do_soilw ) - - use mo_constants, only : r2d - use scamMod, only : latiop,loniop,scmlat,scmlon,scm_cambfb_mode - use shr_scam_mod , only: shr_scam_getCloseLatLon ! Standardized system subroutines - use cam_initfiles, only: initial_file_get_id - use dycore, only : dycore_is - use phys_grid, only : scatter_field_to_chunk - implicit none - - !------------------------------------------------------------------------------------- - ! ... dummy arguments - !------------------------------------------------------------------------------------- - integer, intent(in) :: plon, plat, nlon_veg, nlat_veg, npft_veg - real(r8), pointer :: soilw_map(:,:,:) - real(r8), intent(in) :: landmask(nlon_veg,nlat_veg) - real(r8), intent(in) :: urban(nlon_veg,nlat_veg) - real(r8), intent(in) :: lake(nlon_veg,nlat_veg) - real(r8), intent(in) :: wetland(nlon_veg,nlat_veg) - real(r8), intent(in) :: vegetation_map(nlon_veg,nlat_veg,npft_veg) - real(r8), intent(in) :: lon_veg(nlon_veg) - real(r8), intent(in) :: lon_veg_edge(nlon_veg+1) - real(r8), intent(in) :: lat_veg(nlat_veg) - real(r8), intent(in) :: lat_veg_edge(nlat_veg+1) - logical, intent(in) :: do_soilw - - !------------------------------------------------------------------------------------- - ! ... local variables - !------------------------------------------------------------------------------------- - real(r8) :: closelat,closelon - integer :: latidx,lonidx - - integer, parameter :: veg_ext = 20 - type(file_desc_t), pointer :: piofile - integer :: i, j, ii, jj, jl, ju, i_ndx, n - integer, dimension(plon+1) :: ind_lon - integer, dimension(plat+1) :: ind_lat - real(r8) :: total_land - real(r8), dimension(plon+1) :: lon_edge - real(r8), dimension(plat+1) :: lat_edge - real(r8) :: lat1, lat2, lon1, lon2 - real(r8) :: x1, x2, y1, y2, dx, dy - real(r8) :: area, total_area - real(r8), dimension(npft_veg+3) :: fraction - real(r8) :: total_soilw_area - real(r8) :: fraction_soilw - real(r8) :: total_soilw(12) - - real(r8), dimension(-veg_ext:nlon_veg+veg_ext) :: lon_veg_edge_ext - integer, dimension(-veg_ext:nlon_veg+veg_ext) :: mapping_ext - - real(r8), allocatable :: lam(:), phi(:), garea(:) - - logical, parameter :: has_npole = .true. - integer :: ploniop,platiop - real(r8) :: tmp_frac_lu(plon,n_land_type,plat), tmp_soilw_3d(plon,12,plat) - - if(dycore_is('UNSTRUCTURED') ) then - ! For unstructured grids plon is the 1d horizontal grid size and plat=1 - allocate(lam(plon), phi(plon)) - call get_horiz_grid_d(plon, clat_d_out=phi) - else - allocate(lam(plon), phi(plat)) - call get_horiz_grid_d(plat, clat_d_out=phi) - endif - call get_horiz_grid_d(plon, clon_d_out=lam) - - - jl = 1 - ju = plon - - if (single_column) then - if (scm_cambfb_mode) then - piofile => initial_file_get_id() - call shr_scam_getCloseLatLon(piofile%fh,scmlat,scmlon,closelat,closelon,latidx,lonidx) - ploniop=size(loniop) - platiop=size(latiop) - else - latidx=1 - lonidx=1 - ploniop=1 - platiop=1 - end if - - lon_edge(1) = loniop(lonidx) * r2d - .5_r8*(loniop(2) - loniop(1)) * r2d - - if (lonidx.lt.ploniop) then - lon_edge(2) = loniop(lonidx+1) * r2d - .5_r8*(loniop(2) - loniop(1)) * r2d - else - lon_edge(2) = lon_edge(1) + (loniop(2) - loniop(1)) * r2d - end if - - lat_edge(1) = latiop(latidx) * r2d - .5_r8*(latiop(2) - latiop(1)) * r2d - - if (latidx.lt.platiop) then - lat_edge(2) = latiop(latidx+1) * r2d - .5_r8*(latiop(2) - latiop(1)) * r2d - else - lat_edge(2) = lat_edge(1) + (latiop(2) - latiop(1)) * r2d - end if - else - do i = 1,plon - lon_edge(i) = lam(i) * r2d - .5_r8*(lam(2) - lam(1)) * r2d - end do - lon_edge(plon+1) = lon_edge(plon) + (lam(2) - lam(1)) * r2d - if( .not. has_npole ) then - do j = 1,plat+1 - lat_edge(j) = phi(j) * r2d - .5_r8*(phi(2) - phi(1)) * r2d - end do - else - do j = 1,plat - lat_edge(j) = phi(j) * r2d - .5_r8*(phi(2) - phi(1)) * r2d - end do - lat_edge(plat+1) = lat_edge(plat) + (phi(2) - phi(1)) * r2d - end if - end if - do j = 1,plat+1 - lat_edge(j) = min( lat_edge(j), 90._r8 ) - lat_edge(j) = max( lat_edge(j),-90._r8 ) - end do - - !------------------------------------------------------------------------------------- - ! wrap around the longitudes - !------------------------------------------------------------------------------------- - do i = -veg_ext,0 - lon_veg_edge_ext(i) = lon_veg_edge(nlon_veg+i) - 360._r8 - mapping_ext (i) = nlon_veg+i - end do - do i = 1,nlon_veg - lon_veg_edge_ext(i) = lon_veg_edge(i) - mapping_ext (i) = i - end do - do i = nlon_veg+1,nlon_veg+veg_ext - lon_veg_edge_ext(i) = lon_veg_edge(i-nlon_veg) + 360._r8 - mapping_ext (i) = i-nlon_veg - end do -#ifdef DEBUG - write(iulog,*) 'interp_map : lon_edge ',lon_edge - write(iulog,*) 'interp_map : lat_edge ',lat_edge - write(iulog,*) 'interp_map : mapping_ext ',mapping_ext -#endif - do j = 1,plon+1 - lon1 = lon_edge(j) - do i = -veg_ext,nlon_veg+veg_ext - dx = lon_veg_edge_ext(i ) - lon1 - dy = lon_veg_edge_ext(i+1) - lon1 - if( dx*dy <= 0._r8 ) then - ind_lon(j) = i - exit - end if - end do - end do - - do j = 1,plat+1 - lat1 = lat_edge(j) - do i = 1,nlat_veg - dx = lat_veg_edge(i ) - lat1 - dy = lat_veg_edge(i+1) - lat1 - if( dx*dy <= 0._r8 ) then - ind_lat(j) = i - exit - end if - end do - end do -#ifdef DEBUG - write(iulog,*) 'interp_map : ind_lon ',ind_lon - write(iulog,*) 'interp_map : ind_lat ',ind_lat -#endif - lat_loop : do j = 1,plat - lon_loop : do i = 1,plon - total_area = 0._r8 - fraction = 0._r8 - total_soilw(:) = 0._r8 - total_soilw_area = 0._r8 - do jj = ind_lat(j),ind_lat(j+1) - y1 = max( lat_edge(j),lat_veg_edge(jj) ) - y2 = min( lat_edge(j+1),lat_veg_edge(jj+1) ) - dy = (y2 - y1)/(lat_veg_edge(jj+1) - lat_veg_edge(jj)) - do ii =ind_lon(i),ind_lon(i+1) - i_ndx = mapping_ext(ii) - x1 = max( lon_edge(i),lon_veg_edge_ext(ii) ) - x2 = min( lon_edge(i+1),lon_veg_edge_ext(ii+1) ) - dx = (x2 - x1)/(lon_veg_edge_ext(ii+1) - lon_veg_edge_ext(ii)) - area = dx * dy - total_area = total_area + area - !----------------------------------------------------------------- - ! ... special case for ocean grid point - !----------------------------------------------------------------- - if( nint(landmask(i_ndx,jj)) == 0 ) then - fraction(npft_veg+1) = fraction(npft_veg+1) + area - else - do n = 1,npft_veg - fraction(n) = fraction(n) + vegetation_map(i_ndx,jj,n) * area - end do - fraction(npft_veg+1) = fraction(npft_veg+1) + area * lake (i_ndx,jj) - fraction(npft_veg+2) = fraction(npft_veg+2) + area * wetland(i_ndx,jj) - fraction(npft_veg+3) = fraction(npft_veg+3) + area * urban (i_ndx,jj) - !----------------------------------------------------------------- - ! ... check if land accounts for the whole area. - ! If not, the remaining area is in the ocean - !----------------------------------------------------------------- - total_land = sum(vegetation_map(i_ndx,jj,:)) & - + urban (i_ndx,jj) & - + lake (i_ndx,jj) & - + wetland(i_ndx,jj) - if( total_land < 1._r8 ) then - fraction(npft_veg+1) = fraction(npft_veg+1) + (1._r8 - total_land) * area - end if - !------------------------------------------------------------------------------------- - ! ... compute weighted average of soilw over grid (non-water only) - !------------------------------------------------------------------------------------- - if( do_soilw ) then - fraction_soilw = total_land - (lake(i_ndx,jj) + wetland(i_ndx,jj)) - total_soilw_area = total_soilw_area + fraction_soilw * area - total_soilw(:) = total_soilw(:) + fraction_soilw * area * soilw_map(i_ndx,jj,:) - end if - end if - end do - end do - !------------------------------------------------------------------------------------- - ! ... divide by total area of grid box - !------------------------------------------------------------------------------------- - fraction(:) = fraction(:)/total_area - !------------------------------------------------------------------------------------- - ! ... make sure we don't have too much or too little - !------------------------------------------------------------------------------------- - if( abs( sum(fraction) - 1._r8) > .001_r8 ) then - fraction(:) = fraction(:)/sum(fraction) - end if - !------------------------------------------------------------------------------------- - ! ... map to Wesely land classification - !------------------------------------------------------------------------------------- - - - - - tmp_frac_lu(i, 1, j) = fraction(20) - tmp_frac_lu(i, 2, j) = sum(fraction(16:17)) - tmp_frac_lu(i, 3, j) = sum(fraction(13:15)) - tmp_frac_lu(i, 4, j) = sum(fraction( 5: 9)) - tmp_frac_lu(i, 5, j) = sum(fraction( 2: 4)) - tmp_frac_lu(i, 6, j) = fraction(19) - tmp_frac_lu(i, 7, j) = fraction(18) - tmp_frac_lu(i, 8, j) = fraction( 1) - tmp_frac_lu(i, 9, j) = 0._r8 - tmp_frac_lu(i,10, j) = 0._r8 - tmp_frac_lu(i,11, j) = sum(fraction(10:12)) - if( do_soilw ) then - if( total_soilw_area > 0._r8 ) then - tmp_soilw_3d(i,:,j) = total_soilw(:)/total_soilw_area - else - tmp_soilw_3d(i,:,j) = -99._r8 - end if - end if - end do lon_loop - end do lat_loop - !------------------------------------------------------------------------------------- - ! ... reshape according to lat-lon blocks - !------------------------------------------------------------------------------------- - call scatter_field_to_chunk(1,n_land_type,1,plon,tmp_frac_lu,fraction_landuse) - if(do_soilw) call scatter_field_to_chunk(1,12,1,plon,tmp_soilw_3d,soilw_3d) - !------------------------------------------------------------------------------------- - ! ... make sure there are no out of range values - !------------------------------------------------------------------------------------- - where (fraction_landuse < 0._r8) fraction_landuse = 0._r8 - where (fraction_landuse > 1._r8) fraction_landuse = 1._r8 - - end subroutine interp_map - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine drydep_xactive( ncdate, sfc_temp, pressure_sfc, & - wind_speed, spec_hum, air_temp, pressure_10m, rain, & - snow, solar_flux, dvel, dflx, mmr, & - tv, soilw, rh, ncol, lonndx, latndx, lchnk, & - ocnfrc, icefrc, beglandtype, endlandtype ) - !------------------------------------------------------------------------------------- - ! code based on wesely (atmospheric environment, 1989, vol 23, p. 1293-1304) for - ! calculation of r_c, and on walcek et. al. (atmospheric enviroment, 1986, - ! vol. 20, p. 949-964) for calculation of r_a and r_b - ! - ! as suggested in walcek (u_i)(u*_i) = (u_a)(u*_a) - ! is kept constant where i represents a subgrid environment and a the - ! grid average environment. thus the calculation proceeds as follows: - ! va the grid averaged wind is calculated on dots - ! z0(i) the grid averaged roughness coefficient is calculated - ! ri(i) the grid averaged richardson number is calculated - ! --> the grid averaged (u_a)(u*_a) is calculated - ! --> subgrid scale u*_i is calculated assuming (u_i) given as above - ! --> final deposotion velocity is weighted average of subgrid scale velocities - ! - ! code written by P. Hess, rewritten in fortran 90 by JFL (August 2000) - ! modified by JFL to be used in MOZART-2 (October 2002) - !------------------------------------------------------------------------------------- - - use seq_drydep_mod, only: z0, rgso, rgss, h2_a, h2_b, h2_c, ri, rclo, rcls, rlu, rac - use seq_drydep_mod, only: seq_drydep_setHCoeff, foxd, drat - use physconst, only: tmelt - use seq_drydep_mod, only: drydep_method, DD_XLND - - implicit none - - !------------------------------------------------------------------------------------- - ! ... dummy arguments - !------------------------------------------------------------------------------------- - integer, intent(in) :: ncol - integer, intent(in) :: ncdate ! present date (yyyymmdd) - real(r8), intent(in) :: sfc_temp(pcols) ! surface temperature (K) - real(r8), intent(in) :: pressure_sfc(pcols) ! surface pressure (Pa) - real(r8), intent(in) :: wind_speed(pcols) ! 10 meter wind speed (m/s) - real(r8), intent(in) :: spec_hum(pcols) ! specific humidity (kg/kg) - real(r8), intent(in) :: rh(ncol,1) ! relative humidity - real(r8), intent(in) :: air_temp(pcols) ! surface air temperature (K) - real(r8), intent(in) :: pressure_10m(pcols) ! 10 meter pressure (Pa) - real(r8), intent(in) :: rain(pcols) - real(r8), intent(in) :: snow(pcols) ! snow height (m) - real(r8), intent(in) :: soilw(pcols) ! soil moisture fraction - real(r8), intent(in) :: solar_flux(pcols) ! direct shortwave radiation at surface (W/m^2) - real(r8), intent(in) :: tv(pcols) ! potential temperature - real(r8), intent(in) :: mmr(pcols,plev,gas_pcnst) ! constituent concentration (kg/kg) - real(r8), intent(out) :: dvel(ncol,gas_pcnst) ! deposition velocity (cm/s) - real(r8), intent(inout) :: dflx(pcols,gas_pcnst) ! deposition flux (/cm^2/s) - - integer, intent(in) :: latndx(pcols) ! chunk latitude indicies - integer, intent(in) :: lonndx(pcols) ! chunk longitude indicies - integer, intent(in) :: lchnk ! chunk number - - integer, intent(in), optional :: beglandtype - integer, intent(in), optional :: endlandtype - - real(r8), intent(in), optional :: ocnfrc(pcols) - real(r8), intent(in), optional :: icefrc(pcols) - - !------------------------------------------------------------------------------------- - ! ... local variables - !------------------------------------------------------------------------------------- - real(r8), parameter :: scaling_to_cm_per_s = 100._r8 - real(r8), parameter :: rain_threshold = 1.e-7_r8 ! of the order of 1cm/day expressed in m/s - - integer :: i, ispec, lt, m - integer :: sndx - integer :: month - - real(r8) :: slope = 0._r8 - real(r8) :: z0water ! revised z0 over water - real(r8) :: p ! pressure at midpoint first layer - real(r8) :: pg ! surface pressure - real(r8) :: es ! saturation vapor pressure - real(r8) :: ws ! saturation mixing ratio - real(r8) :: hvar ! constant to compute xmol - real(r8) :: h ! constant to compute xmol - real(r8) :: psih ! stability correction factor - real(r8) :: rs ! constant for calculating rsmx - real(r8) :: rmx ! resistance by vegetation - real(r8) :: zovl ! ratio of z to m-o length - real(r8) :: cvarb ! cvar averaged over landtypes - real(r8) :: bb ! b averaged over landtypes - real(r8) :: ustarb ! ustar averaged over landtypes - real(r8) :: tc(ncol) ! temperature in celsius - real(r8) :: cts(ncol) ! correction to rlu rcl and rgs for frost - - !------------------------------------------------------------------------------------- - ! local arrays: dependent on location and species - !------------------------------------------------------------------------------------- - real(r8), dimension(ncol,nddvels) :: heff - - !------------------------------------------------------------------------------------- - ! local arrays: dependent on location only - !------------------------------------------------------------------------------------- - integer :: index_season(ncol,n_land_type) - real(r8), dimension(ncol) :: tha ! atmospheric virtual potential temperature - real(r8), dimension(ncol) :: thg ! ground virtual potential temperature - real(r8), dimension(ncol) :: z ! height of lowest level - real(r8), dimension(ncol) :: va ! magnitude of v on cross points - real(r8), dimension(ncol) :: ribn ! richardson number - real(r8), dimension(ncol) :: qs ! saturation specific humidity - real(r8), dimension(ncol) :: crs ! multiplier to calculate crs - real(r8), dimension(ncol) :: rdc ! part of lower canopy resistance - real(r8), dimension(ncol) :: uustar ! u*ustar (assumed constant over grid) - real(r8), dimension(ncol) :: z0b ! average roughness length over grid - real(r8), dimension(ncol) :: wrk ! work array - real(r8), dimension(ncol) :: term ! work array - real(r8), dimension(ncol) :: resc ! work array - real(r8), dimension(ncol) :: lnd_frc ! work array - logical, dimension(ncol) :: unstable - logical, dimension(ncol) :: has_rain - logical, dimension(ncol) :: has_dew - - !------------------------------------------------------------------------------------- - ! local arrays: dependent on location and landtype - !------------------------------------------------------------------------------------- - real(r8), dimension(ncol,n_land_type) :: rds ! resistance for deposition of sulfate - real(r8), dimension(ncol,n_land_type) :: b ! buoyancy parameter for unstable conditions - real(r8), dimension(ncol,n_land_type) :: cvar ! height parameter - real(r8), dimension(ncol,n_land_type) :: ustar ! friction velocity - real(r8), dimension(ncol,n_land_type) :: xmol ! monin-obukhov length - - !------------------------------------------------------------------------------------- - ! local arrays: dependent on location, landtype and species - !------------------------------------------------------------------------------------- - real(r8), dimension(ncol,n_land_type,gas_pcnst) :: rsmx ! vegetative resistance (plant mesophyll) - real(r8), dimension(ncol,n_land_type,gas_pcnst) :: rclx ! lower canopy resistance - real(r8), dimension(ncol,n_land_type,gas_pcnst) :: rlux ! vegetative resistance (upper canopy) - real(r8), dimension(ncol,n_land_type) :: rlux_o3 ! vegetative resistance (upper canopy) - real(r8), dimension(ncol,n_land_type,gas_pcnst) :: rgsx ! ground resistance - real(r8) :: pmid(ncol,1) ! for seasalt aerosols - real(r8) :: tfld(ncol,1) ! for seasalt aerosols - real(r8) :: fact, vds - real(r8) :: rc ! combined surface resistance - real(r8) :: var_soilw, dv_soil_h2, fact_h2 ! h2 dvel wrking variables - logical :: fr_lnduse(ncol,n_land_type) ! wrking array - real(r8) :: dewm ! multiplier for rs when dew occurs - - real(r8) :: lcl_frc_landuse(ncol,n_land_type) - - integer :: beglt, endlt - - !------------------------------------------------------------------------------------- - ! jfl : mods for PAN - !------------------------------------------------------------------------------------- - real(r8) :: dv_pan - real(r8) :: c0_pan(11) = (/ 0.000_r8, 0.006_r8, 0.002_r8, 0.009_r8, 0.015_r8, & - 0.006_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.002_r8, 0.002_r8 /) - real(r8) :: k_pan (11) = (/ 0.000_r8, 0.010_r8, 0.005_r8, 0.004_r8, 0.003_r8, & - 0.005_r8, 0.000_r8, 0.000_r8, 0.000_r8, 0.075_r8, 0.002_r8 /) - - if (present( beglandtype)) then - beglt = beglandtype - else - beglt = 1 - endif - if (present( endlandtype)) then - endlt = endlandtype - else - endlt = n_land_type - endif - - !------------------------------------------------------------------------------------- - ! initialize - !------------------------------------------------------------------------------------- - do m = 1,gas_pcnst - dvel(:,m) = 0._r8 - end do - - if( all( .not. has_dvel(:) ) ) then - return - end if - - !------------------------------------------------------------------------------------- - ! define species-dependent parameters (temperature dependent) - !------------------------------------------------------------------------------------- - call seq_drydep_setHCoeff( ncol, sfc_temp, heff ) - - do lt = 1,n_land_type - dep_ra (:,lt,lchnk) = 0._r8 - dep_rb (:,lt,lchnk) = 0._r8 - rds(:,lt) = 0._r8 - end do - - !------------------------------------------------------------------------------------- - ! ... set month - !------------------------------------------------------------------------------------- - month = mod( ncdate,10000 )/100 - - !------------------------------------------------------------------------------------- - ! define which season (relative to Northern hemisphere climate) - !------------------------------------------------------------------------------------- - - !------------------------------------------------------------------------------------- - ! define season index based on fixed LAI - !------------------------------------------------------------------------------------- - if ( drydep_method == DD_XLND ) then - index_season = 4 - else - do i = 1,ncol - index_season(i,:) = index_season_lai(latndx(i),month) - end do - endif - !------------------------------------------------------------------------------------- - ! special case for snow covered terrain - !------------------------------------------------------------------------------------- - do i = 1,ncol - if( snow(i) > .01_r8 ) then - index_season(i,:) = 4 - end if - end do - !------------------------------------------------------------------------------------- - ! scale rain and define logical arrays - !------------------------------------------------------------------------------------- - has_rain(:ncol) = rain(:ncol) > rain_threshold - - !------------------------------------------------------------------------------------- - ! loop over longitude points - !------------------------------------------------------------------------------------- - col_loop : do i = 1,ncol - p = pressure_10m(i) - pg = pressure_sfc(i) - !------------------------------------------------------------------------------------- - ! potential temperature - !------------------------------------------------------------------------------------- - tha(i) = air_temp(i) * (p00/p )**rovcp * (1._r8 + .61_r8*spec_hum(i)) - thg(i) = sfc_temp(i) * (p00/pg)**rovcp * (1._r8 + .61_r8*spec_hum(i)) - !------------------------------------------------------------------------------------- - ! height of 1st level - !------------------------------------------------------------------------------------- - z(i) = - r/grav * air_temp(i) * (1._r8 + .61_r8*spec_hum(i)) * log(p/pg) - !------------------------------------------------------------------------------------- - ! wind speed - !------------------------------------------------------------------------------------- - va(i) = max( .01_r8,wind_speed(i) ) - !------------------------------------------------------------------------------------- - ! Richardson number - !------------------------------------------------------------------------------------- - ribn(i) = z(i) * grav * (tha(i) - thg(i))/thg(i) / (va(i)*va(i)) - ribn(i) = min( ribn(i),ric ) - unstable(i) = ribn(i) < 0._r8 - !------------------------------------------------------------------------------------- - ! saturation vapor pressure (Pascals) - ! saturation mixing ratio - ! saturation specific humidity - !------------------------------------------------------------------------------------- - es = 611._r8*exp( 5414.77_r8*(sfc_temp(i) - tmelt)/(tmelt*sfc_temp(i)) ) - ws = .622_r8*es/(pg - es) - qs(i) = ws/(1._r8 + ws) - has_dew(i) = .false. - if( qs(i) <= spec_hum(i) ) then - has_dew(i) = .true. - end if - if( sfc_temp(i) < tmelt ) then - has_dew(i) = .false. - end if - !------------------------------------------------------------------------------------- - ! constant in determining rs - !------------------------------------------------------------------------------------- - tc(i) = sfc_temp(i) - tmelt - if( sfc_temp(i) > tmelt .and. sfc_temp(i) < 313.15_r8 ) then - crs(i) = (1._r8 + (200._r8/(solar_flux(i) + .1_r8))**2) * (400._r8/(tc(i)*(40._r8 - tc(i)))) - else - crs(i) = large_value - end if - !------------------------------------------------------------------------------------- - ! rdc (lower canopy res) - !------------------------------------------------------------------------------------- - rdc(i) = 100._r8*(1._r8 + 1000._r8/(solar_flux(i) + 10._r8))/(1._r8 + 1000._r8*slope) - end do col_loop - - !------------------------------------------------------------------------------------- - ! ... form working arrays - !------------------------------------------------------------------------------------- - do lt = 1,n_land_type - do i=1,ncol - if ( drydep_method == DD_XLND ) then - lcl_frc_landuse(i,lt) = 0._r8 - else - lcl_frc_landuse(i,lt) = fraction_landuse(i,lt,lchnk) - endif - enddo - end do - if ( present(ocnfrc) .and. present(icefrc) ) then - do i=1,ncol - ! land type 7 is used for ocean - ! land type 8 is used for sea ice - lcl_frc_landuse(i,7) = ocnfrc(i) - lcl_frc_landuse(i,8) = icefrc(i) - enddo - endif - do lt = 1,n_land_type - do i=1,ncol - fr_lnduse(i,lt) = lcl_frc_landuse(i,lt) > 0._r8 - enddo - end do - - !------------------------------------------------------------------------------------- - ! find grid averaged z0: z0bar (the roughness length) z_o=exp[S(f_i*ln(z_oi))] - ! this is calculated so as to find u_i, assuming u*u=u_i*u_i - !------------------------------------------------------------------------------------- - z0b(:) = 0._r8 - do lt = 1,n_land_type - do i = 1,ncol - if( fr_lnduse(i,lt) ) then - z0b(i) = z0b(i) + lcl_frc_landuse(i,lt) * log( z0(index_season(i,lt),lt) ) - end if - end do - end do - - !------------------------------------------------------------------------------------- - ! find the constant velocity uu*=(u_i)(u*_i) - !------------------------------------------------------------------------------------- - do i = 1,ncol - z0b(i) = exp( z0b(i) ) - cvarb = vonkar/log( z(i)/z0b(i) ) - !------------------------------------------------------------------------------------- - ! unstable and stable cases - !------------------------------------------------------------------------------------- - if( unstable(i) ) then - bb = 9.4_r8*(cvarb**2)*sqrt( abs(ribn(i))*z(i)/z0b(i) ) - ustarb = cvarb * va(i) * sqrt( 1._r8 - (9.4_r8*ribn(i)/(1._r8 + 7.4_r8*bb)) ) - else - ustarb = cvarb * va(i)/(1._r8 + 4.7_r8*ribn(i)) - end if - uustar(i) = va(i)*ustarb - end do - - !------------------------------------------------------------------------------------- - ! calculate the friction velocity for each land type u_i=uustar/u*_i - !------------------------------------------------------------------------------------- - do lt = beglt,endlt - do i = 1,ncol - if( fr_lnduse(i,lt) ) then - if( unstable(i) ) then - cvar(i,lt) = vonkar/log( z(i)/z0(index_season(i,lt),lt) ) - b(i,lt) = 9.4_r8*(cvar(i,lt)**2)* sqrt( abs(ribn(i))*z(i)/z0(index_season(i,lt),lt) ) - ustar(i,lt) = sqrt( cvar(i,lt)*uustar(i)*sqrt( 1._r8 - (9.4_r8*ribn(i)/(1._r8 + 7.4_r8*b(i,lt))) ) ) - else - cvar(i,lt) = vonkar/log( z(i)/z0(index_season(i,lt),lt) ) - ustar(i,lt) = sqrt( cvar(i,lt)*uustar(i)/(1._r8 + 4.7_r8*ribn(i)) ) - end if - end if - end do - end do - - !------------------------------------------------------------------------------------- - ! revise calculation of friction velocity and z0 over water - !------------------------------------------------------------------------------------- - lt = 7 - do i = 1,ncol - if( fr_lnduse(i,lt) ) then - if( unstable(i) ) then - z0water = (.016_r8*(ustar(i,lt)**2)/grav) + diffk/(9.1_r8*ustar(i,lt)) - cvar(i,lt) = vonkar/(log( z(i)/z0water )) - b(i,lt) = 9.4_r8*(cvar(i,lt)**2)*sqrt( abs(ribn(i))*z(i)/z0water ) - ustar(i,lt) = sqrt( cvar(i,lt)*uustar(i)* sqrt( 1._r8 - (9.4_r8*ribn(i)/(1._r8+ 7.4_r8*b(i,lt))) ) ) - else - z0water = (.016_r8*(ustar(i,lt)**2)/grav) + diffk/(9.1_r8*ustar(i,lt)) - cvar(i,lt) = vonkar/(log(z(i)/z0water)) - ustar(i,lt) = sqrt( cvar(i,lt)*uustar(i)/(1._r8 + 4.7_r8*ribn(i)) ) - end if - end if - end do - - !------------------------------------------------------------------------------------- - ! compute monin-obukhov length for unstable and stable conditions/ sublayer resistance - !------------------------------------------------------------------------------------- - do lt = beglt,endlt - do i = 1,ncol - if( fr_lnduse(i,lt) ) then - hvar = (va(i)/0.74_r8) * (tha(i) - thg(i)) * (cvar(i,lt)**2) - if( unstable(i) ) then ! unstable - h = hvar*(1._r8 - (9.4_r8*ribn(i)/(1._r8 + 5.3_r8*b(i,lt)))) - else - h = hvar/((1._r8+4.7_r8*ribn(i))**2) - end if - xmol(i,lt) = thg(i) * ustar(i,lt) * ustar(i,lt) / (vonkar * grav * h) - end if - end do - end do - - !------------------------------------------------------------------------------------- - ! psih - !------------------------------------------------------------------------------------- - do lt = beglt,endlt - do i = 1,ncol - if( fr_lnduse(i,lt) ) then - if( xmol(i,lt) < 0._r8 ) then - zovl = z(i)/xmol(i,lt) - zovl = max( -1._r8,zovl ) - psih = exp( .598_r8 + .39_r8*log( -zovl ) - .09_r8*(log( -zovl ))**2 ) - vds = 2.e-3_r8*ustar(i,lt) * (1._r8 + (300/(-xmol(i,lt)))**0.666_r8) - else - zovl = z(i)/xmol(i,lt) - zovl = min( 1._r8,zovl ) - psih = -5._r8 * zovl - vds = 2.e-3_r8*ustar(i,lt) - end if - dep_ra (i,lt,lchnk) = (vonkar - psih*cvar(i,lt))/(ustar(i,lt)*vonkar*cvar(i,lt)) - dep_rb (i,lt,lchnk) = (2._r8/(vonkar*ustar(i,lt))) * crb - rds(i,lt) = 1._r8/vds - end if - end do - end do - - !------------------------------------------------------------------------------------- - ! surface resistance : depends on both land type and species - ! land types are computed seperately, then resistance is computed as average of values - ! following wesely rc=(1/(rs+rm) + 1/rlu +1/(rdc+rcl) + 1/(rac+rgs))**-1 - ! - ! compute rsmx = 1/(rs+rm) : multiply by 3 if surface is wet - !------------------------------------------------------------------------------------- - species_loop1 : do ispec = 1,gas_pcnst - if( has_dvel(ispec) ) then - m = map_dvel(ispec) - do lt = beglt,endlt - do i = 1,ncol - if( fr_lnduse(i,lt) ) then - sndx = index_season(i,lt) - if( ispec == o3_ndx .or. ispec == o3a_ndx .or. ispec == so2_ndx ) then - rmx = 0._r8 - else - rmx = 1._r8/(heff(i,m)/3000._r8 + 100._r8*foxd(m)) - end if - cts(i) = 1000._r8*exp( - tc(i) - 4._r8 ) ! correction for frost - rgsx(i,lt,ispec) = cts(i) + 1._r8/((heff(i,m)/(1.e5_r8*rgss(sndx,lt))) + (foxd(m)/rgso(sndx,lt))) - !------------------------------------------------------------------------------------- - ! special case for H2 and CO;; CH4 is set ot a fraction of dv(H2) - !------------------------------------------------------------------------------------- - if( ispec == h2_ndx .or. ispec == co_ndx .or. ispec == ch4_ndx ) then - if( ispec == co_ndx ) then - fact_h2 = 1.0_r8 - elseif ( ispec == h2_ndx ) then - fact_h2 = 0.5_r8 - elseif ( ispec == ch4_ndx ) then - fact_h2 = 50.0_r8 - end if - !------------------------------------------------------------------------------------- - ! no deposition on snow, ice, desert, and water - !------------------------------------------------------------------------------------- - if( lt == 1 .or. lt == 7 .or. lt == 8 .or. sndx == 4 ) then - rgsx(i,lt,ispec) = large_value - else - var_soilw = max( .1_r8,min( soilw(i),.3_r8 ) ) - if( lt == 3 ) then - var_soilw = log( var_soilw ) - end if - dv_soil_h2 = h2_c(lt) + var_soilw*(h2_b(lt) + var_soilw*h2_a(lt)) - if( dv_soil_h2 > 0._r8 ) then - rgsx(i,lt,ispec) = fact_h2/(dv_soil_h2*1.e-4_r8) - end if - end if - end if - if( lt == 7 ) then - rclx(i,lt,ispec) = large_value - rsmx(i,lt,ispec) = large_value - rlux(i,lt,ispec) = large_value - else - rs = ri(sndx,lt)*crs(i) - if ( has_dew(i) .or. has_rain(i) ) then - dewm = 3._r8 - else - dewm = 1._r8 - end if - rsmx(i,lt,ispec) = (dewm*rs*drat(m) + rmx) - !------------------------------------------------------------------------------------- - ! jfl : special case for PAN - !------------------------------------------------------------------------------------- - if( ispec == pan_ndx .or. ispec == xpan_ndx ) then - dv_pan = c0_pan(lt) * (1._r8 - exp( -k_pan(lt)*(dewm*rs*drat(m))*1.e-2_r8 )) - if( dv_pan > 0._r8 .and. sndx /= 4 ) then - rsmx(i,lt,ispec) = ( 1._r8/dv_pan ) - end if - end if - rclx(i,lt,ispec) = cts(i) + 1._r8/((heff(i,m)/(1.e5_r8*rcls(sndx,lt))) + (foxd(m)/rclo(sndx,lt))) - rlux(i,lt,ispec) = cts(i) + rlu(sndx,lt)/(1.e-5_r8*heff(i,m) + foxd(m)) - end if - end if - end do - end do - end if - end do species_loop1 - - do lt = beglt,endlt - if( lt /= 7 ) then - do i = 1,ncol - if( fr_lnduse(i,lt) ) then - sndx = index_season(i,lt) - !------------------------------------------------------------------------------------- - ! ... no effect if sfc_temp < O C - !------------------------------------------------------------------------------------- - if( sfc_temp(i) > tmelt ) then - if( has_dew(i) ) then - rlux_o3(i,lt) = 3000._r8*rlu(sndx,lt)/(1000._r8 + rlu(sndx,lt)) - if( o3_ndx > 0 ) then - rlux(i,lt,o3_ndx) = rlux_o3(i,lt) - endif - if( o3a_ndx > 0 ) then - rlux(i,lt,o3a_ndx) = rlux_o3(i,lt) - endif - end if - if( has_rain(i) ) then - ! rlux(i,lt,o3_ndx) = 1./(1.e-3 + (1./(3.*rlu(sndx,lt)))) - rlux_o3(i,lt) = 3000._r8*rlu(sndx,lt)/(1000._r8 + 3._r8*rlu(sndx,lt)) - if( o3_ndx > 0 ) then - rlux(i,lt,o3_ndx) = rlux_o3(i,lt) - endif - if( o3a_ndx > 0 ) then - rlux(i,lt,o3a_ndx) = rlux_o3(i,lt) - endif - end if - end if - - if ( o3_ndx > 0 ) then - rclx(i,lt,o3_ndx) = cts(i) + rclo(index_season(i,lt),lt) - rlux(i,lt,o3_ndx) = cts(i) + rlux(i,lt,o3_ndx) - end if - if ( o3a_ndx > 0 ) then - rclx(i,lt,o3a_ndx) = cts(i) + rclo(index_season(i,lt),lt) - rlux(i,lt,o3a_ndx) = cts(i) + rlux(i,lt,o3a_ndx) - end if - - end if - end do - end if - end do - - species_loop2 : do ispec = 1,gas_pcnst - m = map_dvel(ispec) - if( has_dvel(ispec) ) then - if( ispec /= o3_ndx .and. ispec /= o3a_ndx .and. ispec /= so2_ndx ) then - do lt = beglt,endlt - if( lt /= 7 ) then - do i = 1,ncol - if( fr_lnduse(i,lt) ) then - !------------------------------------------------------------------------------------- - ! no effect if sfc_temp < O C - !------------------------------------------------------------------------------------- - if( sfc_temp(i) > tmelt ) then - if( has_dew(i) ) then - rlux(i,lt,ispec) = 1._r8/((1._r8/(3._r8*rlux(i,lt,ispec))) & - + 1.e-7_r8*heff(i,m) + foxd(m)/rlux_o3(i,lt)) - end if - end if - - end if - end do - end if - end do - else if( ispec == so2_ndx ) then - do lt = beglt,endlt - if( lt /= 7 ) then - do i = 1,ncol - if( fr_lnduse(i,lt) ) then - !------------------------------------------------------------------------------------- - ! no effect if sfc_temp < O C - !------------------------------------------------------------------------------------- - if( sfc_temp(i) > tmelt ) then - if( qs(i) <= spec_hum(i) ) then - rlux(i,lt,ispec) = 100._r8 - end if - if( has_rain(i) ) then - ! rlux(i,lt,ispec) = 1./(2.e-4 + (1./(3.*rlu(index_season(i,lt),lt)))) - rlux(i,lt,ispec) = 15._r8*rlu(index_season(i,lt),lt)/(5._r8 + 3.e-3_r8*rlu(index_season(i,lt),lt)) - end if - end if - rclx(i,lt,ispec) = cts(i) + rcls(index_season(i,lt),lt) - rlux(i,lt,ispec) = cts(i) + rlux(i,lt,ispec) - - end if - end do - end if - end do - do i = 1,ncol - if( fr_lnduse(i,1) .and. (has_dew(i) .or. has_rain(i)) ) then - rlux(i,1,ispec) = 50._r8 - end if - end do - end if - end if - end do species_loop2 - - !------------------------------------------------------------------------------------- - ! compute rc - !------------------------------------------------------------------------------------- - term(:ncol) = 1.e-2_r8 * pressure_10m(:ncol) / (r*tv(:ncol)) - species_loop3 : do ispec = 1,gas_pcnst - if( has_dvel(ispec) ) then - wrk(:) = 0._r8 - lt_loop: do lt = beglt,endlt - do i = 1,ncol - if (fr_lnduse(i,lt)) then - resc(i) = 1._r8/( 1._r8/rsmx(i,lt,ispec) + 1._r8/rlux(i,lt,ispec) & - + 1._r8/(rdc(i) + rclx(i,lt,ispec)) & - + 1._r8/(rac(index_season(i,lt),lt) + rgsx(i,lt,ispec))) - - resc(i) = max( 10._r8,resc(i) ) - - lnd_frc(i) = lcl_frc_landuse(i,lt) - endif - enddo - !------------------------------------------------------------------------------------- - ! ... compute average deposition velocity - !------------------------------------------------------------------------------------- - select case( solsym(ispec) ) - case( 'SO2' ) - if( lt == 7 ) then - where( fr_lnduse(:ncol,lt) ) - ! assume no surface resistance for SO2 over water` - wrk(:) = wrk(:) + lnd_frc(:)/(dep_ra(:ncol,lt,lchnk) + dep_rb(:ncol,lt,lchnk)) - endwhere - else - where( fr_lnduse(:ncol,lt) ) - wrk(:) = wrk(:) + lnd_frc(:)/(dep_ra(:ncol,lt,lchnk) + dep_rb(:ncol,lt,lchnk) + resc(:)) - endwhere - end if - - ! JFL - increase in dry deposition of SO2 to improve bias over US/Europe - wrk(:) = wrk(:) * 2._r8 - - case( 'SO4' ) - where( fr_lnduse(:ncol,lt) ) - wrk(:) = wrk(:) + lnd_frc(:)/(dep_ra(:ncol,lt,lchnk) + rds(:,lt)) - endwhere - case( 'NH4', 'NH4NO3', 'XNH4NO3' ) - where( fr_lnduse(:ncol,lt) ) - wrk(:) = wrk(:) + lnd_frc(:)/(dep_ra(:ncol,lt,lchnk) + 0.5_r8*rds(:,lt)) - endwhere - - !------------------------------------------------------------------------------------- - ! ... special case for Pb (for consistency with offline code) - !------------------------------------------------------------------------------------- - case( 'Pb' ) - if( lt == 7 ) then - where( fr_lnduse(:ncol,lt) ) - wrk(:) = wrk(:) + lnd_frc(:) * 0.05e-2_r8 - endwhere - else - where( fr_lnduse(:ncol,lt) ) - wrk(:ncol) = wrk(:ncol) + lnd_frc(:ncol) * 0.2e-2_r8 - endwhere - end if - - !------------------------------------------------------------------------------------- - ! ... special case for carbon aerosols - !------------------------------------------------------------------------------------- - case( 'CB1', 'CB2', 'OC1', 'OC2', 'SOAM', 'SOAI', 'SOAT', 'SOAB','SOAX' ) - if ( drydep_method == DD_XLND ) then - where( fr_lnduse(:ncol,lt) ) - wrk(:ncol) = wrk(:ncol) + lnd_frc(:ncol) * 0.10e-2_r8 - endwhere - else - wrk(:ncol) = 0.10e-2_r8 - endif - - !------------------------------------------------------------------------------------- - ! deposition over ocean for HCN, CH3CN - ! velocity estimated from aircraft measurements (E.Apel, INTEX-B) - !------------------------------------------------------------------------------------- - case( 'HCN','CH3CN' ) - if( lt == 7 ) then ! over ocean only - where( fr_lnduse(:ncol,lt) .and. snow(:ncol) < 0.01_r8 ) - wrk(:ncol) = wrk(:ncol) + lnd_frc(:ncol) * 0.2e-2_r8 - endwhere - end if - case default - where( fr_lnduse(:ncol,lt) ) - wrk(:ncol) = wrk(:ncol) + lnd_frc(:ncol)/(dep_ra(:ncol,lt,lchnk) + dep_rb(:ncol,lt,lchnk) + resc(:ncol)) - endwhere - end select - end do lt_loop - dvel(:ncol,ispec) = wrk(:ncol) * scaling_to_cm_per_s - dflx(:ncol,ispec) = term(:ncol) * dvel(:ncol,ispec) * mmr(:ncol,plev,ispec) - end if - - end do species_loop3 - - if ( beglt > 1 ) return - - !------------------------------------------------------------------------------------- - ! ... special adjustments - !------------------------------------------------------------------------------------- - if( mpan_ndx > 0 ) then - if( has_dvel(mpan_ndx) ) then - dvel(:ncol,mpan_ndx) = dvel(:ncol,mpan_ndx)/3._r8 - dflx(:ncol,mpan_ndx) = term(:ncol) * dvel(:ncol,mpan_ndx) * mmr(:ncol,plev,mpan_ndx) - end if - end if - if( xmpan_ndx > 0 ) then - if( has_dvel(xmpan_ndx) ) then - dvel(:ncol,xmpan_ndx) = dvel(:ncol,xmpan_ndx)/3._r8 - dflx(:ncol,xmpan_ndx) = term(:ncol) * dvel(:ncol,xmpan_ndx) * mmr(:ncol,plev,xmpan_ndx) - end if - end if - - ! HCOOH, use CH3COOH dep.vel - if( hcooh_ndx > 0) then - if( has_dvel(hcooh_ndx) ) then - dvel(:ncol,hcooh_ndx) = dvel(:ncol,ch3cooh_ndx) - dflx(:ncol,hcooh_ndx) = term(:ncol) * dvel(:ncol,hcooh_ndx) * mmr(:ncol,plev,hcooh_ndx) - end if - end if -! -! SOG species -! - if( sogm_ndx > 0) then - if( has_dvel(sogm_ndx) ) then - dvel(:ncol,sogm_ndx) = dvel(:ncol,ch3cooh_ndx) - dflx(:ncol,sogm_ndx) = term(:ncol) * dvel(:ncol,sogm_ndx) * mmr(:ncol,plev,sogm_ndx) - end if - end if - if( sogi_ndx > 0) then - if( has_dvel(sogi_ndx) ) then - dvel(:ncol,sogi_ndx) = dvel(:ncol,ch3cooh_ndx) - dflx(:ncol,sogi_ndx) = term(:ncol) * dvel(:ncol,sogi_ndx) * mmr(:ncol,plev,sogi_ndx) - end if - end if - if( sogt_ndx > 0) then - if( has_dvel(sogt_ndx) ) then - dvel(:ncol,sogt_ndx) = dvel(:ncol,ch3cooh_ndx) - dflx(:ncol,sogt_ndx) = term(:ncol) * dvel(:ncol,sogt_ndx) * mmr(:ncol,plev,sogt_ndx) - end if - end if - if( sogb_ndx > 0) then - if( has_dvel(sogb_ndx) ) then - dvel(:ncol,sogb_ndx) = dvel(:ncol,ch3cooh_ndx) - dflx(:ncol,sogb_ndx) = term(:ncol) * dvel(:ncol,sogb_ndx) * mmr(:ncol,plev,sogb_ndx) - end if - end if - if( sogx_ndx > 0) then - if( has_dvel(sogx_ndx) ) then - dvel(:ncol,sogx_ndx) = dvel(:ncol,ch3cooh_ndx) - dflx(:ncol,sogx_ndx) = term(:ncol) * dvel(:ncol,sogx_ndx) * mmr(:ncol,plev,sogx_ndx) - end if - end if -! - end subroutine drydep_xactive - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine soilw_inti( ncfile, nlon_veg, nlat_veg, soilw_map ) - !------------------------------------------------------------------ - ! ... read primary soil moisture table - !------------------------------------------------------------------ - - use time_manager, only : get_calday - - implicit none - - !------------------------------------------------------------------ - ! ... dummy args - !------------------------------------------------------------------ - integer, intent(in) :: & - nlon_veg, & - nlat_veg - real(r8), pointer :: soilw_map(:,:,:) - character(len=*), intent(in) :: ncfile ! file name of netcdf file containing data - - !------------------------------------------------------------------ - ! ... local variables - !------------------------------------------------------------------ - integer :: gndx = 0 - integer :: nlat, & ! # of lats in soilw file - nlon ! # of lons in soilw file - integer :: i, ip, k, m - integer :: j, jl, ju - integer :: lev, day, ierr - type(file_desc_t) :: piofile - type(var_desc_t) :: vid - - integer :: dimid_lat, dimid_lon, dimid_time - integer :: dates(12) = (/ 116, 214, 316, 415, 516, 615, & - 716, 816, 915, 1016, 1115, 1216 /) - - character(len=shr_kind_cl) :: locfn - - !----------------------------------------------------------------------- - ! ... open netcdf file - !----------------------------------------------------------------------- - call getfil (ncfile, locfn, 0) - call cam_pio_openfile (piofile, trim(locfn), PIO_NOWRITE) - - !----------------------------------------------------------------------- - ! ... get longitudes - !----------------------------------------------------------------------- - ierr = pio_inq_dimid( piofile, 'lon', dimid_lon ) - ierr = pio_inq_dimlen( piofile, dimid_lon, nlon ) - if( nlon /= nlon_veg ) then - write(iulog,*) 'soilw_inti: soil and vegetation lons differ; ',nlon, nlon_veg - call endrun - end if - !----------------------------------------------------------------------- - ! ... get latitudes - !----------------------------------------------------------------------- - ierr = pio_inq_dimid( piofile, 'lat', dimid_lat ) - ierr = pio_inq_dimlen( piofile, dimid_lat, nlat ) - if( nlat /= nlat_veg ) then - write(iulog,*) 'soilw_inti: soil and vegetation lats differ; ',nlat, nlat_veg - call endrun - end if - !----------------------------------------------------------------------- - ! ... set times (days of year) - !----------------------------------------------------------------------- - ierr = pio_inq_dimid( piofile, 'time', dimid_time ) - ierr = pio_inq_dimlen( piofile, dimid_time, ndays ) - if( ndays /= 12 ) then - write(iulog,*) 'soilw_inti: dataset not a cyclical year' - call endrun - end if - allocate( days(ndays),stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'soilw_inti: days allocation error = ',ierr - call endrun - end if - do m = 1,min(12,ndays) - days(m) = get_calday( dates(m), 0 ) - end do - - !------------------------------------------------------------------ - ! ... allocate arrays - !------------------------------------------------------------------ - allocate( soilw_map(nlon,nlat,ndays), stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'soilw_inti: soilw_map allocation error = ',ierr - call endrun - end if - - !------------------------------------------------------------------ - ! ... read in the soil moisture - !------------------------------------------------------------------ - ierr = pio_inq_varid( piofile, 'SOILW', vid ) - ierr = pio_get_var( piofile, vid, soilw_map ) - !------------------------------------------------------------------ - ! ... close file - !------------------------------------------------------------------ - call cam_pio_closefile( piofile ) - - end subroutine soilw_inti - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine chk_soilw( calday ) - !-------------------------------------------------------------------- - ! ... check timing for ub values - !-------------------------------------------------------------------- - - use mo_constants, only : dayspy - - implicit none - - !-------------------------------------------------------------------- - ! ... dummy args - !-------------------------------------------------------------------- - real(r8), intent(in) :: calday - - !-------------------------------------------------------------------- - ! ... local variables - !-------------------------------------------------------------------- - integer :: m, upper - real(r8) :: numer, denom - - !-------------------------------------------------------- - ! ... setup the time interpolation - !-------------------------------------------------------- - if( calday < days(1) ) then - next = 1 - last = ndays - else - if( days(ndays) < dayspy ) then - upper = ndays - else - upper = ndays - 1 - end if - do m = upper,1,-1 - if( calday >= days(m) ) then - exit - end if - end do - last = m - next = mod( m,ndays ) + 1 - end if - numer = calday - days(last) - denom = days(next) - days(last) - if( numer < 0._r8 ) then - numer = dayspy + numer - end if - if( denom < 0._r8 ) then - denom = dayspy + denom - end if - dels = max( min( 1._r8,numer/denom ),0._r8 ) - - end subroutine chk_soilw - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - subroutine set_soilw( soilw, lchnk, calday ) - !-------------------------------------------------------------------- - ! ... set the soil moisture - !-------------------------------------------------------------------- - - implicit none - - !-------------------------------------------------------------------- - ! ... dummy args - !-------------------------------------------------------------------- - real(r8), intent(inout) :: soilw(pcols) - integer, intent(in) :: lchnk ! chunk indice - real(r8), intent(in) :: calday - - - integer :: i, ilon,ilat - - call chk_soilw( calday ) - - soilw(:) = soilw_3d(:,last,lchnk) + dels *( soilw_3d(:,next,lchnk) - soilw_3d(:,last,lchnk)) - - end subroutine set_soilw - - !------------------------------------------------------------------------------------- - !------------------------------------------------------------------------------------- - function has_drydep( name ) - - implicit none - - character(len=*), intent(in) :: name - - logical :: has_drydep - integer :: i - - has_drydep = .false. - - do i=1,nddvels - if ( trim(name) == trim(drydep_list(i)) ) then - has_drydep = .true. - exit - endif - enddo - - endfunction has_drydep - -end module mo_drydep diff --git a/src/physics/cam_oslo/mo_neu_wetdep.F90 b/src/physics/cam_oslo/mo_neu_wetdep.F90 deleted file mode 100644 index eae583761a..0000000000 --- a/src/physics/cam_oslo/mo_neu_wetdep.F90 +++ /dev/null @@ -1,1793 +0,0 @@ -! -! code written by J.-F. Lamarque, S. Walters and F. Vitt -! based on the original code from J. Neu developed for UC Irvine -! model -! -! LKE 2/23/2018 - correct setting flag for mass-limited (HNO3,etc.) vs Henry's Law washout -! -module mo_neu_wetdep -! - use shr_kind_mod, only : r8 => shr_kind_r8 - use cam_logfile, only : iulog - use constituents, only : pcnst - use spmd_utils, only : masterproc - use cam_abortutils, only : endrun - use seq_drydep_mod, only : n_species_table, species_name_table, dheff - use gas_wetdep_opts, only : gas_wetdep_method, gas_wetdep_list, gas_wetdep_cnt -#ifdef OSLO_AERO - use phys_control, only: phys_getopts - use mo_constants, only: rgrav - use phys_control, only: phys_getopts -#endif -! - implicit none -! - private - public :: neu_wetdep_init - public :: neu_wetdep_tend -! - save -! - integer, allocatable, dimension(:) :: mapping_to_heff,mapping_to_mmr - real(r8),allocatable, dimension(:) :: mol_weight - logical ,allocatable, dimension(:) :: ice_uptake - integer :: index_cldice,index_cldliq,nh3_ndx,co2_ndx - logical :: debug = .false. - integer :: hno3_ndx = 0 - integer :: h2o2_ndx = 0 -! -! diagnostics -! - logical :: do_diag = .false. - integer, parameter :: kdiag = 18 -! - real(r8), parameter :: zero = 0._r8 - real(r8), parameter :: one = 1._r8 -! - logical :: do_neu_wetdep -! - real(r8), parameter :: TICE=263._r8 - -contains - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- -! -subroutine neu_wetdep_init -! - use constituents, only : cnst_get_ind,cnst_mw - use cam_history, only : addfld, add_default, horiz_only - use phys_control, only : phys_getopts -! - integer :: m,l - character*20 :: test_name - - logical :: history_chemistry - - call phys_getopts(history_chemistry_out=history_chemistry) - - do_neu_wetdep = gas_wetdep_method == 'NEU' .and. gas_wetdep_cnt>0 - - if (.not.do_neu_wetdep) return - - allocate( mapping_to_heff(gas_wetdep_cnt) ) - allocate( mapping_to_mmr(gas_wetdep_cnt) ) - allocate( ice_uptake(gas_wetdep_cnt) ) - allocate( mol_weight(gas_wetdep_cnt) ) - -! -! find mapping to heff table -! - if ( debug ) then - print '(a,i4)','gas_wetdep_cnt=',gas_wetdep_cnt - print '(a,i4)','n_species_table=',n_species_table - end if - mapping_to_heff = -99 - do m=1,gas_wetdep_cnt -! - test_name = gas_wetdep_list(m) - if ( debug ) print '(i4,a)',m,trim(test_name) -! -! mapping based on the MOZART4 wet removal subroutine; -! this might need to be redone (JFL: Sep 2010) -! - select case( trim(test_name) ) -! -! CCMI: added SO2t and NH_50W -! - case( 'HYAC', 'CH3COOH' , 'HCOOH', 'EOOH', 'IEPOX' ) - test_name = 'CH2O' - case ( 'SOGB','SOGI','SOGM','SOGT','SOGX' ) - test_name = 'H2O2' - case ( 'SO2t' ) - test_name = 'SO2' - case ( 'CLONO2','BRONO2','HCL','HOCL','HOBR','HBR', 'Pb', 'MACROOH', 'ISOPOOH', 'XOOH', 'H2SO4', 'HF', 'COF2', 'COFCL') - test_name = 'HNO3' - case ( 'NH_50W', 'NDEP', 'NHDEP', 'NH4', 'NH4NO3' ) - test_name = 'HNO3' - case ( 'ALKOOH', 'MEKOOH', 'TOLOOH' ) - test_name = 'CH3OOH' - case( 'PHENOOH', 'BENZOOH', 'C6H5OOH', 'BZOOH', 'XYLOLOOH', 'XYLENOOH', 'HPALD' ) - test_name = 'CH3OOH' - case( 'TERPOOH', 'TERP2OOH', 'MBOOOH' ) - test_name = 'HNO3' - case( 'TERPROD1', 'TERPROD2' ) - test_name = 'CH2O' - case( 'HMPROP' ) - test_name = 'GLYALD' - case( 'NOA', 'ALKNIT', 'ISOPNITA', 'ISOPNITB', 'HONITR', 'ISOPNOOH' ) - test_name = 'H2O2' - case( 'NC4CHO', 'NC4CH2OH', 'TERPNIT', 'NTERPOOH' ) - test_name = 'H2O2' - case( 'SOAGbb0' ) ! Henry's Law coeff. added for VBS SOA's, biomass burning is the same as fossil fuels - test_name = 'SOAGff0' - case( 'SOAGbb1' ) - test_name = 'SOAGff1' - case( 'SOAGbb2' ) - test_name = 'SOAGff2' - case( 'SOAGbb3' ) - test_name = 'SOAGff3' - case( 'SOAGbb4' ) - test_name = 'SOAGff4' - end select -! - do l = 1,n_species_table -! -! if ( debug ) print '(i4,a)',l,trim(species_name_table(l)) -! - if( trim(test_name) == trim( species_name_table(l) ) ) then - mapping_to_heff(m) = l - if ( debug ) print '(a,a,i4)','mapping to heff of ',trim(species_name_table(l)),l - exit - end if - end do - if ( mapping_to_heff(m) == -99 ) then - if (masterproc) print *,'problem with mapping_to_heff of ',trim(test_name) -! call endrun() - end if -! -! special cases for NH3 and CO2 -! - if ( trim(test_name) == 'NH3' ) then - nh3_ndx = m - end if - if ( trim(test_name) == 'CO2' ) then - co2_ndx = m - end if - if ( trim(gas_wetdep_list(m)) == 'HNO3' ) then - hno3_ndx = m - end if -! - end do - - if (any ( mapping_to_heff(:) == -99 )) call endrun('mo_neu_wet->depwetdep_init: unmapped species error' ) -! - if ( debug ) then - print '(a,i4)','co2_ndx',co2_ndx - print '(a,i4)','nh3_ndx',nh3_ndx - end if -! -! find mapping to species -! - mapping_to_mmr = -99 - do m=1,gas_wetdep_cnt - if ( debug ) print '(i4,a)',m,trim(gas_wetdep_list(m)) - call cnst_get_ind(gas_wetdep_list(m), mapping_to_mmr(m), abort=.false. ) - if ( debug ) print '(a,i4)','mapping_to_mmr ',mapping_to_mmr(m) - if ( mapping_to_mmr(m) <= 0 ) then - print *,'problem with mapping_to_mmr of ',gas_wetdep_list(m) - call endrun('problem with mapping_to_mmr of '//trim(gas_wetdep_list(m))) - end if - end do -! -! define species-dependent arrays -! - do m=1,gas_wetdep_cnt -! - mol_weight(m) = cnst_mw(mapping_to_mmr(m)) - if ( debug ) print '(i4,a,f8.4)',m,' mol_weight ',mol_weight(m) - ice_uptake(m) = .false. - if ( trim(gas_wetdep_list(m)) == 'HNO3' ) then - ice_uptake(m) = .true. - end if -! -! - end do -! -! indices for cloud quantities -! - call cnst_get_ind( 'CLDICE', index_cldice ) - call cnst_get_ind( 'CLDLIQ', index_cldliq ) -! -! define output -! - do m=1,gas_wetdep_cnt - call addfld ('DTWR_'//trim(gas_wetdep_list(m)),(/ 'lev' /), 'A','kg/kg/s','wet removal Neu scheme tendency') - call addfld ('WD_'//trim(gas_wetdep_list(m)),horiz_only, 'A','kg/m2/s','vertical integrated wet deposition flux') - call addfld ('HEFF_'//trim(gas_wetdep_list(m)),(/ 'lev' /), 'A','M/atm','Effective Henrys Law coeff.') - if (history_chemistry) then - call add_default('DTWR_'//trim(gas_wetdep_list(m)), 1, ' ') - call add_default('WD_'//trim(gas_wetdep_list(m)), 1, ' ') - end if - end do -! - if ( do_diag ) then - call addfld ('QT_RAIN_HNO3',(/ 'lev' /), 'A','mol/mol/s','wet removal Neu scheme rain tendency') - call addfld ('QT_RIME_HNO3',(/ 'lev' /), 'A','mol/mol/s','wet removal Neu scheme rain tendency') - call addfld ('QT_WASH_HNO3',(/ 'lev' /), 'A','mol/mol/s','wet removal Neu scheme rain tendency') - call addfld ('QT_EVAP_HNO3',(/ 'lev' /), 'A','mol/mol/s','wet removal Neu scheme rain tendency') - if (history_chemistry) then - call add_default('QT_RAIN_HNO3',1,' ') - call add_default('QT_RIME_HNO3',1,' ') - call add_default('QT_WASH_HNO3',1,' ') - call add_default('QT_EVAP_HNO3',1,' ') - end if - end if -! - return -! -end subroutine neu_wetdep_init -! -subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & - prain, nevapr, cld, cmfdqr, wd_tend, wd_tend_int) -! - use ppgrid, only : pcols, pver -!!DEK - use phys_grid, only : get_area_all_p, get_rlat_all_p - use shr_const_mod, only : SHR_CONST_REARTH,SHR_CONST_G - use cam_history, only : outfld -! - implicit none -! - integer, intent(in) :: lchnk,ncol - real(r8), intent(in) :: mmr(pcols,pver,pcnst) ! mass mixing ratio (kg/kg) - real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressures (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! pressure delta about midpoints (Pa) - real(r8), intent(in) :: zint(pcols,pver+1) ! interface geopotential height above the surface (m) - real(r8), intent(in) :: tfld(pcols,pver) ! midpoint temperature (K) - real(r8), intent(in) :: delt ! timestep (s) -! - real(r8), intent(in) :: prain(ncol, pver) - real(r8), intent(in) :: nevapr(ncol, pver) - real(r8), intent(in) :: cld(ncol, pver) - real(r8), intent(in) :: cmfdqr(ncol, pver) - real(r8), intent(inout) :: wd_tend(pcols,pver,pcnst) - real(r8), intent(inout) :: wd_tend_int(pcols,pcnst) -! -! local arrays and variables -! - integer :: i,k,l,kk,m,id - real(r8), parameter :: rearth = SHR_CONST_REARTH ! radius earth (m) - real(r8), parameter :: gravit = SHR_CONST_G ! m/s^2 - real(r8), dimension(ncol) :: area, wk_out - real(r8), dimension(ncol,pver) :: cldice,cldliq,cldfrc,totprec,totevap,delz,delp,p - real(r8), dimension(ncol,pver) :: rls,evaprate,mass_in_layer,temp - real(r8), dimension(ncol,pver,gas_wetdep_cnt) :: trc_mass,heff,dtwr - real(r8), dimension(ncol,pver,gas_wetdep_cnt) :: wd_mmr - logical , dimension(gas_wetdep_cnt) :: tckaqb - integer , dimension(ncol) :: test_flag -! -! arrays for HNO3 diagnostics -! - real(r8), dimension(ncol,pver) :: qt_rain,qt_rime,qt_wash,qt_evap -! -! for Henry's law calculations -! - real(r8), parameter :: t0 = 298._r8 - real(r8), parameter :: ph = 1.e-5_r8 - real(r8), parameter :: ph_inv = 1._r8/ph - real(r8) :: e298, dhr - real(r8), dimension(ncol) :: dk1s,dk2s,wrk -!!DEK - real(r8) :: pi - real(r8) :: lats(pcols) - -#ifdef OSLO_AERO - real(r8) :: wrk_wd(pcols) - logical history_aerosol -#endif - -call phys_getopts( history_aerosol_out = history_aerosol) -! -! from cam/src/physics/cam/stratiform.F90 -! -!!DEK - pi = 4._r8*atan(1.0_r8) - - if (.not.do_neu_wetdep) return -! -! don't do anything if there are no species to be removed -! - if ( gas_wetdep_cnt == 0 ) return -! -! reset output variables -! - wd_tend_int = 0._r8 -! -! get area (in radians square) -! - call get_area_all_p(lchnk, ncol, area) - area = area * rearth**2 ! in m^2 -! -! reverse order along the vertical before calling -! J. Neu's wet removal subroutine -! - do k=1,pver - kk = pver - k + 1 - do i=1,ncol -! - mass_in_layer(i,k) = area(i) * pdel(i,kk)/gravit ! kg -! - cldice (i,k) = mmr(i,kk,index_cldice) ! kg/kg - cldliq (i,k) = mmr(i,kk,index_cldliq) ! kg/kg - cldfrc (i,k) = cld(i,kk) ! unitless -! - totprec(i,k) = (prain(i,kk)+cmfdqr(i,kk)) & - * mass_in_layer(i,k) ! kg/s - totevap(i,k) = nevapr(i,kk) * mass_in_layer(i,k) ! kg/s -! - delz(i,k) = zint(i,kk) - zint(i,kk+1) ! in m -! - temp(i,k) = tfld(i,kk) -! -! convert tracer mass to kg to kg/kg -! - trc_mass(i,k,:) = mmr(i,kk,mapping_to_mmr(:)) * mass_in_layer(i,k) -! - delp(i,k) = pdel(i,kk) * 0.01_r8 ! in hPa - p (i,k) = pmid(i,kk) * 0.01_r8 ! in hPa -! - end do - end do -! -! define array for tendency calculation (on model grid) -! - dtwr(1:ncol,:,:) = mmr(1:ncol,:,mapping_to_mmr(:)) -! -! compute 1) integrated precipitation flux across the interfaces (rls) -! 2) evaporation rate -! - rls (:,pver) = 0._r8 - evaprate (:,pver) = 0._r8 - do k=pver-1,1,-1 - rls (:,k) = max(0._r8,totprec(:,k)-totevap(:,k)+rls(:,k+1)) - !evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+totprec(:,k)+1.e-36_r8)) - evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+1.e-36_r8)) - end do -! -! compute effective Henry's law coefficients -! code taken from models/drv/shr/seq_drydep_mod.F90 -! - heff = 0._r8 - do k=1,pver -! - kk = pver - k + 1 -! - wrk(:) = (t0-tfld(1:ncol,kk))/(t0*tfld(1:ncol,kk)) -! - do m=1,gas_wetdep_cnt -! - l = mapping_to_heff(m) - id = 6*(l - 1) - e298 = dheff(id+1) - dhr = dheff(id+2) - heff(:,k,m) = e298*exp( dhr*wrk(:) ) - test_flag = -99 - if( dheff(id+3) /= 0._r8 .and. dheff(id+5) == 0._r8 ) then - e298 = dheff(id+3) - dhr = dheff(id+4) - dk1s(:) = e298*exp( dhr*wrk(:) ) - where( heff(:,k,m) /= 0._r8 ) - heff(:,k,m) = heff(:,k,m)*(1._r8 + dk1s(:)*ph_inv) - elsewhere - test_flag = 1 - heff(:,k,m) = dk1s(:)*ph_inv - endwhere - end if -! - if (k.eq.1 .and. maxval(test_flag) > 0 .and. debug ) print '(a,i4)','heff for m=',m -! - if( dheff(id+5) /= 0._r8 ) then - if( nh3_ndx > 0 .or. co2_ndx > 0 ) then - e298 = dheff(id+3) - dhr = dheff(id+4) - dk1s(:) = e298*exp( dhr*wrk(:) ) - e298 = dheff(id+5) - dhr = dheff(id+6) - dk2s(:) = e298*exp( dhr*wrk(:) ) - if( m == co2_ndx ) then - heff(:,k,m) = heff(:,k,m)*(1._r8 + dk1s(:)*ph_inv)*(1._r8 + dk2s(:)*ph_inv) - else if( m == nh3_ndx ) then - heff(:,k,m) = heff(:,k,m)*(1._r8 + dk1s(:)*ph/dk2s(:)) - else - write(iulog,*) 'error in assigning henrys law coefficients' - write(iulog,*) 'species ',m - end if - end if - end if -! - end do - end do -! - if ( debug ) then - print '(a,50f8.2)','tckaqb ',tckaqb - print '(a,50e12.4)','heff ',heff(1,1,:) - print '(a,50i4)' ,'ice_uptake ',ice_uptake - print '(a,50f8.2)','mol_weight ',mol_weight(:) - print '(a,50f8.2)','temp ',temp(1,:) - print '(a,50f8.2)','p ',p (1,:) - end if -! -! call J. Neu's subroutine -! - do i=1,ncol -! - call washo(pver,gas_wetdep_cnt,delt,trc_mass(i,:,:),mass_in_layer(i,:),p(i,:),delz(i,:) & - ,rls(i,:),cldliq(i,:),cldice(i,:),cldfrc(i,:),temp(i,:),evaprate(i,:) & - ,area(i),heff(i,:,:),mol_weight(:),tckaqb(:),ice_uptake(:) & - ,qt_rain(i,:),qt_rime(i,:),qt_wash(i,:),qt_evap(i,:) ) -! - end do -! -! compute tendencies and convert back to mmr -! on original vertical grid -! - do k=1,pver - kk = pver - k + 1 - do i=1,ncol -! -! convert tracer mass from kg -! - wd_mmr(i,kk,:) = trc_mass(i,k,:) / mass_in_layer(i,k) -! - end do - end do -! -! tendency calculation (on model grid) -! - dtwr(1:ncol,:,:) = wd_mmr(1:ncol,:,:) - dtwr(1:ncol,:,:) - dtwr(1:ncol,:,:) = dtwr(1:ncol,:,:) / delt - -!!DEK polarward of 60S, 60N and <200hPa set to zero! - call get_rlat_all_p(lchnk, pcols, lats ) - do k = 1, pver - do i= 1, ncol - if ( abs( lats(i)*180._r8/pi ) > 60._r8 ) then - if ( pmid(i,k) < 20000._r8) then - dtwr(i,k,:) = 0._r8 - endif - endif - end do - end do -! -! output tendencies -! - do m=1,gas_wetdep_cnt - wd_tend(1:ncol,:,mapping_to_mmr(m)) = wd_tend(1:ncol,:,mapping_to_mmr(m)) + dtwr(1:ncol,:,m) - call outfld( 'DTWR_'//trim(gas_wetdep_list(m)),dtwr(:,:,m),ncol,lchnk ) - - call outfld( 'HEFF_'//trim(gas_wetdep_list(m)),heff(:,pver:1:-1,m),ncol,lchnk ) -! -! vertical integrated wet deposition rate [kg/m2/s] -! - wk_out = 0._r8 - do k=1,pver - kk = pver - k + 1 - wk_out(1:ncol) = wk_out(1:ncol) + (dtwr(1:ncol,k,m) * mass_in_layer(1:ncol,kk)/area(1:ncol)) - end do - call outfld( 'WD_'//trim(gas_wetdep_list(m)),wk_out,ncol,lchnk ) -! -! to be used in mo_chm_diags to compute wet_deposition_NOy_as_N and wet_deposition_NHx_as_N (units: kg/m2/s) -! - if ( debug) print *,'mo_neu ',mapping_to_mmr(m),(wk_out(1:ncol)) - wd_tend_int(1:ncol,mapping_to_mmr(m)) = wk_out(1:ncol) -! - end do - -!This is output normally in mo_chm_diags, but -!if neu wetdep, we have to output it here! -#ifdef OSLO_AERO - if(history_aerosol)then - do m=1,gas_wetdep_cnt - wrk_wd(:ncol) = 0.0_r8 - do k=1,pver - !Note sign: tendency is negative, so this becomes a positive flux! - wrk_wd(:ncol) = wrk_wd(:ncol) & - - wd_tend(1:ncol,k,mapping_to_mmr(m))*pdel(:ncol,k)*rgrav !kg/m2/sec - end do - call outfld('WD_A_'//trim(gas_wetdep_list(m)),wrk_wd(:ncol),ncol,lchnk) - end do - end if -#endif -! - if ( do_diag ) then - call outfld('QT_RAIN_HNO3', qt_rain, ncol, lchnk ) - call outfld('QT_RIME_HNO3', qt_rime, ncol, lchnk ) - call outfld('QT_WASH_HNO3', qt_wash, ncol, lchnk ) - call outfld('QT_EVAP_HNO3', qt_evap, ncol, lchnk ) - end if -! - return -end subroutine neu_wetdep_tend - -!----------------------------------------------------------------------- -! -! Original code from Jessica Neu -! Updated by S. Walters and J.-F. Lamarque (March-April 2011) -! -!----------------------------------------------------------------------- - - subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & - RLS,CLWC,CIWC,CFR,TEM,EVAPRATE,GAREA,HSTAR,TCMASS,TCKAQB, & - TCNION, qt_rain, qt_rime, qt_wash, qt_evap) -! - implicit none - -!----------------------------------------------------------------------- -!---p-conde 5.4 (2007) -----called from main----- -!---called from pmain to calculate rainout and washout of tracers -!---revised by JNEU 8/2007 -!--- -!-LAER has been removed - no scavenging for aerosols -!-LAER could be used as LWASHTYP -!---WILL THIS WORK FOR T42->T21??????????? -!----------------------------------------------------------------------- - - integer LPAR, NTRACE - real(r8), intent(inout) :: QTTJFL(LPAR,NTRACE) - real(r8), intent(in) :: DTSCAV, QM(LPAR),POFL(LPAR),DELZ(LPAR),GAREA - real(r8), intent(in) :: RLS(LPAR),CLWC(LPAR),CIWC(LPAR),CFR(LPAR),TEM(LPAR), & - EVAPRATE(LPAR) - real(r8), intent(in) :: HSTAR(LPAR,NTRACE),TCMASS(NTRACE) - logical , intent(in) :: TCKAQB(NTRACE),TCNION(NTRACE) -! - real(r8), intent(inout) :: qt_rain(lpar) - real(r8), intent(inout) :: qt_rime(lpar) - real(r8), intent(inout) :: qt_wash(lpar) - real(r8), intent(inout) :: qt_evap(lpar) -! - integer I,J,L,N,LE, LM1 - real(r8), dimension(LPAR) :: CFXX - real(r8), dimension(LPAR) :: QTT, QTTNEW - - real(r8) WRK, RNEW_TST - real(r8) CLWX - real(r8) RNEW,RPRECIP,DELTARIMEMASS,DELTARIME,RAMPCT - real(r8) MASSLOSS - real(r8) DOR,DNEW,DEMP,COLEFFSNOW,RHOSNOW - real(r8) WEMP,REMP,RRAIN,RWASH - real(r8) QTPRECIP,QTRAIN,QTCXA,QTAX,QTOC - - real(r8) FAMA,RAMA,DAMA,FCA,RCA,DCA - real(r8) FAX,RAX,DAX,FCXA,RCXA,DCXA,FCXB,RCXB,DCXB - real(r8) RAXADJ,FAXADJ,RAXADJF - real(r8) QTDISCF,QTDISRIME,QTDISCXA - real(r8) QTEVAPAXP,QTEVAPAXW,QTEVAPAX - real(r8) QTWASHAX - real(r8) QTEVAPCXAP,QTEVAPCXAW,QTEVAPCXA - real(r8) QTWASHCXA,QTRIMECXA - real(r8) QTRAINCXA,QTRAINCXB - real(r8) QTTOPCA,QTTOPAA,QTTOPCAX,QTTOPAAX - - real(r8) AMPCT,AMCLPCT,CLNEWPCT,CLNEWAMPCT,CLOLDPCT,CLOLDAMPCT - real(r8) RAXLOC,RCXALOC,RCXBLOC,RCALOC,RAMALOC,RCXPCT - - real(r8) QTNETLCXA,QTNETLCXB,QTNETLAX,QTNETL - real(r8) QTDISSTAR - - - real(r8), parameter :: CFMIN=0.1_r8 - real(r8), parameter :: CWMIN=1.0e-5_r8 - real(r8), parameter :: DMIN=1.0e-1_r8 !mm - real(r8), parameter :: VOLPOW=1._r8/3._r8 - real(r8), parameter :: RHORAIN=1.0e3_r8 !kg/m3 - real(r8), parameter :: RHOSNOWFIX=1.0e2_r8 !kg/m3 - real(r8), parameter :: COLEFFRAIN=0.7_r8 - real(r8), parameter :: TMIX=258._r8 - real(r8), parameter :: TFROZ=240._r8 - real(r8), parameter :: COLEFFAER=0.05_r8 -! -! additional work arrays and diagnostics -! - real(r8) :: rls_wrk(lpar) - real(r8) :: rnew_wrk(lpar) - real(r8) :: rca_wrk(lpar) - real(r8) :: fca_wrk(lpar) - real(r8) :: rcxa_wrk(lpar) - real(r8) :: fcxa_wrk(lpar) - real(r8) :: rcxb_wrk(lpar) - real(r8) :: fcxb_wrk(lpar) - real(r8) :: rax_wrk(lpar,2) - real(r8) :: fax_wrk(lpar,2) - real(r8) :: rama_wrk(lpar) - real(r8) :: fama_wrk(lpar) - real(r8) :: deltarime_wrk(lpar) - real(r8) :: clwx_wrk(lpar) - real(r8) :: frc(lpar,3) - real(r8) :: rlsog(lpar) -! - logical :: is_hno3 - logical :: rls_flag(lpar) - logical :: rnew_flag(lpar) - logical :: cf_trigger(lpar) - logical :: freezing(lpar) -! - real(r8), parameter :: four = 4._r8 - real(r8), parameter :: adj_factor = one + 10._r8*epsilon( one ) -! - integer :: LWASHTYP,LICETYP -! - if ( debug ) then - print '(a,50f8.2)','tckaqb ',tckaqb - print '(a,50e12.4)','hstar ',hstar(1,:) - print '(a,50i4)' ,'ice_uptake ',TCNION - print '(a,50f8.2)','mol_weight ',TCMASS(:) - print '(a,50f8.2)','temp ',tem(:) - print '(a,50f8.2)','p ',pofl(:) - end if - -!----------------------------------------------------------------------- - LE = LPAR-1 -! - rls_flag(1:le) = rls(1:le) > zero - freezing(1:le) = tem(1:le) < tice - rlsog(1:le) = rls(1:le)/garea -! -species_loop : & - do N = 1,NTRACE - QTT(:lpar) = QTTJFL(:lpar,N) - QTTNEW(:lpar) = QTTJFL(:lpar,N) - is_hno3 = n == hno3_ndx - if( is_hno3 ) then - qt_rain(:lpar) = zero - qt_rime(:lpar) = zero - qt_wash(:lpar) = zero - qt_evap(:lpar) = zero - rca_wrk(:lpar) = zero - fca_wrk(:lpar) = zero - rcxa_wrk(:lpar) = zero - fcxa_wrk(:lpar) = zero - rcxb_wrk(:lpar) = zero - fcxb_wrk(:lpar) = zero - rls_wrk(:lpar) = zero - rnew_wrk(:lpar) = zero - cf_trigger(:lpar) = .false. - clwx_wrk(:lpar) = -9999._r8 - deltarime_wrk(:lpar) = -9999._r8 - rax_wrk(:lpar,:) = zero - fax_wrk(:lpar,:) = zero - endif - -!----------------------------------------------------------------------- -! check whether soluble in ice -!----------------------------------------------------------------------- - if( TCNION(N) ) then - LICETYP = 1 - else - LICETYP = 2 - end if - -!----------------------------------------------------------------------- -! initialization -!----------------------------------------------------------------------- - QTTOPAA = zero - QTTOPCA = zero - - RCA = zero - FCA = zero - DCA = zero - RAMA = zero - FAMA = zero - DAMA = zero - - AMPCT = zero - AMCLPCT = zero - CLNEWPCT = zero - CLNEWAMPCT = zero - CLOLDPCT = zero - CLOLDAMPCT = zero -!----------------------------------------------------------------------- -! Check whether precip in top layer - if so, require CF ge 0.2 -!----------------------------------------------------------------------- - if( RLS(LE) > zero ) then - CFXX(LE) = max( CFMIN,CFR(LE) ) - else - CFXX(LE) = CFR(LE) - endif - - rnew_flag(1:le) = .false. - -level_loop : & - do L = LE,1,-1 - LM1 = L - 1 - FAX = zero - RAX = zero - DAX = zero - FCXA = zero - FCXB = zero - DCXA = zero - DCXB = zero - RCXA = zero - RCXB = zero - - QTDISCF = zero - QTDISRIME = zero - QTDISCXA = zero - - QTEVAPAXP = zero - QTEVAPAXW = zero - QTEVAPAX = zero - QTWASHAX = zero - - QTEVAPCXAP = zero - QTEVAPCXAW = zero - QTEVAPCXA = zero - QTRIMECXA = zero - QTWASHCXA = zero - QTRAINCXA = zero - QTRAINCXB = zero - - RAMPCT = zero - RCXPCT = zero - - RCXALOC = zero - RCXBLOC = zero - RAXLOC = zero - RAMALOC = zero - RCALOC = zero - - RPRECIP = zero - DELTARIMEMASS = zero - DELTARIME = zero - DOR = zero - DNEW = zero - - QTTOPAAX = zero - QTTOPCAX = zero - -has_rls : & - if( rls_flag(l) ) then -!----------------------------------------------------------------------- -!-----Evaporate ambient precip and decrease area------------------------- -!-----If ice, diam=diam falling from above If rain, diam=4mm (not used) -!-----Evaporate tracer contained in evaporated precip -!-----Can't evaporate more than we start with----------------------------- -!-----Don't do washout until we adjust ambient precip to match Rbot if needed -!------(after RNEW if statements) -!----------------------------------------------------------------------- - FAX = max( zero,FAMA*(one - evaprate(l)) ) - RAX = RAMA !kg/m2/s - if ( debug ) then - if( (l == 3 .or. l == 2) ) then - write(*,*) 'washout: l,rls,fax = ',l,rls(l),fax - endif - endif - if( FAMA > zero ) then - if( freezing(l) ) then - DAX = DAMA !mm - else - DAX = four !mm - not necessary - endif - else - DAX = zero - endif - - if( RAMA > zero ) then - QTEVAPAXP = min( QTTOPAA,EVAPRATE(L)*QTTOPAA ) - else - QTEVAPAXP = zero - endif - if( is_hno3 ) then - rax_wrk(l,1) = rax - fax_wrk(l,1) = fax - endif - - -!----------------------------------------------------------------------- -! Determine how much the in-cloud precip rate has increased------ -!----------------------------------------------------------------------- - WRK = RAX*FAX + RCA*FCA - if( WRK > 0._r8 ) then - RNEW_TST = RLS(L)/(GAREA * WRK) - else - RNEW_TST = 10._r8 - endif - RNEW = RLSOG(L) - (RAX*FAX + RCA*FCA) !GBA*CF - rnew_wrk(l) = rnew_tst - if ( debug ) then - if( is_hno3 .and. l == kdiag-1 ) then - write(*,*) ' ' - write(*,*) 'washout: rls,rax,fax,rca,fca' - write(*,'(1p,5g15.7)') rls(l),rax,fax,rca,fca - write(*,*) ' ' - endif - endif -!----------------------------------------------------------------------- -! if RNEW>0, there is growth and/or new precip formation -!----------------------------------------------------------------------- -has_rnew: if( rlsog(l) > adj_factor*(rax*fax + rca*fca) ) then -!----------------------------------------------------------------------- -! Min cloudwater requirement for cloud with new precip -! Min CF is set at top for LE, at end for other levels -! CWMIN is only needed for new precip formation - do not need for RNEW<0 -!----------------------------------------------------------------------- - if( cfxx(l) == zero ) then - if ( do_diag ) then - write(*,*) 'cfxx(l) == zero',l - write(*,*) qttjfl(:,n) - write(*,*) qm(:) - write(*,*) pofl(:) - write(*,*) delz(:) - write(*,*) rls(:) - write(*,*) clwc(:) - write(*,*) ciwc(:) - write(*,*) cfr(:) - write(*,*) tem(:) - write(*,*) evaprate(:) - write(*,*) hstar(:,n) - end if -! -! if we are here,, that means that there is -! a inconsistency and this will lead to a division -! by 0 later on! This column should then be skipped -! - QTTJFL(:lpar,n) = QTT(:lpar) - cycle species_loop -! -! call endrun() -! - endif - rnew_flag(l) = .true. - CLWX = max( CLWC(L)+CIWC(L),CWMIN*CFXX(L) ) - if( is_hno3 ) then - clwx_wrk(l) = clwx - endif -!----------------------------------------------------------------------- -! Area of old cloud and new cloud -!----------------------------------------------------------------------- - FCXA = FCA - FCXB = max( zero,CFXX(L)-FCXA ) -!----------------------------------------------------------------------- -! ICE -! For ice and mixed phase, grow precip in old cloud by riming -! Use only portion of cloudwater in old cloud fraction -! and rain above old cloud fraction -! COLEFF from Lohmann and Roeckner (1996), Loss rate from Rotstayn (1997) -!----------------------------------------------------------------------- -is_freezing : & - if( freezing(l) ) then - COLEFFSNOW = exp( 2.5e-2_r8*(TEM(L) - TICE) ) - if( TEM(L) <= TFROZ ) then - RHOSNOW = RHOSNOWFIX - else - RHOSNOW = 0.303_r8*(TEM(L) - TFROZ)*RHOSNOWFIX - endif - if( FCXA > zero ) then - if( DCA > zero ) then - DELTARIMEMASS = CLWX*QM(L)*(FCXA/CFXX(L))* & - (one - exp( (-COLEFFSNOW/(DCA*1.e-3_r8))*((RCA)/(2._r8*RHOSNOW))*DTSCAV )) !uses GBA R - else - DELTARIMEMASS = zero - endif - else - DELTARIMEMASS = zero - endif -!----------------------------------------------------------------------- -! Increase in precip rate due to riming (kg/m2/s): -! Limit to total increase in R in cloud -!----------------------------------------------------------------------- - if( FCXA > zero ) then - DELTARIME = min( RNEW/FCXA,DELTARIMEMASS/(FCXA*GAREA*DTSCAV) ) !GBA - else - DELTARIME = zero - endif - if( is_hno3 ) then - deltarime_wrk(l) = deltarime - endif -!----------------------------------------------------------------------- -! Find diameter of rimed precip, must be at least .1mm -!----------------------------------------------------------------------- - if( RCA > zero ) then - DOR = max( DMIN,(((RCA+DELTARIME)/RCA)**VOLPOW)*DCA ) - else - DOR = zero - endif -!----------------------------------------------------------------------- -! If there is some in-cloud precip left, we have new precip formation -! Will be spread over whole cloud fraction -!----------------------------------------------------------------------- -! Calculate precip rate in old and new cloud fractions -!----------------------------------------------------------------------- - RPRECIP = (RNEW-(DELTARIME*FCXA))/CFXX(L) !kg/m2/s !GBA -!----------------------------------------------------------------------- -! Calculate precip rate in old and new cloud fractions -!----------------------------------------------------------------------- - RCXA = RCA + DELTARIME + RPRECIP !kg/m2/s GBA - RCXB = RPRECIP !kg/m2/s GBA - -!----------------------------------------------------------------------- -! Find diameter of new precip from empirical relation using Rprecip -! in given area of box- use density of water, not snow, to convert kg/s -! to mm/s -> as given in Field and Heymsfield -! Also calculate diameter of mixed precip,DCXA, from empirical relation -! using total R in FCXA - this will give larger particles than averaging DOR and -! DNEW in the next level -! DNEW and DCXA must be at least .1mm -!----------------------------------------------------------------------- - if( RPRECIP > zero ) then - WEMP = (CLWX*QM(L))/(GAREA*CFXX(L)*DELZ(L)) !kg/m3 - REMP = RPRECIP/((RHORAIN/1.e3_r8)) !mm/s local - DNEW = DEMPIRICAL( WEMP, REMP ) - if ( debug ) then - if( is_hno3 .and. l >= 15 ) then - write(*,*) ' ' - write(*,*) 'washout: wemp,remp.dnew @ l = ',l - write(*,'(1p,3g15.7)') wemp,remp,dnew - write(*,*) ' ' - endif - endif - DNEW = max( DMIN,DNEW ) - if( FCXB > zero ) then - DCXB = DNEW - else - DCXB = zero - endif - else - DCXB = zero - endif - - if( FCXA > zero ) then - WEMP = (CLWX*QM(L)*(FCXA/CFXX(L)))/(GAREA*FCXA*DELZ(L)) !kg/m3 - REMP = RCXA/((RHORAIN/1.e3_r8)) !mm/s local - DEMP = DEMPIRICAL( WEMP, REMP ) - DCXA = ((RCA+DELTARIME)/RCXA)*DOR + (RPRECIP/RCXA)*DNEW - DCXA = max( DEMP,DCXA ) - DCXA = max( DMIN,DCXA ) - else - DCXA = zero - endif - if ( debug ) then - if( is_hno3 .and. l >= 15 ) then - write(*,*) ' ' - write(*,*) 'washout: rca,rcxa,deltarime,dor,rprecip,dnew @ l = ',l - write(*,'(1p,6g15.7)') rca,rcxa,deltarime,dor,rprecip,dnew - write(*,*) 'washout: dcxa,dcxb,wemp,remp,demp' - write(*,'(1p,5g15.7)') dcxa,dcxb,wemp,remp,demp - write(*,*) ' ' - end if - endif - - if( QTT(L) > zero ) then -!----------------------------------------------------------------------- -! ICE SCAVENGING -!----------------------------------------------------------------------- -! For ice, rainout only hno3/aerosols using new precip -! Tracer dissolved given by Kaercher and Voigt (2006) for T<258K -! For T>258K, use Henry's Law with Retention coefficient -! Rain out in whole CF -!----------------------------------------------------------------------- - if( RPRECIP > zero ) then - if( LICETYP == 1 ) then - RRAIN = RPRECIP*GAREA !kg/s local - call DISGAS( CLWX, CFXX(L), TCMASS(N), HSTAR(L,N), & - TEM(L),POFL(L),QM(L), & - QTT(L)*CFXX(L),QTDISCF ) - call RAINGAS( RRAIN, DTSCAV, CLWX, CFXX(L), & - QM(L), QTT(L), QTDISCF, QTRAIN ) - WRK = QTRAIN/CFXX(L) - QTRAINCXA = FCXA*WRK - QTRAINCXB = FCXB*WRK - elseif( LICETYP == 2 ) then - QTRAINCXA = zero - QTRAINCXB = zero - endif - if( debug .and. is_hno3 .and. l == kdiag ) then - write(*,*) ' ' - write(*,*) 'washout: Ice Scavenging' - write(*,*) 'washout: qtraincxa, qtraincxb, fcxa, fcxb, qt_rain, cfxx(l), wrk @ level = ',l - write(*,'(1p,7g15.7)') qtraincxa, qtraincxb, fcxa, fcxb, qt_rain(l), cfxx(l), wrk - write(*,*) ' ' - endif - endif -!----------------------------------------------------------------------- -! For ice, accretion removal for hno3 and aerosols is propotional to riming, -! no accretion removal for gases -! remove only in mixed portion of cloud -! Limit DELTARIMEMASS to RNEW*DTSCAV for ice - evaporation of rimed ice to match -! RNEW precip rate would result in HNO3 escaping from ice (no trapping) -!----------------------------------------------------------------------- - if( DELTARIME > zero ) then - if( LICETYP == 1 ) then - if( TEM(L) <= TFROZ ) then - RHOSNOW = RHOSNOWFIX - else - RHOSNOW = 0.303_r8*(TEM(L) - TFROZ)*RHOSNOWFIX - endif - QTCXA = QTT(L)*FCXA - call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & - HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTCXA, QTDISRIME ) - QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) - if ( debug ) then - if( is_hno3 .and. l >= 15 ) then - write(*,*) ' ' - write(*,*) 'washout: fcxa,dca,rca,qtdisstar @ l = ',l - write(*,'(1p,4g15.7)') fcxa,dca,rca,qtdisstar - write(*,*) ' ' - endif - endif - QTRIMECXA = QTCXA* & - (one - exp((-COLEFFSNOW/(DCA*1.e-3_r8))* & - (RCA/(2._r8*RHOSNOW))* & !uses GBA R - (QTDISSTAR/QTCXA)*DTSCAV)) - QTRIMECXA = min( QTRIMECXA, & - ((RNEW*GAREA*DTSCAV)/(CLWX*QM(L)*(FCXA/CFXX(L))))*QTDISSTAR) - elseif( LICETYP == 2 ) then - QTRIMECXA = zero - endif - endif - else - QTRAINCXA = zero - QTRAINCXB = zero - QTRIMECXA = zero - endif -!----------------------------------------------------------------------- -! For ice, no washout in interstitial cloud air -!----------------------------------------------------------------------- - QTWASHCXA = zero - QTEVAPCXA = zero - -!----------------------------------------------------------------------- -! RAIN -! For rain, accretion increases rain rate but diameter remains constant -! Diameter is 4mm (not used) -!----------------------------------------------------------------------- - else is_freezing - if( FCXA > zero ) then - DELTARIMEMASS = (CLWX*QM(L))*(FCXA/CFXX(L))* & - (one - exp( -0.24_r8*COLEFFRAIN*((RCA)**0.75_r8)*DTSCAV )) !local - else - DELTARIMEMASS = zero - endif -!----------------------------------------------------------------------- -! Increase in precip rate due to riming (kg/m2/s): -! Limit to total increase in R in cloud -!----------------------------------------------------------------------- - if( FCXA > zero ) then - DELTARIME = min( RNEW/FCXA,DELTARIMEMASS/(FCXA*GAREA*DTSCAV) ) !GBA - else - DELTARIME = zero - endif -!----------------------------------------------------------------------- -! If there is some in-cloud precip left, we have new precip formation -!----------------------------------------------------------------------- - RPRECIP = (RNEW-(DELTARIME*FCXA))/CFXX(L) !GBA - - RCXA = RCA + DELTARIME + RPRECIP !kg/m2/s GBA - RCXB = RPRECIP !kg/m2/s GBA - DCXA = FOUR - if( FCXB > zero ) then - DCXB = FOUR - else - DCXB = zero - endif -!----------------------------------------------------------------------- -! RAIN SCAVENGING -! For rain, rainout both hno3/aerosols and gases using new precip -!----------------------------------------------------------------------- - if( QTT(L) > zero ) then - if( RPRECIP > zero ) then - RRAIN = (RPRECIP*GAREA) !kg/s local - call DISGAS( CLWX, CFXX(L), TCMASS(N), HSTAR(L,N), & - TEM(L), POFL(L), QM(L), & - QTT(L)*CFXX(L), QTDISCF ) - call RAINGAS( RRAIN, DTSCAV, CLWX, CFXX(L), & - QM(L), QTT(L), QTDISCF, QTRAIN ) - WRK = QTRAIN/CFXX(L) - QTRAINCXA = FCXA*WRK - QTRAINCXB = FCXB*WRK - if( debug .and. is_hno3 .and. l == kdiag ) then - write(*,*) ' ' - write(*,*) 'washout: Rain Scavenging' - write(*,*) 'washout: qtraincxa, qtraincxb, fcxa, fcxb, qt_rain, cfxx(l), wrk @ level = ',l - write(*,'(1p,7g15.7)') qtraincxa, qtraincxb, fcxa, fcxb, qt_rain(l), cfxx(l), wrk - write(*,*) ' ' - endif - endif -!----------------------------------------------------------------------- -! For rain, accretion removal is propotional to riming -! caclulate for hno3/aerosols and gases -! Remove only in mixed portion of cloud -! Limit DELTARIMEMASS to RNEW*DTSCAV -!----------------------------------------------------------------------- - if( DELTARIME > zero ) then - QTCXA = QTT(L)*FCXA - call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & - HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTCXA, QTDISRIME ) - QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) - QTRIMECXA = QTCXA* & - (one - exp(-0.24_r8*COLEFFRAIN* & - ((RCA)**0.75_r8)* & !local - (QTDISSTAR/QTCXA)*DTSCAV)) - QTRIMECXA = min( QTRIMECXA, & - ((RNEW*GAREA*DTSCAV)/(CLWX*QM(L)*(FCXA/CFXX(L))))*QTDISSTAR) - else - QTRIMECXA = zero - endif - else - QTRAINCXA = zero - QTRAINCXB = zero - QTRIMECXA = zero - endif -!----------------------------------------------------------------------- -! For rain, washout gases and HNO3/aerosols using rain from above old cloud -! Washout for HNO3/aerosols is only on non-dissolved portion, impaction-style -! Washout for gases is on non-dissolved portion, limited by QTTOP+QTRIME -!----------------------------------------------------------------------- - if( RCA > zero ) then - QTPRECIP = FCXA*QTT(L) - QTDISRIME - if( HSTAR(L,N) > 1.e4_r8 ) then - if( QTPRECIP > zero ) then - QTWASHCXA = QTPRECIP*(one - exp( -0.24_r8*COLEFFAER*((RCA)**0.75_r8)*DTSCAV )) !local - else - QTWASHCXA = zero - endif - QTEVAPCXA = zero - else - RWASH = RCA*GAREA !kg/s local - if( QTPRECIP > zero ) then - call WASHGAS( RWASH, FCA, DTSCAV, QTTOPCA+QTRIMECXA, & - HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTPRECIP, QTWASHCXA, QTEVAPCXA ) - else - QTWASHCXA = zero - QTEVAPCXA = zero - endif - endif - endif - endif is_freezing -!----------------------------------------------------------------------- -! If RNEW zero ) then - RCXA = min( RCA,RLS(L)/(GAREA*FCXA) ) !kg/m2/s GBA - if( FAX > zero .and. ((RCXA+1.e-12_r8) < RLS(L)/(GAREA*FCXA)) ) then - RAXADJF = RLS(L)/GAREA - RCXA*FCXA - RAMPCT = RAXADJF/(RAX*FAX) - FAXADJ = RAMPCT*FAX - if( FAXADJ > zero ) then - RAXADJ = RAXADJF/FAXADJ - else - RAXADJ = zero - endif - else - RAXADJ = zero - RAMPCT = zero - FAXADJ = zero - endif - else - RCXA = zero - if( FAX > zero ) then - RAXADJF = RLS(L)/GAREA - RAMPCT = RAXADJF/(RAX*FAX) - FAXADJ = RAMPCT*FAX - if( FAXADJ > zero ) then - RAXADJ = RAXADJF/FAXADJ - else - RAXADJ = zero - endif - else - RAXADJ = zero - RAMPCT = zero - FAXADJ = zero - endif - endif - - QTEVAPAXP = min( QTTOPAA,QTTOPAA - (RAMPCT*(QTTOPAA-QTEVAPAXP)) ) - FAX = FAXADJ - RAX = RAXADJ - if ( debug ) then - if( (l == 3 .or. l == 2) ) then - write(*,*) 'washout: l,fcxa,fax = ',l,fcxa,fax - endif - endif - -!----------------------------------------------------------------------- -! IN-CLOUD EVAPORATION/WASHOUT -! If precip out the bottom of the cloud is 0, evaporate everything -! If there is no cloud, QTTOPCA=0, so nothing happens -!----------------------------------------------------------------------- - if( RCXA <= zero ) then - QTEVAPCXA = QTTOPCA - RCXA = zero - DCXA = zero - else -!----------------------------------------------------------------------- -! If rain out the bottom of the cloud is >0 (but .le. RCA): -! For ice, decrease particle size, -! no washout -! no evap for non-ice gases (b/c there is nothing in ice) -! TTmix, hno3&aerosols are incorporated into ice structure: -! do not release -! For rain, assume full evaporation of some raindrops -! proportional evaporation for all species -! washout for gases using Rbot -! impact washout for hno3/aerosol portion in gas phase -!----------------------------------------------------------------------- -! if (TEM(L) < TICE ) then -is_freezing_a : & - if( freezing(l) ) then - QTWASHCXA = zero - DCXA = ((RCXA/RCA)**VOLPOW)*DCA - if( LICETYP == 1 ) then - if( TEM(L) <= TMIX ) then - MASSLOSS = (RCA-RCXA)*FCXA*GAREA*DTSCAV -!----------------------------------------------------------------------- -! note-QTT doesn't matter b/c T<258K -!----------------------------------------------------------------------- - call DISGAS( (MASSLOSS/QM(L)), FCXA, TCMASS(N), & - HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTT(L), QTEVAPCXA ) - QTEVAPCXA = min( QTTOPCA,QTEVAPCXA ) - else - QTEVAPCXA = zero - endif - elseif( LICETYP == 2 ) then - QTEVAPCXA = zero - endif - else is_freezing_a - QTEVAPCXAP = (RCA - RCXA)/RCA*QTTOPCA - DCXA = FOUR - QTCXA = FCXA*QTT(L) - if( HSTAR(L,N) > 1.e4_r8 ) then - if( QTT(L) > zero ) then - call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & - HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTCXA, QTDISCXA ) - if( QTCXA > QTDISCXA ) then - QTWASHCXA = (QTCXA - QTDISCXA)*(one - exp( -0.24_r8*COLEFFAER*((RCXA)**0.75_r8)*DTSCAV )) !local - else - QTWASHCXA = zero - endif - QTEVAPCXAW = zero - else - QTWASHCXA = zero - QTEVAPCXAW = zero - endif - else - RWASH = RCXA*GAREA !kg/s local - call WASHGAS( RWASH, FCXA, DTSCAV, QTTOPCA, HSTAR(L,N), & - TEM(L), POFL(L), QM(L), & - QTCXA-QTDISCXA, QTWASHCXA, QTEVAPCXAW ) - endif - QTEVAPCXA = QTEVAPCXAP + QTEVAPCXAW - endif is_freezing_a - endif - endif has_rnew - -!----------------------------------------------------------------------- -! AMBIENT WASHOUT -! Ambient precip is finalized - if it is rain, washout -! no ambient washout for ice, since gases are in vapor phase -!----------------------------------------------------------------------- - if( RAX > zero ) then - if( .not. freezing(l) ) then - QTAX = FAX*QTT(L) - if( HSTAR(L,N) > 1.e4_r8 ) then - QTWASHAX = QTAX* & - (one - exp(-0.24_r8*COLEFFAER* & - ((RAX)**0.75_r8)*DTSCAV)) !local - QTEVAPAXW = zero - else - RWASH = RAX*GAREA !kg/s local - call WASHGAS( RWASH, FAX, DTSCAV, QTTOPAA, HSTAR(L,N), & - TEM(L), POFL(L), QM(L), QTAX, & - QTWASHAX, QTEVAPAXW ) - endif - else - QTEVAPAXW = zero - QTWASHAX = zero - endif - else - QTEVAPAXW = zero - QTWASHAX = zero - endif - QTEVAPAX = QTEVAPAXP + QTEVAPAXW - -!----------------------------------------------------------------------- -! END SCAVENGING -! Require CF if our ambient evaporation rate would give less -! precip than R from model. -!----------------------------------------------------------------------- - if( do_diag .and. is_hno3 ) then - rls_wrk(l) = rls(l)/garea - rca_wrk(l) = rca - fca_wrk(l) = fca - rcxa_wrk(l) = rcxa - fcxa_wrk(l) = fcxa - rcxb_wrk(l) = rcxb - fcxb_wrk(l) = fcxb - rax_wrk(l,2) = rax - fax_wrk(l,2) = fax - endif -upper_level : & - if( L > 1 ) then - FAMA = max( FCXA + FCXB + FAX - CFR(LM1),zero ) - if( FAX > zero ) then - RAXLOC = RAX/FAX - else - RAXLOC = zero - endif - if( FCXA > zero ) then - RCXALOC = RCXA/FCXA - else - RCXALOC = zero - endif - if( FCXB > zero ) then - RCXBLOC = RCXB/FCXB - else - RCXBLOC = zero - endif - - if( CFR(LM1) >= CFMIN ) then - CFXX(LM1) = CFR(LM1) - else - if( adj_factor*RLSOG(LM1) >= (RCXA*FCXA + RCXB*FCXB + RAX*FAX)*(one - EVAPRATE(LM1)) ) then - CFXX(LM1) = CFMIN - cf_trigger(lm1) = .true. - else - CFXX(LM1) = CFR(LM1) - endif - if( is_hno3 .and. lm1 == kdiag .and. debug ) then - write(*,*) ' ' - write(*,*) 'washout: rls,garea,rcxa,fcxa,rcxb,fcxb,rax,fax' - write(*,'(1p,8g15.7)') rls(lm1),garea,rcxa,fcxa,rcxb,fcxb,rax,fax - write(*,*) ' ' - endif - endif -!----------------------------------------------------------------------- -! Figure out what will go into ambient and cloud below -! Don't do for lowest level -!----------------------------------------------------------------------- - if( FAX > zero ) then - RAXLOC = RAX/FAX - AMPCT = max( zero,min( one,(CFXX(L) + FAX - CFXX(LM1))/FAX ) ) - AMCLPCT = one - AMPCT - else - RAXLOC = zero - AMPCT = zero - AMCLPCT = zero - endif - if( FCXB > zero ) then - RCXBLOC = RCXB/FCXB - CLNEWPCT = max( zero,min( (CFXX(LM1) - FCXA)/FCXB,one ) ) - CLNEWAMPCT = one - CLNEWPCT - else - RCXBLOC = zero - CLNEWPCT = zero - CLNEWAMPCT = zero - endif - if( FCXA > zero ) then - RCXALOC = RCXA/FCXA - CLOLDPCT = max( zero,min( CFXX(LM1)/FCXA,one ) ) - CLOLDAMPCT = one - CLOLDPCT - else - RCXALOC = zero - CLOLDPCT = zero - CLOLDAMPCT = zero - endif -!----------------------------------------------------------------------- -! Remix everything for the next level -!----------------------------------------------------------------------- - FCA = min( CFXX(LM1),FCXA*CLOLDPCT + CLNEWPCT*FCXB + AMCLPCT*FAX ) - if( FCA > zero ) then -!----------------------------------------------------------------------- -! Maintain cloud core by reducing NC and AM area going into cloud below -!----------------------------------------------------------------------- - RCA = (RCXA*FCXA*CLOLDPCT + RCXB*FCXB*CLNEWPCT + RAX*FAX*AMCLPCT)/FCA - if ( debug ) then - if( is_hno3 ) then - write(*,*) ' ' - write(*,*) 'washout: rcxa,fcxa,cloldpctrca,rca,fca,dcxa @ l = ',l - write(*,'(1p,6g15.7)') rcxa,fcxa,cloldpct,rca,fca,dcxa - write(*,*) 'washout: rcxb,fcxb,clnewpct,dcxb' - write(*,'(1p,4g15.7)') rcxb,fcxb,clnewpct,dcxb - write(*,*) 'washout: rax,fax,amclpct,dax' - write(*,'(1p,4g15.7)') rax,fax,amclpct,dax - write(*,*) ' ' - endif - endif - - if (RCA > zero) then - DCA = (RCXA*FCXA*CLOLDPCT)/(RCA*FCA)*DCXA + & - (RCXB*FCXB*CLNEWPCT)/(RCA*FCA)*DCXB + & - (RAX*FAX*AMCLPCT)/(RCA*FCA)*DAX - else - DCA = zero - FCA = zero - endif - - else - FCA = zero - DCA = zero - RCA = zero - endif - - FAMA = FCXA + FCXB + FAX - CFXX(LM1) - if( FAMA > zero ) then - RAMA = (RCXA*FCXA*CLOLDAMPCT + RCXB*FCXB*CLNEWAMPCT + RAX*FAX*AMPCT)/FAMA - if( RAMA > zero ) then - DAMA = (RCXA*FCXA*CLOLDAMPCT)/(RAMA*FAMA)*DCXA + & - (RCXB*FCXB*CLNEWAMPCT)/(RAMA*FAMA)*DCXB + & - (RAX*FAX*AMPCT)/(RAMA*FAMA)*DAX - else - FAMA = zero - DAMA = zero - endif - else - FAMA = zero - DAMA = zero - RAMA = zero - endif - else upper_level - AMPCT = zero - AMCLPCT = zero - CLNEWPCT = zero - CLNEWAMPCT = zero - CLOLDPCT = zero - CLOLDAMPCT = zero - endif upper_level - else has_rls - RNEW = zero - QTEVAPCXA = QTTOPCA - QTEVAPAX = QTTOPAA - if( L > 1 ) then - if( RLS(LM1) > zero ) then - CFXX(LM1) = max( CFMIN,CFR(LM1) ) -! if( CFR(LM1) >= CFMIN ) then -! CFXX(LM1) = CFR(LM1) -! else -! CFXX(LM1) = CFMIN -! endif - else - CFXX(LM1) = CFR(LM1) - endif - endif - AMPCT = zero - AMCLPCT = zero - CLNEWPCT = zero - CLNEWAMPCT = zero - CLOLDPCT = zero - CLOLDAMPCT = zero - RCA = zero - RAMA = zero - FCA = zero - FAMA = zero - DCA = zero - DAMA = zero - endif has_rls - - if( do_diag .and. is_hno3 ) then - fama_wrk(l) = fama - rama_wrk(l) = rama - endif -!----------------------------------------------------------------------- -! Net loss can not exceed QTT in each region -!----------------------------------------------------------------------- - QTNETLCXA = QTRAINCXA + QTRIMECXA + QTWASHCXA - QTEVAPCXA - QTNETLCXA = min( QTT(L)*FCXA,QTNETLCXA ) - - QTNETLCXB =QTRAINCXB - QTNETLCXB = min( QTT(L)*FCXB,QTNETLCXB ) - - QTNETLAX = QTWASHAX - QTEVAPAX - QTNETLAX = min( QTT(L)*FAX,QTNETLAX ) - - QTTNEW(L) = QTT(L) - (QTNETLCXA + QTNETLCXB + QTNETLAX) - - if( do_diag .and. is_hno3 ) then - qt_rain(l) = qtraincxa + qtraincxb - qt_rime(l) = qtrimecxa - qt_wash(l) = qtwashcxa + qtwashax - qt_evap(l) = qtevapcxa + qtevapax - frc(l,1) = qtnetlcxa - frc(l,2) = qtnetlcxb - frc(l,3) = qtnetlax - endif - if( debug .and. is_hno3 .and. l == kdiag ) then - write(*,*) ' ' - write(*,*) 'washout: qtraincxa, qtraincxb, qtrimecxa @ level = ',l - write(*,'(1p,3g15.7)') qtraincxa, qtraincxb, qtrimecxa - write(*,*) ' ' - endif - if ( debug ) then - if( (l == 3 .or. l == 2) ) then - write(*,*) 'washout: hno3, hno3, qtnetlca,b, qtnetlax @ level = ',l - write(*,'(1p,5g15.7)') qttnew(l), qtt(l), qtnetlcxa, qtnetlcxb, qtnetlax - write(*,*) 'washout: qtwashax, qtevapax,fax,fama' - write(*,'(1p,5g15.7)') qtwashax, qtevapax, fax, fama - endif - endif - - QTTOPCAX = (QTTOPCA + QTNETLCXA)*CLOLDPCT + QTNETLCXB*CLNEWPCT + (QTTOPAA + QTNETLAX)*AMCLPCT - QTTOPAAX = (QTTOPCA + QTNETLCXA)*CLOLDAMPCT + QTNETLCXB*CLNEWAMPCT + (QTTOPAA + QTNETLAX)*AMPCT - QTTOPCA = QTTOPCAX - QTTOPAA = QTTOPAAX - end do level_loop - - if ( debug ) then - if( is_hno3 ) then - write(*,*) ' ' - write(*,*) 'washout: clwx_wrk' - write(*,'(1p,5g15.7)') clwx_wrk(1:le) - write(*,*) 'washout: cfr' - write(*,'(1p,5g15.7)') cfr(1:le) - write(*,*) 'washout: cfxx' - write(*,'(1p,5g15.7)') cfxx(1:le) - write(*,*) 'washout: cf trigger' - write(*,'(10l4)') cf_trigger(1:le) - write(*,*) 'washout: evaprate' - write(*,'(1p,5g15.7)') evaprate(1:le) - write(*,*) 'washout: rls' - write(*,'(1p,5g15.7)') rls(1:le) - write(*,*) 'washout: rls/garea' - write(*,'(1p,5g15.7)') rls_wrk(1:le) - write(*,*) 'washout: rnew_wrk' - write(*,'(1p,5g15.7)') rnew_wrk(1:le) - write(*,*) 'washout: rnew_flag' - write(*,'(10l4)') rnew_flag(1:le) - write(*,*) 'washout: deltarime_wrk' - write(*,'(1p,5g15.7)') deltarime_wrk(1:le) - write(*,*) 'washout: rama_wrk' - write(*,'(1p,5g15.7)') rama_wrk(1:le) - write(*,*) 'washout: fama_wrk' - write(*,'(1p,5g15.7)') fama_wrk(1:le) - write(*,*) 'washout: rca_wrk' - write(*,'(1p,5g15.7)') rca_wrk(1:le) - write(*,*) 'washout: fca_wrk' - write(*,'(1p,5g15.7)') fca_wrk(1:le) - write(*,*) 'washout: rcxa_wrk' - write(*,'(1p,5g15.7)') rcxa_wrk(1:le) - write(*,*) 'washout: fcxa_wrk' - write(*,'(1p,5g15.7)') fcxa_wrk(1:le) - write(*,*) 'washout: rcxb_wrk' - write(*,'(1p,5g15.7)') rcxb_wrk(1:le) - write(*,*) 'washout: fcxb_wrk' - write(*,'(1p,5g15.7)') fcxb_wrk(1:le) - write(*,*) 'washout: rax1_wrk' - write(*,'(1p,5g15.7)') rax_wrk(1:le,1) - write(*,*) 'washout: fax1_wrk' - write(*,'(1p,5g15.7)') fax_wrk(1:le,1) - write(*,*) 'washout: rax2_wrk' - write(*,'(1p,5g15.7)') rax_wrk(1:le,2) - write(*,*) 'washout: fax2_wrk' - write(*,'(1p,5g15.7)') fax_wrk(1:le,2) - write(*,*) 'washout: rls_flag' - write(*,'(1p,10l4)') rls_flag(1:le) - write(*,*) 'washout: freezing' - write(*,'(1p,10l4)') freezing(1:le) - write(*,*) 'washout: qtnetlcxa' - write(*,'(1p,5g15.7)') frc(1:le,1) - write(*,*) 'washout: qtnetlcxb' - write(*,'(1p,5g15.7)') frc(1:le,2) - write(*,*) 'washout: qtnetlax' - write(*,'(1p,5g15.7)') frc(1:le,3) - write(*,*) ' ' - endif - endif -!----------------------------------------------------------------------- -! reload new tracer mass and rescale moments: check upper limits (LE) -!----------------------------------------------------------------------- - QTTJFL(:le,N) = QTTNEW(:le) - - end do species_loop -! - return - end subroutine washo -!--------------------------------------------------------------------- - subroutine DISGAS (CLWX,CFX,MOLMASS,HSTAR,TM,PR,QM,QT,QTDIS) -!--------------------------------------------------------------------- - implicit none - real(r8), intent(in) :: CLWX,CFX !cloud water,cloud fraction - real(r8), intent(in) :: MOLMASS !molecular mass of tracer - real(r8), intent(in) :: HSTAR !Henry's Law coeffs A*exp(-B/T) - real(r8), intent(in) :: TM !temperature of box (K) - real(r8), intent(in) :: PR !pressure of box (hPa) - real(r8), intent(in) :: QM !air mass in box (kg) - real(r8), intent(in) :: QT !tracer in box (kg) - real(r8), intent(out) :: QTDIS !tracer dissolved in aqueous phase - - real(r8) MUEMP - real(r8), parameter :: INV298 = 1._r8/298._r8 - real(r8), parameter :: TMIX=258._r8 - real(r8), parameter :: RETEFF=0.5_r8 -!---Next calculate rate of uptake of tracer - -!---effective Henry's Law constant: H* = moles-T / liter-precip / press(atm-T) -!---p(atm of tracer-T) = (QT/QM) * (.029/MolWt-T) * pressr(hPa)/1000 -!---limit temperature effects to T above freezing -!----MU from fit to Kaercher and Voigt (2006) - - if(TM .ge. TICE) then - QTDIS=(HSTAR*(QT/(QM*CFX))*0.029_r8*(PR/1.0e3_r8))*(CLWX*QM) - elseif (TM .le. TMIX) then - MUEMP=exp(-14.2252_r8+(1.55704e-1_r8*TM)-(7.1929e-4_r8*(TM**2.0_r8))) - QTDIS=MUEMP*(MOLMASS/18._r8)*(CLWX*QM) - else - QTDIS=RETEFF*((HSTAR*(QT/(QM*CFX))*0.029_r8*(PR/1.0e3_r8))*(CLWX*QM)) - endif - - return - end subroutine DISGAS - -!----------------------------------------------------------------------- - subroutine RAINGAS (RRAIN,DTSCAV,CLWX,CFX,QM,QT,QTDIS,QTRAIN) -!----------------------------------------------------------------------- -!---New trace-gas rainout from large-scale precip with two time scales, -!---one based on precip formation from cloud water and one based on -!---Henry's Law solubility: correct limit for delta-t -!--- -!---NB this code does not consider the aqueous dissociation (eg, C-q) -!--- that makes uptake of HNO3 and H2SO4 so complete. To do so would -!--- require that we keep track of the pH of the falling rain. -!---THUS the Henry's Law coefficient KHA needs to be enhanced to incldue this! -!---ALSO the possible formation of other soluble species from, eg, CH2O, H2O2 -!--- can be considered with enhanced values of KHA. -!--- -!---Does NOT now use RMC (moist conv rain) but could, assuming 30% coverage -!----------------------------------------------------------------------- - implicit none - real(r8), intent(in) :: RRAIN !new rain formation in box (kg/s) - real(r8), intent(in) :: DTSCAV !time step (s) - real(r8), intent(in) :: CLWX,CFX !cloud water and cloud fraction - real(r8), intent(in) :: QM !air mass in box (kg) - real(r8), intent(in) :: QT !tracer in box (kg) - real(r8), intent(in) :: QTDIS !tracer in aqueous phase (kg) - real(r8), intent(out) :: QTRAIN !tracer picked up by new rain - - real(r8) QTLF,QTDISSTAR - - - - - - QTDISSTAR=(QTDIS*(QT*CFX))/(QTDIS+(QT*CFX)) - -!---Tracer Loss frequency (1/s) within cloud fraction: - QTLF = (RRAIN*QTDISSTAR)/(CLWX*QM*QT*CFX) - -!---in time = DTSCAV, the amount of QTT scavenged is calculated -!---from CF*AMOUNT OF UPTAKE - QTRAIN = QT*CFX*(1._r8 - exp(-DTSCAV*QTLF)) - - return - end subroutine RAINGAS - - -!----------------------------------------------------------------------- - subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & - QT,QTWASH,QTEVAP) -!----------------------------------------------------------------------- -!---for most gases below-cloud washout assume Henry-Law equilib with precip -!---assumes that precip is liquid, if frozen, do not call this sub -!---since solubility is moderate, fraction of box with rain does not matter -!---NB this code does not consider the aqueous dissociation (eg, C-q) -!--- that makes uptake of HNO3 and H2SO4 so complete. To do so would -!--- require that we keep track of the pH of the falling rain. -!---THUS the Henry's Law coefficient KHA needs to be enhanced to incldue this! -!---ALSO the possible formation of other soluble species from, eg, CH2O, H2O2 -!--- can be considered with enhanced values of KHA. -!----------------------------------------------------------------------- - implicit none - real(r8), intent(in) :: RWASH ! precip leaving bottom of box (kg/s) - real(r8), intent(in) :: BOXF ! fraction of box with washout - real(r8), intent(in) :: DTSCAV ! time step (s) - real(r8), intent(in) :: QTRTOP ! tracer-T in rain entering top of box -! over time step (kg) - real(r8), intent(in) :: HSTAR ! Henry's Law coeffs A*exp(-B/T) - real(r8), intent(in) :: TM ! temperature of box (K) - real(r8), intent(in) :: PR ! pressure of box (hPa) - real(r8), intent(in) :: QT ! tracer in box (kg) - real(r8), intent(in) :: QM ! air mass in box (kg) - real(r8), intent(out) :: QTWASH ! tracer picked up by precip (kg) - real(r8), intent(out) :: QTEVAP ! tracer evaporated from precip (kg) - - real(r8), parameter :: INV298 = 1._r8/298._r8 - real(r8) :: FWASH, QTMAX, QTDIF - -!---effective Henry's Law constant: H* = moles-T / liter-precip / press(atm-T) -!---p(atm of tracer-T) = (QT/QM) * (.029/MolWt-T) * pressr(hPa)/1000 -!---limit temperature effects to T above freezing - -! -! jfl -! -! added test for BOXF = 0. -! - if ( BOXF == 0._r8 ) then - QTWASH = 0._r8 - QTEVAP = 0._r8 - return - end if - -!---effective washout frequency (1/s): - FWASH = (RWASH*HSTAR*29.e-6_r8*PR)/(QM*BOXF) -!---equilib amount of T (kg) in rain thru bottom of box over time step - QTMAX = QT*FWASH*DTSCAV - if (QTMAX .gt. QTRTOP) then -!---more of tracer T can go into rain - QTDIF = min (QT, QTMAX-QTRTOP) - QTWASH = QTDIF * (1._r8 - exp(-DTSCAV*FWASH)) - QTEVAP=0._r8 - else -!--too much of T in rain, must degas/evap T - QTWASH = 0._r8 - QTEVAP = QTRTOP - QTMAX - endif - - return - end subroutine WASHGAS - -!----------------------------------------------------------------------- - function DEMPIRICAL (CWATER,RRATE) -!----------------------------------------------------------------------- - use shr_spfn_mod, only: shr_spfn_gamma - - implicit none - real(r8), intent(in) :: CWATER - real(r8), intent(in) :: RRATE - - real(r8) :: DEMPIRICAL - - real(r8) RRATEX,WX,THETA,PHI,ETA,BETA,ALPHA,BEE - real(r8) GAMTHETA,GAMBETA - - - - RRATEX=RRATE*3600._r8 !mm/hr - WX=CWATER*1.0e3_r8 !g/m3 - - if(RRATEX .gt. 0.04_r8) then - THETA=exp(-1.43_r8*dlog10(7._r8*RRATEX))+2.8_r8 - else - THETA=5._r8 - endif - PHI=RRATEX/(3600._r8*10._r8) !cgs units - ETA=exp((3.01_r8*THETA)-10.5_r8) - BETA=THETA/(1._r8+0.638_r8) - ALPHA=exp(4._r8*(BETA-3.5_r8)) - BEE=(.638_r8*THETA/(1._r8+.638_r8))-1.0_r8 - GAMTHETA = shr_spfn_gamma(THETA) - GAMBETA = shr_spfn_gamma(BETA+1._r8) - DEMPIRICAL=(((WX*ETA*GAMTHETA)/(1.0e6_r8*ALPHA*PHI*GAMBETA))** & - (-1._r8/BEE))*10._r8 ! in mm (wx/1e6 for cgs) - - - return - end function DEMPIRICAL -! -end module mo_neu_wetdep diff --git a/src/physics/cam_oslo/mo_srf_emissions.F90 b/src/physics/cam_oslo/mo_srf_emissions.F90 deleted file mode 100644 index 53fcb4218b..0000000000 --- a/src/physics/cam_oslo/mo_srf_emissions.F90 +++ /dev/null @@ -1,463 +0,0 @@ -module mo_srf_emissions - !--------------------------------------------------------------- - ! ... surface emissions module - !--------------------------------------------------------------- - - use shr_kind_mod, only : r8 => shr_kind_r8 - use chem_mods, only : gas_pcnst - use spmd_utils, only : masterproc,iam - use mo_tracname, only : solsym - use cam_abortutils,only : endrun - use ioFileMod, only : getfil - use ppgrid, only : pcols, begchunk, endchunk - use cam_logfile, only : iulog - use tracer_data, only : trfld,trfile - use oslo_ocean_intr, only: oslo_dms_inq - - implicit none - - type :: emission - integer :: spc_ndx - real(r8) :: mw - real(r8) :: scalefactor - character(len=256):: filename - character(len=16) :: species - character(len=8) :: units - integer :: nsectors - character(len=32),pointer :: sectors(:) - type(trfld), pointer :: fields(:) - type(trfile) :: file - end type emission - - private - - public :: srf_emissions_inti, set_srf_emissions, set_srf_emissions_time - - save - - real(r8), parameter :: amufac = 1.65979e-23_r8 ! 1.e4* kg / amu - logical :: has_emis(gas_pcnst) - type(emission), allocatable :: emissions(:) - integer :: n_emis_files - integer :: c10h16_ndx, isop_ndx - integer :: dms_ndx - -contains - - subroutine srf_emissions_inti( srf_emis_specifier, emis_type_in, emis_cycle_yr, emis_fixed_ymd, emis_fixed_tod ) - - !----------------------------------------------------------------------- - ! ... initialize the surface emissions - !----------------------------------------------------------------------- - - use chem_mods, only : adv_mass - use mo_constants, only : d2r, pi, rearth - use string_utils, only : to_upper - use mo_chem_utls, only : get_spc_ndx - use tracer_data, only : trcdata_init - use cam_pio_utils, only : cam_pio_openfile - use pio, only : pio_inquire, pio_nowrite, pio_closefile, pio_inq_varndims - use pio, only : pio_inq_varname, file_desc_t, pio_get_att, PIO_NOERR, PIO_GLOBAL - use pio, only : pio_seterrorhandling, PIO_BCAST_ERROR,PIO_INTERNAL_ERROR - use chem_surfvals, only : flbc_list - use string_utils, only : GLC - use m_MergeSorts, only : IndexSort - - implicit none - - !----------------------------------------------------------------------- - ! ... dummy arguments - !----------------------------------------------------------------------- - character(len=*), intent(in) :: srf_emis_specifier(:) - character(len=*), intent(in) :: emis_type_in - integer, intent(in) :: emis_cycle_yr - integer, intent(in) :: emis_fixed_ymd - integer, intent(in) :: emis_fixed_tod - - !----------------------------------------------------------------------- - ! ... local variables - !----------------------------------------------------------------------- - integer :: astat - integer :: j, l, m, n, i, nn ! Indices - character(len=16) :: spc_name - character(len=256) :: filename - - character(len=16) :: emis_species(gas_pcnst) - character(len=256) :: emis_filenam(gas_pcnst) - integer :: emis_indexes(gas_pcnst) - integer :: indx(gas_pcnst) - real(r8) :: emis_scalefactor(gas_pcnst) - - integer :: vid, nvars, isec - integer, allocatable :: vndims(:) - type(file_desc_t) :: ncid - character(len=32) :: varname - character(len=256) :: locfn - integer :: ierr - character(len=1), parameter :: filelist = '' - character(len=1), parameter :: datapath = '' - logical , parameter :: rmv_file = .false. - - character(len=32) :: emis_type = ' ' - character(len=80) :: file_interp_type = ' ' - character(len=256) :: tmp_string = ' ' - character(len=32) :: xchr = ' ' - real(r8) :: xdbl - - has_emis(:) = .false. - nn = 0 - indx(:) = 0 - - count_emis: do n=1,gas_pcnst - if ( len_trim(srf_emis_specifier(n) ) == 0 ) then - exit count_emis - endif - - i = scan(srf_emis_specifier(n),'->') - spc_name = trim(adjustl(srf_emis_specifier(n)(:i-1))) - - ! need to parse out scalefactor ... - tmp_string = adjustl(srf_emis_specifier(n)(i+2:)) - j = scan( tmp_string, '*' ) - if (j>0) then - xchr = tmp_string(1:j-1) ! get the multipler (left of the '*') - read( xchr, * ) xdbl ! convert the string to a real - tmp_string = adjustl(tmp_string(j+1:)) ! get the filepath name (right of the '*') - else - xdbl = 1._r8 - endif - filename = trim(tmp_string) - - m = get_spc_ndx(spc_name) - - if (m > 0) then - has_emis(m) = .true. - else - write(iulog,*) 'srf_emis_inti: spc_name ',spc_name,' is not included in the simulation' - call endrun('srf_emis_inti: invalid surface emission specification') - endif - - if (any( flbc_list == spc_name )) then - call endrun('srf_emis_inti: ERROR -- cannot specify both fixed LBC ' & - //'and emissions for the same species: '//trim(spc_name)) - endif - - nn = nn+1 - emis_species(nn) = spc_name - emis_filenam(nn) = filename - emis_indexes(nn) = m - emis_scalefactor(nn) = xdbl - - indx(n)=n - - enddo count_emis - - n_emis_files = nn - - if (masterproc) write(iulog,*) 'srf_emis_inti: n_emis_files = ',n_emis_files - - allocate( emissions(n_emis_files), stat=astat ) - if( astat/= 0 ) then - write(iulog,*) 'srf_emis_inti: failed to allocate emissions array; error = ',astat - call endrun('srf_emis_inti: failed to allocate emissions array') - end if - - !----------------------------------------------------------------------- - ! Sort the input files so that the emissions sources are summed in the - ! same order regardless of the order of the input files in the namelist - !----------------------------------------------------------------------- - if (n_emis_files > 0) then - call IndexSort(n_emis_files, indx, emis_filenam) - end if - - !----------------------------------------------------------------------- - ! ... setup the emission type array - !----------------------------------------------------------------------- - do m=1,n_emis_files - emissions(m)%spc_ndx = emis_indexes(indx(m)) - emissions(m)%units = 'Tg/y' - emissions(m)%species = emis_species(indx(m)) - emissions(m)%mw = adv_mass(emis_indexes(indx(m))) ! g / mole - emissions(m)%filename = emis_filenam(indx(m)) - emissions(m)%scalefactor = emis_scalefactor(indx(m)) - enddo - - !----------------------------------------------------------------------- - ! read emis files to determine number of sectors - !----------------------------------------------------------------------- - spc_loop: do m = 1, n_emis_files - - emissions(m)%nsectors = 0 - - call getfil (emissions(m)%filename, locfn, 0) - call cam_pio_openfile ( ncid, trim(locfn), PIO_NOWRITE) - ierr = pio_inquire (ncid, nvariables=nvars) - - allocate(vndims(nvars)) - - do vid = 1,nvars - - ierr = pio_inq_varndims (ncid, vid, vndims(vid)) - - if( vndims(vid) < 3 ) then - cycle - elseif( vndims(vid) > 3 ) then - ierr = pio_inq_varname (ncid, vid, varname) - write(iulog,*) 'srf_emis_inti: Skipping variable ', trim(varname),', ndims = ',vndims(vid), & - ' , species=',trim(emissions(m)%species) - cycle - end if - - emissions(m)%nsectors = emissions(m)%nsectors+1 - - enddo - - allocate( emissions(m)%sectors(emissions(m)%nsectors), stat=astat ) - if( astat/= 0 ) then - write(iulog,*) 'srf_emis_inti: failed to allocate emissions(m)%sectors array; error = ',astat - call endrun - end if - - isec = 1 - - do vid = 1,nvars - if( vndims(vid) == 3 ) then - ierr = pio_inq_varname(ncid, vid, emissions(m)%sectors(isec)) - isec = isec+1 - endif - - enddo - deallocate(vndims) - - ! Global attribute 'input_method' overrides the srf_emis_type namelist setting on - ! a file-by-file basis. If the emis file does not contain the 'input_method' - ! attribute then the srf_emis_type namelist setting is used. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ierr = pio_get_att(ncid, PIO_GLOBAL, 'input_method', file_interp_type) - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - if ( ierr == PIO_NOERR) then - l = GLC(file_interp_type) - emis_type(1:l) = file_interp_type(1:l) - emis_type(l+1:) = ' ' - else - emis_type = trim(emis_type_in) - endif - - call pio_closefile (ncid) - - allocate(emissions(m)%file%in_pbuf(size(emissions(m)%sectors))) - emissions(m)%file%in_pbuf(:) = .false. - - call trcdata_init( emissions(m)%sectors, & - emissions(m)%filename, filelist, datapath, & - emissions(m)%fields, & - emissions(m)%file, & - rmv_file, emis_cycle_yr, emis_fixed_ymd, emis_fixed_tod, trim(emis_type) ) - - enddo spc_loop - - c10h16_ndx = get_spc_ndx('C10H16') - isop_ndx = get_spc_ndx('ISOP') - - dms_ndx = get_spc_ndx('DMS') - - end subroutine srf_emissions_inti - - subroutine set_srf_emissions_time( pbuf2d, state ) - !----------------------------------------------------------------------- - ! ... check serial case for time span - !----------------------------------------------------------------------- - - use physics_types,only : physics_state - use ppgrid, only : begchunk, endchunk - use tracer_data, only : advance_trcdata - use physics_buffer, only : physics_buffer_desc - - implicit none - - type(physics_state), intent(in):: state(begchunk:endchunk) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - !----------------------------------------------------------------------- - ! ... local variables - !----------------------------------------------------------------------- - integer :: m - - do m = 1,n_emis_files - call advance_trcdata( emissions(m)%fields, emissions(m)%file, state, pbuf2d ) - end do - - end subroutine set_srf_emissions_time - - ! adds surf flux specified in file to sflx - subroutine set_srf_emissions( lchnk, ncol, sflx ) - !-------------------------------------------------------- - ! ... form the surface fluxes for this latitude slice - !-------------------------------------------------------- - - use mo_constants, only : pi - use time_manager, only : get_curr_calday - use string_utils, only : to_lower, GLC - use phys_grid, only : get_rlat_all_p, get_rlon_all_p - - implicit none - - !-------------------------------------------------------- - ! ... Dummy arguments - !-------------------------------------------------------- - integer, intent(in) :: ncol ! columns in chunk - integer, intent(in) :: lchnk ! chunk index - real(r8), intent(out) :: sflx(:,:) ! surface emissions ( kg/m^2/s ) - - !-------------------------------------------------------- - ! ... local variables - !-------------------------------------------------------- - integer :: i, m, n - real(r8) :: factor - real(r8) :: dayfrac ! fration of day in light - real(r8) :: iso_off ! time iso flux turns off - real(r8) :: iso_on ! time iso flux turns on - - logical :: polar_day,polar_night - real(r8) :: doy_loc - real(r8) :: sunon,sunoff - real(r8) :: loc_angle - real(r8) :: latitude - real(r8) :: declination - real(r8) :: tod - real(r8) :: calday - - real(r8), parameter :: dayspy = 365._r8 - real(r8), parameter :: twopi = 2.0_r8 * pi - real(r8), parameter :: pid2 = 0.5_r8 * pi - real(r8), parameter :: dec_max = 23.45_r8 * pi/180._r8 - - real(r8) :: flux(ncol) - real(r8) :: mfactor - integer :: isec - - character(len=12),parameter :: mks_units(4) = (/ "kg/m2/s ", & - "kg/m2/sec ", & - "kg/m^2/s ", & - "kg/m^2/sec " /) - character(len=12) :: units - - real(r8), dimension(ncol) :: rlats, rlons - - sflx(:,:) = 0._r8 - - !-------------------------------------------------------- - ! ... set non-zero emissions - !-------------------------------------------------------- - emis_loop : do m = 1,n_emis_files - - n = emissions(m)%spc_ndx - - flux(:) = 0._r8 - do isec = 1,emissions(m)%nsectors - flux(:ncol) = flux(:ncol) + emissions(m)%scalefactor*emissions(m)%fields(isec)%data(:ncol,1,lchnk) - enddo - - units = to_lower(trim(emissions(m)%fields(1)%units(:GLC(emissions(m)%fields(1)%units)))) - - if ( any( mks_units(:) == units ) ) then - sflx(:ncol,n) = sflx(:ncol,n) + flux(:ncol) - else - mfactor = amufac * emissions(m)%mw - sflx(:ncol,n) = sflx(:ncol,n) + flux(:ncol) * mfactor - endif - - end do emis_loop - - call get_rlat_all_p( lchnk, ncol, rlats ) - call get_rlon_all_p( lchnk, ncol, rlons ) - - calday = get_curr_calday() - doy_loc = aint( calday ) - declination = dec_max * cos((doy_loc - 172._r8)*twopi/dayspy) - tod = (calday - doy_loc) + .5_r8 - - !Remove DMS emissions if option is not "from file" - !Online emissions are treated in seasalt module - if(oslo_dms_inq() .eqv. .FALSE.)then !Returns "True" if "emissions from file" - if(dms_ndx .gt. 0)then - sflx(:,dms_ndx) = 0.0_r8 - end if - end if - - do i = 1,ncol - ! - polar_day = .false. - polar_night = .false. - ! - loc_angle = tod * twopi + rlons(i) - loc_angle = mod( loc_angle,twopi ) - latitude = rlats(i) - ! - !------------------------------------------------------------------ - ! determine if in polar day or night - ! if not in polar day or night then - ! calculate terminator longitudes - !------------------------------------------------------------------ - if( abs(latitude) >= (pid2 - abs(declination)) ) then - if( sign(1._r8,declination) == sign(1._r8,latitude) ) then - polar_day = .true. - sunoff = 2._r8*twopi - sunon = -twopi - else - polar_night = .true. - end if - else - sunoff = acos( -tan(declination)*tan(latitude) ) - sunon = twopi - sunoff - end if - - !-------------------------------------------------------- - ! ... adjust alpha-pinene for diurnal variation - !-------------------------------------------------------- - if( c10h16_ndx > 0 ) then - if( has_emis(c10h16_ndx) ) then - if( .not. polar_night .and. .not. polar_day ) then - dayfrac = sunoff / pi - sflx(i,c10h16_ndx) = sflx(i,c10h16_ndx) / (.7_r8 + .3_r8*dayfrac) - if( loc_angle >= sunoff .and. loc_angle <= sunon ) then - sflx(i,c10h16_ndx) = sflx(i,c10h16_ndx) * .7_r8 - endif - end if - end if - end if - - !-------------------------------------------------------- - ! ... adjust isoprene for diurnal variation - !-------------------------------------------------------- - if( isop_ndx > 0 ) then - if( has_emis(isop_ndx) ) then - if( .not. polar_night ) then - if( polar_day ) then - iso_off = .8_r8 * pi - iso_on = 1.2_r8 * pi - else - iso_off = .8_r8 * sunoff - iso_on = 2._r8 * pi - iso_off - end if - if( loc_angle >= iso_off .and. loc_angle <= iso_on ) then - sflx(i,isop_ndx) = 0._r8 - else - factor = loc_angle - iso_on - if( factor <= 0._r8 ) then - factor = factor + 2._r8*pi - end if - factor = factor / (2._r8*iso_off + 1.e-6_r8) - sflx(i,isop_ndx) = sflx(i,isop_ndx) * 2._r8 / iso_off * pi * (sin(pi*factor))**2 - end if - else - sflx(i,isop_ndx) = 0._r8 - end if - end if - end if - - end do - - end subroutine set_srf_emissions - -end module mo_srf_emissions From 60d24beff9e6e3686080352b4b8c25e835018146 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 1 Sep 2023 16:50:47 +0200 Subject: [PATCH 38/71] put calcaersize into aero_model --- src/chemistry/oslo_aero/aero_model.F90 | 170 +++++++++++++++++++++- src/chemistry/oslo_aero/calcaersize.F90 | 179 ------------------------ 2 files changed, 169 insertions(+), 180 deletions(-) delete mode 100644 src/chemistry/oslo_aero/calcaersize.F90 diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index a2ebbf6d97..37cb1b6080 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -50,7 +50,6 @@ module aero_model use commondefinitions, only: originalSigma, originalNumberMedianRadius use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes use const, only: numberToSurface - use calcaersize #ifdef AEROCOM use aerocom_opt_mod, only: initaeropt use aerocom_dry_mod, only: initdryp @@ -787,4 +786,173 @@ subroutine aero_model_constants() end subroutine aero_model_constants + + subroutine calcaersize_sub( ncol, t, h2ommr, pmid, pdel,wetnumberMedianDiameter,wetrho, & + wetNumberMedianDiameter_processmode, wetrho_processmode) + + ! Seland Calculates mean volume size and hygroscopic growth for use in dry deposition + + use shr_kind_mod, only: r8 => shr_kind_r8 + use constituents, only : pcnst + use ppgrid + use wv_saturation, only: qsat_water + use commondefinitions, only: nmodes + use aerosoldef + use physconst, only: rhoh2o + + integer, intent(in) :: ncol ! number of columns + real(r8), intent(in) :: t(pcols,pver) ! layer temperatures (K) + real(r8), intent(in) :: h2ommr(pcols,pver) ! layer specific humidity + real(r8), intent(in) :: pmid(pcols,pver) ! layer pressure (Pa) + real(r8), intent(in) :: pdel(pcols,pver) ! layer pressure thickness (Pa) + + real(r8), intent(out):: wetNumberMedianDiameter(pcols,pver,0:nmodes) + real(r8), intent(out):: wetrho(pcols,pver,0:nmodes) ! wet aerosol density + real(r8), intent(out) :: wetNumberMedianDiameter_processmode(pcols,pver,numberOfProcessModeTracers) + real(r8), intent(out) :: wetrho_processmode(pcols,pver,numberOfProcessModeTracers) + + ! local variables + real(r8) :: relhum(pcols,pver) ! Relative humidity + integer :: i,k,m,irelh,mm, tracerCounter + integer ::l ! species index + real(r8) :: xrh(pcols,pver) + real(r8) :: qs(pcols,pver) ! saturation specific humidity + real(r8) :: rmeanvol ! Mean radius with respect to volume + integer :: irh1(pcols,pver),irh2(pcols,pver) + integer :: t_irh1,t_irh2 + real(r8) :: t_rh1,t_rh2,t_xrh,rr1,rr2 + real(r8) :: volumeFractionAerosol !with respect to total (aerosol + water) + real(r8) :: tmp1, tmp2 + real(r8) :: wetrad_tmp(max_tracers_per_mode) + real(r8) :: dry_rhopart_tmp(max_tracers_per_mode) + real(r8) :: mixed_dry_rho + + + !Get the tabulated rh in all grid cells + do k=1,pver + do i=1,ncol + call qsat_water(t(i,k),pmid(i,k), tmp1, qs(i,k), tmp2) + xrh(i,k) = h2ommr(i,k)/qs(i,k) + !cak + ! if(xrh(i,k).lt.0.0_r8.or.xrh(i,k).gt.1.0_r8) then + ! write(*,*) 'i,k,rh calcaer=',i,k,xrh(i,k) + ! endif + !cak + xrh(i,k) = max(xrh(i,k),0.0_r8) + xrh(i,k) = min(xrh(i,k),1.0_r8) + relhum(i,k)=xrh(i,k) + xrh(i,k)=min(xrh(i,k),rhtab(10)) + end do + end do + + !Find the relh-index in all grid-points + do irelh=1,SIZE(rhtab) - 1 + do k=1,pver + do i=1,ncol + if(xrh(i,k).ge.rhtab(irelh).and. & + xrh(i,k).le.rhtab(irelh+1)) then + irh1(i,k)=irelh !lower index + irh2(i,k)=irelh+1 !higher index + end if + end do + end do + end do + + do k=1,pver + do i=1,ncol + + !Get the indexes out as floating point single numbers + t_irh1 = irh1(i,k) + t_irh2 = irh2(i,k) + t_rh1 = rhtab(t_irh1) + t_rh2 = rhtab(t_irh2) + t_xrh = xrh(i,k) + + do m = 0, nmodes + !Do some weighting to mass mean property + !weighting by 1.5 is number median ==> volumetric mean + !http://dust.ess.uci.edu/facts/psd/psd.pdf + rmeanvol = lifeCycleNumberMedianRadius(m)*DEXP(1.5_r8*(log(lifeCycleSigma(m)))**2) + wetNumberMedianDiameter(i,k,m ) = 0.1e-6_r8 !Initialize to something.. + mixed_dry_rho = 1.e3_r8 + + tracerCounter = 0 + do l = 1,getNumberOfBackgroundTracersInMode(m) + + tracerCounter = tracerCounter + 1 + + !which tracer is this? + mm = getTracerIndex(m,l,.false.) + + !radius of lower rh-bin for this tracer + rr1=rdivr0(t_irh1,mm) + + !radius of upper rh-bin for this tracer + rr2=rdivr0(t_irh2,mm) + + !linear interpolate dry ==> wet radius for this tracer + wetrad_tmp(tracerCounter) = (((t_rh2-t_xrh)*rr1+(t_xrh-t_rh1)*rr2)/ & + (t_rh2-t_rh1))*rmeanvol + + !mixed density of dry particle + dry_rhopart_tmp(tracerCounter) = getDryDensity(m,l) + + end do + + !Find the average growth of this mode + !(still not taking into account how much we have!!) + if(TracerCounter .gt. 0)then + + !Convert to diameter and take average (note: This is MASS median diameter) + wetNumberMedianDiameter(i,k,m) = 2.0_r8 * SUM(wetrad_tmp(1:tracerCounter))/dble(tracerCounter) + + !Take average density + mixed_dry_rho = SUM(dry_rhopart_tmp(1:tracerCounter))/dble(tracerCounter) + + !At this point the radius is in "mass mean" space + volumeFractionAerosol = MIN(1.0_r8, ( 2.0_r8*rmeanVol / wetNumberMedianDiameter(i,k,m) )**3) + + !wet density + wetrho(i,k,m) = mixed_dry_rho * volumeFractionAerosol & + + (1._r8-volumeFractionAerosol)*rhoh2o + + !convert back to number median diameter (wet) + wetNumberMedianDiameter(i,k,m) = wetNumberMedianDiameter(i,k,m)*DEXP(-1.5_r8*(log(lifeCycleSigma(m)))**2) + endif + + + end do !modes + + !Same thing for the process modes + do l=1,numberOfProcessModeTracers + + mm = tracerInProcessMode(l) !process mode tracer (physics space) + + !weighting by 1.5 is number median ==> volumetric mean + !http://dust.ess.uci.edu/facts/psd/psd.pdf + rmeanvol = processModeNumberMedianRadius(l)*DEXP(1.5_r8*(log(processModeSigma(l)))**2) + + !radius of lower rh-bin for this tracer + rr1=rdivr0(t_irh1,mm) + + !radius of upper rh-bin for this tracer + rr2=rdivr0(t_irh2,mm) + + !Note this is MASS median diameter + wetNumberMedianDiameter_processmode(i,k,l) = (((t_rh2-t_xrh)*rr1+(t_xrh-t_rh1)*rr2)/ & + (t_rh2-t_rh1))*rmeanvol*2.0_r8 + + volumeFractionAerosol = MIN(1.0, (2.0_r8*rmeanVol/wetnumberMedianDiameter_processmode(i,k,l))**3) + + wetrho_processmode(i,k,l) = volumeFractionAerosol*rhopart(mm) & + + (1.0_r8 - volumeFractionAerosol)*rhoh2o + + !convert back to number median diameter (wet) + wetNumberMedianDiameter_processMode(i,k,l) = wetNumberMedianDiameter_processMode(i,k,l)*DEXP(-1.5_r8*(log(processModeSigma(l)))**2) + end do !process modes + end do !horizontal points + end do !layers + + end subroutine calcaersize_sub + end module aero_model diff --git a/src/chemistry/oslo_aero/calcaersize.F90 b/src/chemistry/oslo_aero/calcaersize.F90 deleted file mode 100644 index cbc65878c6..0000000000 --- a/src/chemistry/oslo_aero/calcaersize.F90 +++ /dev/null @@ -1,179 +0,0 @@ -module calcaersize - -contains - -! � Seland Calculates mean volume size and hygroscopic growth for use in -! dry deposition - subroutine calcaersize_sub( ncol, & - t, h2ommr, pmid, pdel,wetnumberMedianDiameter,wetrho & - , wetNumberMedianDiameter_processmode, wetrho_processmode) - - - use constituents, only : pcnst - use shr_kind_mod,only: r8 => shr_kind_r8 - use ppgrid - use wv_saturation, only: qsat_water - use commondefinitions, only: nmodes - use aerosoldef - use physconst, only: rhoh2o - - implicit none - - integer, intent(in) :: ncol ! number of columns - real(r8), intent(in) :: t(pcols,pver) ! layer temperatures (K) - real(r8), intent(in) :: h2ommr(pcols,pver) ! layer specific humidity - real(r8), intent(in) :: pmid(pcols,pver) ! layer pressure (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! layer pressure thickness (Pa) - - real(r8), intent(out):: wetNumberMedianDiameter(pcols,pver,0:nmodes) - real(r8), intent(out):: wetrho(pcols,pver,0:nmodes) ! wet aerosol density - real(r8), intent(out) :: wetNumberMedianDiameter_processmode(pcols,pver,numberOfProcessModeTracers) - real(r8), intent(out) :: wetrho_processmode(pcols,pver,numberOfProcessModeTracers) - -! local variables - real(r8) :: relhum(pcols,pver) ! Relative humidity - integer :: i,k,m,irelh,mm, tracerCounter - integer ::l ! species index - real(r8) :: xrh(pcols,pver) - real(r8) :: qs(pcols,pver) ! saturation specific humidity - real(r8) :: rmeanvol ! Mean radius with respect to volume - integer :: irh1(pcols,pver),irh2(pcols,pver) - integer :: t_irh1,t_irh2 - real(r8) :: t_rh1,t_rh2,t_xrh,rr1,rr2 - real(r8) :: volumeFractionAerosol !with respect to total (aerosol + water) - real(r8) :: tmp1, tmp2 - real(r8) :: wetrad_tmp(max_tracers_per_mode) - real(r8) :: dry_rhopart_tmp(max_tracers_per_mode) - real(r8) :: mixed_dry_rho - - - !Get the tabulated rh in all grid cells - do k=1,pver - do i=1,ncol - call qsat_water(t(i,k),pmid(i,k), tmp1, qs(i,k), tmp2) - xrh(i,k) = h2ommr(i,k)/qs(i,k) -!cak -! if(xrh(i,k).lt.0.0_r8.or.xrh(i,k).gt.1.0_r8) then -! write(*,*) 'i,k,rh calcaer=',i,k,xrh(i,k) -! endif -!cak - xrh(i,k) = max(xrh(i,k),0.0_r8) - xrh(i,k) = min(xrh(i,k),1.0_r8) - relhum(i,k)=xrh(i,k) - xrh(i,k)=min(xrh(i,k),rhtab(10)) - end do - end do - - !Find the relh-index in all grid-points - do irelh=1,SIZE(rhtab) - 1 - do k=1,pver - do i=1,ncol - if(xrh(i,k).ge.rhtab(irelh).and. & - xrh(i,k).le.rhtab(irelh+1)) then - irh1(i,k)=irelh !lower index - irh2(i,k)=irelh+1 !higher index - end if - end do - end do - end do - - do k=1,pver - do i=1,ncol - - !Get the indexes out as floating point single numbers - t_irh1 = irh1(i,k) - t_irh2 = irh2(i,k) - t_rh1 = rhtab(t_irh1) - t_rh2 = rhtab(t_irh2) - t_xrh = xrh(i,k) - - do m = 0, nmodes - !Do some weighting to mass mean property - !weighting by 1.5 is number median ==> volumetric mean - !http://dust.ess.uci.edu/facts/psd/psd.pdf - rmeanvol = lifeCycleNumberMedianRadius(m)*DEXP(1.5_r8*(log(lifeCycleSigma(m)))**2) - wetNumberMedianDiameter(i,k,m ) = 0.1e-6_r8 !Initialize to something.. - mixed_dry_rho = 1.e3_r8 - - tracerCounter = 0 - do l = 1,getNumberOfBackgroundTracersInMode(m) - - tracerCounter = tracerCounter + 1 - - !which tracer is this? - mm = getTracerIndex(m,l,.false.) - - !radius of lower rh-bin for this tracer - rr1=rdivr0(t_irh1,mm) - - !radius of upper rh-bin for this tracer - rr2=rdivr0(t_irh2,mm) - - !linear interpolate dry ==> wet radius for this tracer - wetrad_tmp(tracerCounter) = (((t_rh2-t_xrh)*rr1+(t_xrh-t_rh1)*rr2)/ & - (t_rh2-t_rh1))*rmeanvol - - !mixed density of dry particle - dry_rhopart_tmp(tracerCounter) = getDryDensity(m,l) - - end do - - !Find the average growth of this mode - !(still not taking into account how much we have!!) - if(TracerCounter .gt. 0)then - - !Convert to diameter and take average (note: This is MASS median diameter) - wetNumberMedianDiameter(i,k,m) = 2.0_r8 * SUM(wetrad_tmp(1:tracerCounter))/dble(tracerCounter) - - !Take average density - mixed_dry_rho = SUM(dry_rhopart_tmp(1:tracerCounter))/dble(tracerCounter) - - !At this point the radius is in "mass mean" space - volumeFractionAerosol = MIN(1.0_r8, ( 2.0_r8*rmeanVol / wetNumberMedianDiameter(i,k,m) )**3) - - !wet density - wetrho(i,k,m) = mixed_dry_rho * volumeFractionAerosol & - + (1._r8-volumeFractionAerosol)*rhoh2o - - !convert back to number median diameter (wet) - wetNumberMedianDiameter(i,k,m) = wetNumberMedianDiameter(i,k,m)*DEXP(-1.5_r8*(log(lifeCycleSigma(m)))**2) - endif - - - end do !modes - - !Same thing for the process modes - do l=1,numberOfProcessModeTracers - - mm = tracerInProcessMode(l) !process mode tracer (physics space) - - !weighting by 1.5 is number median ==> volumetric mean - !http://dust.ess.uci.edu/facts/psd/psd.pdf - rmeanvol = processModeNumberMedianRadius(l)*DEXP(1.5_r8*(log(processModeSigma(l)))**2) - - !radius of lower rh-bin for this tracer - rr1=rdivr0(t_irh1,mm) - - !radius of upper rh-bin for this tracer - rr2=rdivr0(t_irh2,mm) - - !Note this is MASS median diameter - wetNumberMedianDiameter_processmode(i,k,l) = (((t_rh2-t_xrh)*rr1+(t_xrh-t_rh1)*rr2)/ & - (t_rh2-t_rh1))*rmeanvol*2.0_r8 - - volumeFractionAerosol = MIN(1.0, (2.0_r8*rmeanVol/wetnumberMedianDiameter_processmode(i,k,l))**3) - - wetrho_processmode(i,k,l) = volumeFractionAerosol*rhopart(mm) & - + (1.0_r8 - volumeFractionAerosol)*rhoh2o - - !convert back to number median diameter (wet) - wetNumberMedianDiameter_processMode(i,k,l) = wetNumberMedianDiameter_processMode(i,k,l)*DEXP(-1.5_r8*(log(processModeSigma(l)))**2) - end do !process modes - end do !horizontal points - end do !layers - - return - end subroutine calcaersize_sub -end module - - From e1eaeb12e342d7882030a1dbff1f05964ed5985d Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Fri, 1 Sep 2023 17:11:49 +0200 Subject: [PATCH 39/71] more cleanup of aero_model --- src/chemistry/oslo_aero/aero_model.F90 | 13 ++----------- 1 file changed, 2 insertions(+), 11 deletions(-) diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 37cb1b6080..06ae34403d 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -26,6 +26,7 @@ module aero_model use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx use ref_pres, only: top_lev => clim_modal_aero_top_lev + use wv_saturation, only: qsat_water ! use oslo_aero_depos, only: oslo_aero_depos_init use oslo_aero_depos, only: oslo_aero_depos_dry, oslo_aero_depos_wet, oslo_aero_wetdep_init @@ -792,13 +793,8 @@ subroutine calcaersize_sub( ncol, t, h2ommr, pmid, pdel,wetnumberMedianDiameter, ! Seland Calculates mean volume size and hygroscopic growth for use in dry deposition - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only : pcnst - use ppgrid - use wv_saturation, only: qsat_water use commondefinitions, only: nmodes use aerosoldef - use physconst, only: rhoh2o integer, intent(in) :: ncol ! number of columns real(r8), intent(in) :: t(pcols,pver) ! layer temperatures (K) @@ -814,7 +810,7 @@ subroutine calcaersize_sub( ncol, t, h2ommr, pmid, pdel,wetnumberMedianDiameter, ! local variables real(r8) :: relhum(pcols,pver) ! Relative humidity integer :: i,k,m,irelh,mm, tracerCounter - integer ::l ! species index + integer :: l ! species index real(r8) :: xrh(pcols,pver) real(r8) :: qs(pcols,pver) ! saturation specific humidity real(r8) :: rmeanvol ! Mean radius with respect to volume @@ -833,11 +829,6 @@ subroutine calcaersize_sub( ncol, t, h2ommr, pmid, pdel,wetnumberMedianDiameter, do i=1,ncol call qsat_water(t(i,k),pmid(i,k), tmp1, qs(i,k), tmp2) xrh(i,k) = h2ommr(i,k)/qs(i,k) - !cak - ! if(xrh(i,k).lt.0.0_r8.or.xrh(i,k).gt.1.0_r8) then - ! write(*,*) 'i,k,rh calcaer=',i,k,xrh(i,k) - ! endif - !cak xrh(i,k) = max(xrh(i,k),0.0_r8) xrh(i,k) = min(xrh(i,k),1.0_r8) relhum(i,k)=xrh(i,k) From 31c8bbbb54d5b6eaf5fdf0dfe056dc5753a5bd96 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 2 Sep 2023 18:29:06 +0200 Subject: [PATCH 40/71] renamed and refactored interpolation routines --- src/chemistry/oslo_aero/aero_model.F90 | 2 - src/chemistry/oslo_aero/aerocom_dry_mod.F90 | 15 +- src/chemistry/oslo_aero/aerocom_opt_mod.F90 | 15 +- src/chemistry/oslo_aero/lininterpol_mod.F90 | 141 ------ src/chemistry/oslo_aero/oslo_aero_conc.F90 | 415 +++++++++--------- .../oslo_aero/oslo_aero_linear_interp.F90 | 134 ++++++ .../{intlog.F90 => oslo_aero_logn_tables.F90} | 245 +++++------ .../oslo_aero/oslo_aero_sw_tables.F90 | 13 +- 8 files changed, 476 insertions(+), 504 deletions(-) delete mode 100644 src/chemistry/oslo_aero/lininterpol_mod.F90 create mode 100644 src/chemistry/oslo_aero/oslo_aero_linear_interp.F90 rename src/chemistry/oslo_aero/{intlog.F90 => oslo_aero_logn_tables.F90} (76%) diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 06ae34403d..9bc96dbdad 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -37,7 +37,6 @@ module aero_model use oslo_aero_utils, only: calculateNumberConcentration use oslo_aero_condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4 use oslo_aero_condtend, only: registerCondensation, initializeCondensation, condtend - use oslo_aero_interp_log, only: initlogn use oslo_aero_seasalt, only: oslo_aero_seasalt_init, oslo_aero_seasalt_emis, seasalt_active use oslo_aero_dust, only: oslo_aero_dust_init, oslo_aero_dust_emis, dust_active use oslo_aero_ocean, only: oslo_aero_ocean_init, oslo_aero_dms_emis @@ -159,7 +158,6 @@ subroutine aero_model_init( pbuf2d ) call aero_model_constants call initopt - call initlogn call initopt_lw call initializeCondensation() call oslo_aero_ocean_init() diff --git a/src/chemistry/oslo_aero/aerocom_dry_mod.F90 b/src/chemistry/oslo_aero/aerocom_dry_mod.F90 index 68c4095ed5..983164ce0b 100644 --- a/src/chemistry/oslo_aero/aerocom_dry_mod.F90 +++ b/src/chemistry/oslo_aero/aerocom_dry_mod.F90 @@ -2,13 +2,14 @@ module aerocom_dry_mod #ifdef AEROCOM - use shr_kind_mod , only: r8 => shr_kind_r8 - use ppgrid , only: pcols, pver - use commondefinitions , only: nmodes, nbmodes - use oslo_aero_sw_tables, only: cate, cat, fac, faq, fbc, fombg, fbcbg, nbmp1 - use lininterpol_mod , only: lininterpol3dim, lininterpol4dim, lininterpol5dim - use oslo_control , only: oslo_getopts, dir_string_length - use cam_logfile , only: iulog + use shr_kind_mod , only: r8 => shr_kind_r8 + use ppgrid , only: pcols, pver + use cam_logfile , only: iulog + ! + use commondefinitions , only: nmodes, nbmodes + use oslo_aero_sw_tables , only: cate, cat, fac, faq, fbc, fombg, fbcbg, nbmp1 + use oslo_aero_linear_interp , only: lininterpol3dim, lininterpol4dim, lininterpol5dim + use oslo_control , only: oslo_getopts, dir_string_length implicit none private diff --git a/src/chemistry/oslo_aero/aerocom_opt_mod.F90 b/src/chemistry/oslo_aero/aerocom_opt_mod.F90 index e17cf34394..db3bdb46bc 100644 --- a/src/chemistry/oslo_aero/aerocom_opt_mod.F90 +++ b/src/chemistry/oslo_aero/aerocom_opt_mod.F90 @@ -2,13 +2,14 @@ module aerocom_opt_mod #ifdef AEROCOM - use shr_kind_mod , only : r8 => shr_kind_r8 - use ppgrid , only : pcols, pver - use commondefinitions , only : nmodes, nbmodes - use oslo_aero_sw_tables , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg - use oslo_control , only : oslo_getopts, dir_string_length - use cam_logfile , only : iulog - use lininterpol_mod , only : lininterpol3dim, lininterpol4dim, lininterpol5dim + use shr_kind_mod , only : r8 => shr_kind_r8 + use ppgrid , only : pcols, pver + use cam_logfile , only : iulog + ! + use commondefinitions , only : nmodes, nbmodes + use oslo_aero_sw_tables , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg + use oslo_control , only : oslo_getopts, dir_string_length + use oslo_aero_linear_interp , only : lininterpol3dim, lininterpol4dim, lininterpol5dim implicit none private diff --git a/src/chemistry/oslo_aero/lininterpol_mod.F90 b/src/chemistry/oslo_aero/lininterpol_mod.F90 deleted file mode 100644 index a0d02c1058..0000000000 --- a/src/chemistry/oslo_aero/lininterpol_mod.F90 +++ /dev/null @@ -1,141 +0,0 @@ -module lininterpol_mod - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - - public :: lininterpol3dim - public :: lininterpol4dim - public :: lininterpol5dim - -! ========================================================== -contains -! ========================================================== - - subroutine lininterpol3dim (d2mx, dxm1, invd, opt3d, optout1, optout2) - - ! Input arguments - real(r8), intent(in) :: opt3d(2,2,2) - real(r8), intent(in) :: d2mx(3) - real(r8), intent(in) :: dxm1(3) - real(r8), intent(in) :: invd(3) - ! - ! Output arguments - real(r8), intent(out) :: optout1 - real(r8), intent(out) :: optout2 - ! - ! Local variables - real(r8) opt2d(2,2) - !------------------------------------ - - ! interpolation in the third dimension (except invd(3) factor) - opt2d(1,1)=d2mx(3)*opt3d(1,1,1)+dxm1(3)*opt3d(1,1,2) - opt2d(1,2)=d2mx(3)*opt3d(1,2,1)+dxm1(3)*opt3d(1,2,2) - opt2d(2,1)=d2mx(3)*opt3d(2,1,1)+dxm1(3)*opt3d(2,1,2) - opt2d(2,2)=d2mx(3)*opt3d(2,2,1)+dxm1(3)*opt3d(2,2,2) - - ! interpolation in the (third and) second dimension - optout1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(3)*invd(2) - optout2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(3)*invd(2) - - end subroutine lininterpol3dim - - ! ========================================================== - subroutine lininterpol4dim (d2mx, dxm1, invd, opt4d, optout1, optout2) - - ! Input arguments - real(r8), intent(in) :: opt4d(2,2,2,2) - real(r8), intent(in) :: d2mx(4) - real(r8), intent(in) :: dxm1(4) - real(r8), intent(in) :: invd(4) - ! - ! Output arguments - real(r8), intent(out) :: optout1 - real(r8), intent(out) :: optout2 - ! - ! Local variables - real(r8) opt3d(2,2,2), opt2d(2,2) - !------------------------------------ - - ! interpolation in the fourth dimension (except invd(4) factor) - opt3d(1,1,1)=d2mx(4)*opt4d(1,1,1,1)+dxm1(4)*opt4d(1,1,1,2) - opt3d(1,1,2)=d2mx(4)*opt4d(1,1,2,1)+dxm1(4)*opt4d(1,1,2,2) - opt3d(1,2,1)=d2mx(4)*opt4d(1,2,1,1)+dxm1(4)*opt4d(1,2,1,2) - opt3d(1,2,2)=d2mx(4)*opt4d(1,2,2,1)+dxm1(4)*opt4d(1,2,2,2) - opt3d(2,1,1)=d2mx(4)*opt4d(2,1,1,1)+dxm1(4)*opt4d(2,1,1,2) - opt3d(2,1,2)=d2mx(4)*opt4d(2,1,2,1)+dxm1(4)*opt4d(2,1,2,2) - opt3d(2,2,1)=d2mx(4)*opt4d(2,2,1,1)+dxm1(4)*opt4d(2,2,1,2) - opt3d(2,2,2)=d2mx(4)*opt4d(2,2,2,1)+dxm1(4)*opt4d(2,2,2,2) - - ! interpolation in the third dimension (except invd(3) factor) - opt2d(1,1)=d2mx(3)*opt3d(1,1,1)+dxm1(3)*opt3d(1,1,2) - opt2d(1,2)=d2mx(3)*opt3d(1,2,1)+dxm1(3)*opt3d(1,2,2) - opt2d(2,1)=d2mx(3)*opt3d(2,1,1)+dxm1(3)*opt3d(2,1,2) - opt2d(2,2)=d2mx(3)*opt3d(2,2,1)+dxm1(3)*opt3d(2,2,2) - - ! interpolation in the (fourth, third and) second dimension - optout1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(4)*invd(3)*invd(2) - optout2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(4)*invd(3)*invd(2) - - end subroutine lininterpol4dim - - ! ========================================================== - subroutine lininterpol5dim (d2mx, dxm1, invd, opt5d, optout1, optout2) - - ! - ! Input arguments - real(r8), intent(in) :: opt5d(2,2,2,2,2) - real(r8), intent(in) :: d2mx(5) - real(r8), intent(in) :: dxm1(5) - real(r8), intent(in) :: invd(5) - ! - ! Output arguments - real(r8), intent(out) :: optout1 - real(r8), intent(out) :: optout2 - ! - ! Local variables - real(r8) opt4d(2,2,2,2), opt3d(2,2,2), opt2d(2,2) - !------------------------------------ - - ! interpolation in the fifth dimension (except invd(5) factor) - opt4d(1,1,1,1)=d2mx(5)*opt5d(1,1,1,1,1)+dxm1(5)*opt5d(1,1,1,1,2) - opt4d(1,1,1,2)=d2mx(5)*opt5d(1,1,1,2,1)+dxm1(5)*opt5d(1,1,1,2,2) - opt4d(1,1,2,1)=d2mx(5)*opt5d(1,1,2,1,1)+dxm1(5)*opt5d(1,1,2,1,2) - opt4d(1,1,2,2)=d2mx(5)*opt5d(1,1,2,2,1)+dxm1(5)*opt5d(1,1,2,2,2) - opt4d(1,2,1,1)=d2mx(5)*opt5d(1,2,1,1,1)+dxm1(5)*opt5d(1,2,1,1,2) - opt4d(1,2,1,2)=d2mx(5)*opt5d(1,2,1,2,1)+dxm1(5)*opt5d(1,2,1,2,2) - opt4d(1,2,2,1)=d2mx(5)*opt5d(1,2,2,1,1)+dxm1(5)*opt5d(1,2,2,1,2) - opt4d(1,2,2,2)=d2mx(5)*opt5d(1,2,2,2,1)+dxm1(5)*opt5d(1,2,2,2,2) - opt4d(2,1,1,1)=d2mx(5)*opt5d(2,1,1,1,1)+dxm1(5)*opt5d(2,1,1,1,2) - opt4d(2,1,1,2)=d2mx(5)*opt5d(2,1,1,2,1)+dxm1(5)*opt5d(2,1,1,2,2) - opt4d(2,1,2,1)=d2mx(5)*opt5d(2,1,2,1,1)+dxm1(5)*opt5d(2,1,2,1,2) - opt4d(2,1,2,2)=d2mx(5)*opt5d(2,1,2,2,1)+dxm1(5)*opt5d(2,1,2,2,2) - opt4d(2,2,1,1)=d2mx(5)*opt5d(2,2,1,1,1)+dxm1(5)*opt5d(2,2,1,1,2) - opt4d(2,2,1,2)=d2mx(5)*opt5d(2,2,1,2,1)+dxm1(5)*opt5d(2,2,1,2,2) - opt4d(2,2,2,1)=d2mx(5)*opt5d(2,2,2,1,1)+dxm1(5)*opt5d(2,2,2,1,2) - opt4d(2,2,2,2)=d2mx(5)*opt5d(2,2,2,2,1)+dxm1(5)*opt5d(2,2,2,2,2) - - ! interpolation in the fourth dimension (except invd(4) factor) - opt3d(1,1,1)=d2mx(4)*opt4d(1,1,1,1)+dxm1(4)*opt4d(1,1,1,2) - opt3d(1,1,2)=d2mx(4)*opt4d(1,1,2,1)+dxm1(4)*opt4d(1,1,2,2) - opt3d(1,2,1)=d2mx(4)*opt4d(1,2,1,1)+dxm1(4)*opt4d(1,2,1,2) - opt3d(1,2,2)=d2mx(4)*opt4d(1,2,2,1)+dxm1(4)*opt4d(1,2,2,2) - opt3d(2,1,1)=d2mx(4)*opt4d(2,1,1,1)+dxm1(4)*opt4d(2,1,1,2) - opt3d(2,1,2)=d2mx(4)*opt4d(2,1,2,1)+dxm1(4)*opt4d(2,1,2,2) - opt3d(2,2,1)=d2mx(4)*opt4d(2,2,1,1)+dxm1(4)*opt4d(2,2,1,2) - opt3d(2,2,2)=d2mx(4)*opt4d(2,2,2,1)+dxm1(4)*opt4d(2,2,2,2) - - ! interpolation in the third dimension (except invd(3) factor) - opt2d(1,1)=d2mx(3)*opt3d(1,1,1)+dxm1(3)*opt3d(1,1,2) - opt2d(1,2)=d2mx(3)*opt3d(1,2,1)+dxm1(3)*opt3d(1,2,2) - opt2d(2,1)=d2mx(3)*opt3d(2,1,1)+dxm1(3)*opt3d(2,1,2) - opt2d(2,2)=d2mx(3)*opt3d(2,2,1)+dxm1(3)*opt3d(2,2,2) - - ! interpolation in the (fifth, fourth, third and) second dimension - optout1=(d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*(invd(5)*invd(4)*invd(3)*invd(2)) - optout2=(d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*(invd(5)*invd(4)*invd(3)*invd(2)) - - end subroutine lininterpol5dim - -end module lininterpol_mod diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 index b2420b4260..e46f8a9536 100644 --- a/src/chemistry/oslo_aero/oslo_aero_conc.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_conc.F90 @@ -1,15 +1,17 @@ module oslo_aero_conc - use shr_kind_mod , only: r8 => shr_kind_r8 - use ppgrid , only: pcols, pver - use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o, pi - use constituents , only: pcnst, cnst_name + ! Calculate concentrations of aerosol modes based on lifecycle species + + use shr_kind_mod , only: r8 => shr_kind_r8 + use ppgrid , only: pcols, pver + use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o, pi + use constituents , only: pcnst, cnst_name ! - use oslo_aero_interp_log, only: intlog1to3_sub, intlog4_sub, intlog5to10_sub - use oslo_aero_utils, only: calculateNumberConcentration - use oslo_aero_coag, only: normalizedCoagulationSink - use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV - use const, only: smallNumber, volumeToNumber,smallNumber + use oslo_aero_logn_tables, only: intlog1to3_sub, intlog4_sub, intlog5to10_sub, initlogn + use oslo_aero_utils, only: calculateNumberConcentration + use oslo_aero_coag, only: normalizedCoagulationSink + use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV + use const, only: smallNumber, volumeToNumber,smallNumber use commondefinitions use aerosoldef @@ -34,6 +36,8 @@ module oslo_aero_conc real(r8), parameter :: aThird = 1.0_r8/3.0_r8 real(r8), parameter :: ln10 = log(10.0_r8) + logical :: init_logn_tables = .false. + contains !******************************************************************************************** @@ -221,36 +225,34 @@ subroutine calculateHygroscopicity(ncol, mmr, numberConcentration, rho_air, Cam, ! http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract ! Abdul-Razzak and S. Ghan: - !INPUT - integer, intent(in) :: ncol - real(r8), intent(in) :: mmr(pcols,pver,pcnst) !I [kg/kg] mass mixing ratios - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes)!I [#/m3] number concentrations - real(r8), intent(in) :: rho_air(pcols,pver) !I [kg/m3] air density - real(r8), intent(in) :: Cam(pcols, pver, nbmodes) !I [kg/m3] total added mass during microphysics - real(r8), intent(in) :: f_acm(pcols,pver,nbmodes) !I [-] fraction of added mass which is carbon - real(r8), intent(in) :: f_aqm(pcols,pver,nbmodes) !I [-] fraction of sulfate which is aq. phase - real(r8), intent(in) :: f_bcm(pcols,pver,nbmodes) !I [-] fraction of C which is bc - logical, intent(in) :: hasAerosol(pcols,pver,nmodes) !I [t/f] do we have aerosols - - !OUTPUT - real(r8), intent(out) :: hygroscopicity(pcols,pver,nmodes) - real(r8), intent(out) :: volumeConcentration(pcols,pver,nmodes) + ! arguments + integer , intent(in) :: ncol + real(r8) , intent(in) :: mmr(pcols,pver,pcnst) ! [kg/kg] mass mixing ratios + real(r8) , intent(in) :: numberConcentration(pcols,pver,0:nmodes) ! [#/m3] number concentrations + real(r8) , intent(in) :: rho_air(pcols,pver) ! [kg/m3] air density + real(r8) , intent(in) :: Cam(pcols, pver, nbmodes) ! [kg/m3] total added mass during microphysics + real(r8) , intent(in) :: f_acm(pcols,pver,nbmodes) ! [-] fraction of added mass which is carbon + real(r8) , intent(in) :: f_aqm(pcols,pver,nbmodes) ! [-] fraction of sulfate which is aq. phase + real(r8) , intent(in) :: f_bcm(pcols,pver,nbmodes) ! [-] fraction of C which is bc + logical , intent(in) :: hasAerosol(pcols,pver,nmodes) ! [t/f] do we have aerosols + real(r8) , intent(out) :: hygroscopicity(pcols,pver,nmodes) + real(r8) , intent(out) :: volumeConcentration(pcols,pver,nmodes) + real(r8) , intent(out) :: volumeCore(pcols,pver,nmodes) ![m3] + real(r8) , intent(out) :: volumeCoat(pcols,pver,nmodes) ![m3] - !Local variables - real(r8) :: hygroscopicityAvg(pcols,pver) - real(r8) :: hygroscopicityCoat(pcols,pver) - real(r8) :: massConcentrationTracerInMode(pcols,pver) - real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) ![m3] - real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) ![m3] - real(r8) :: averageRadiusCore(pcols,pver) ![m] - real(r8) :: averageRadiusTotal(pcols,pver) ![m] - integer :: kcomp !counter for modes - integer :: l !counter for components - integer :: tracerIndex - integer :: k !counter for levels - integer :: i - - !initialize + ! local variables + integer :: kcomp !counter for modes + integer :: l !counter for components + integer :: k !counter for levels + integer :: tracerIndex + integer :: i + real(r8) :: hygroscopicityAvg(pcols,pver) + real(r8) :: hygroscopicityCoat(pcols,pver) + real(r8) :: massConcentrationTracerInMode(pcols,pver) + real(r8) :: averageRadiusCore(pcols,pver) ![m] + real(r8) :: averageRadiusTotal(pcols,pver) ![m] + + ! initialize hygroscopicity(:,:,:) = 0.0_r8 volumeConcentration(:,:,:)=0.0_r8 @@ -279,81 +281,60 @@ subroutine calculateHygroscopicity(ncol, mmr, numberConcentration, rho_air, Cam, massConcentrationTracerInMode(:ncol,k) = mmr(:ncol,k,tracerIndex)*rho_air(:ncol,k) end do - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , tracerIndex & - ) + ! hasAerosol is true if any concentration in this point + call addModeHygroscopicity( ncol, hasAerosol(:,:,kcomp), & + massConcentrationTracerInMode, volumeCore(:,:,kcomp), volumeCoat(:,:,kcomp), & + hygroscopicityAvg, hygroscopicityCoat, tracerIndex) + end do !background tracers in mode (l) !The background modes can have tracer mass added to them - if(kcomp .le. nbmodes)then + if (kcomp .le. nbmodes)then - !added aquous sulfate + ! added aquous sulfate if(isTracerInMode(kcomp,l_so4_a2))then do k=1,pver massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*f_aqm(:ncol,k,kcomp) end do - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , l_so4_a2 & - ) - endif + ! hasAerosol is true if any concentration in this point + call addModeHygroscopicity( ncol, hasAerosol(:,:,kcomp), & + massConcentrationTracerInMode, volumeCore(:,:,kcomp), volumeCoat(:,:,kcomp), & + hygroscopicityAvg, hygroscopicityCoat, l_so4_a2) - !added condensate/coagulate - !All modes which have coagulate have also condensate, so it is - !ok to check for condensate and add the combined mass.. - if(isTracerInMode(kcomp,l_so4_a1))then + endif + ! added condensate/coagulate + ! All modes which have coagulate have also condensate, so it is + ! ok to check for condensate and add the combined mass.. + if (isTracerInMode(kcomp,l_so4_a1))then do k=1,pver massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*(1.0_r8 - f_aqm(:ncol,k,kcomp)) end do - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , l_so4_a1 & - ) + call addModeHygroscopicity(ncol, hasAerosol(:,:,kcomp), & + massConcentrationTracerInMode, volumeCore(:,:,kcomp), volumeCoat(:,:,kcomp), & + hygroscopicityAvg, hygroscopicityCoat, l_so4_a1) + endif - !Added bc - if(isTracerInMode(kcomp,l_bc_ac))then + ! Added bc + if (isTracerInMode(kcomp,l_bc_ac))then do k=1,pver massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*f_bcm(:ncol,k,kcomp) end do - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , l_bc_ac & - ) + call addModeHygroscopicity( ncol, hasAerosol(:,:,kcomp), & + massConcentrationTracerInMode, volumeCore(:,:,kcomp), volumeCoat(:,:,kcomp), & + hygroscopicityAvg, hygroscopicityCoat, l_bc_ac ) endif - !Added oc (both POM and SOA), then both have the same - !properties, so add combined mass here. - !All modes which have condensate also has coagulate, so OK to check - !for condensate and distribute the sum.. - if(isTracerInMode(kcomp,l_soa_a1))then - + ! Added oc (both POM and SOA), then both have the same + ! properties, so add combined mass here. + ! All modes which have condensate also has coagulate, so OK to check + ! for condensate and distribute the sum.. + if (isTracerInMode(kcomp,l_soa_a1))then do k=1,pver massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*(1.0_r8 -f_bcm(:ncol,k,kcomp)) end do @@ -383,7 +364,7 @@ subroutine calculateHygroscopicity(ncol, mmr, numberConcentration, rho_air, Cam, !If there is enough soluble material, a coating will be formed: In that case, the !volume of the aerosol in question is only the volume of the coating! hygroscopicityCoat(:ncol,k) = molecularWeightWater*hygroscopicityCoat(:ncol,k) & - & /( density_water * volumeCoat(:ncol,k,kcomp)) !Note use of volume Coating here + /( density_water * volumeCoat(:ncol,k,kcomp)) !Note use of volume Coating here elsewhere hygroscopicityCoat(:ncol,k) = 1.e-30_r8 endwhere @@ -392,14 +373,16 @@ subroutine calculateHygroscopicity(ncol, mmr, numberConcentration, rho_air, Cam, !hygroscopicity of mixture (Note use of total volume to get average hygroscopicity) hygroscopicityAvg(:ncol,k) = molecularWeightWater*hygroscopicityAvg(:ncol,k) & - & /(density_water * volumeConcentration(:ncol,k,kcomp)) + /(density_water * volumeConcentration(:ncol,k,kcomp)) !Average size of insoluble core (average radius) - averageRadiusCore(:ncol,k) = 0.5_r8*( (volumeCore(:ncol,k,kcomp)) / numberConcentration(:ncol,k,kcomp) * (6.0_r8/pi))**athird + averageRadiusCore(:ncol,k) = 0.5_r8*( (volumeCore(:ncol,k,kcomp)) & + / numberConcentration(:ncol,k,kcomp) * (6.0_r8/pi))**athird !Average size of total aerosol (average radius) - averageRadiusTotal(:ncol,k) = 0.5_r8*((volumeConcentration(:ncol,k,kcomp)) / numberConcentration(:ncol,k,kcomp)*(6.0_r8/pi))**athird + averageRadiusTotal(:ncol,k) = 0.5_r8*((volumeConcentration(:ncol,k,kcomp)) & + / numberConcentration(:ncol,k,kcomp)*(6.0_r8/pi))**athird !do i=1,ncol ! if(numberConcentration(i,k,kcomp) .gt. 1.e6 .and. kcomp.eq.6 )then @@ -408,14 +391,17 @@ subroutine calculateHygroscopicity(ncol, mmr, numberConcentration, rho_air, Cam, ! endif !end do - !use one or the other hygroscopicity based on coating + ! use one or the other hygroscopicity based on coating where ( averageRadiusTotal(:ncol,k) - averageRadiusCore(:ncol,k) .gt. coatingLimit ) hygroscopicity(:ncol,k,kcomp) = hygroscopicityCoat(:ncol,k) elsewhere hygroscopicity(:ncol,k,kcomp) = hygroscopicityAvg(:ncol,k) endwhere + elsewhere ! No aerosol + hygroscopicity(:ncol,k,kcomp) = 1.e-10_r8 + end where end do !levels @@ -512,30 +498,28 @@ subroutine doLognormalInterpolation(ncol, numberConcentration, hasAerosol, & real(r8) , intent(out) :: lnsigma(pcols,pver,nmodes) ![-] log (base e) of std. dev ! local variables + integer :: kcomp + integer :: i,k real(r8) :: nconccm3(pcols,pver) real(r8) :: camUg(pcols,pver) - real(r8) :: log10sig(pcols,pver) ! [-] logarithm (base 10) of look up tables - real(r8) :: f_ocm(pcols,pver,4) ! [-] fraction of added mass which is either SOA condensate or OC coagulate - integer :: iloop - integer :: kcomp - integer :: i - integer :: k - real(r8), dimension(pcols,pver,nbmodes) :: cxs ![ug/m3] NOTE NON-SI UNITS non-allocated mass - integer , dimension(pcols) :: ind ![idx] index in mapping (not really used) - real(r8), dimension(pcols,pver) :: radius_tmp ![m] radius in look up tables - - - !total mass not allocated to any mode - !this is non-zero if the look-up table can not cope with all the add-on mass - !cxstot(:,:) = 0.0_r8 - - !Remove this later! - do i=1,ncol - ind(i)=i - end do - - ! calculate fraction of added mass which is either SOA condensate or OC coagulate, - ! which in AeroTab are both treated as condensate for kcomp=1-4 + real(r8) :: log10sig(pcols,pver) ! [-] logarithm (base 10) of look up tables + real(r8) :: f_ocm(pcols,pver,4) ! [-] fraction of added mass which is either SOA condensate or OC coagulate + real(r8) :: cxs(pcols,pver,nbmodes) ![ug/m3] NOTE NON-SI UNITS non-allocated mass + integer :: ind(pcols) ![idx] index in mapping (not really used) + real(r8) :: radius_tmp(pcols,pver) ![m] radius in look up tables + + ! Initialize logn tables for interpolation + if (.not. init_logn_tables) then + call initlogn() + init_logn_tables = .true. + end if + + ! total mass not allocated to any mode + ! this is non-zero if the look-up table can not cope with all the add-on mass + ! cxstot(:,:) = 0.0_r8 + + ! calculate fraction of added mass which is either SOA condensate or OC coagulate, + ! which in AeroTab are both treated as condensate for kcomp=1-4 do kcomp=1,4 do k=1,pver do i=1,ncol @@ -544,128 +528,127 @@ subroutine doLognormalInterpolation(ncol, numberConcentration, hasAerosol, & enddo enddo - do iloop=1,1 ! loop over i>1 for testing CPU use in intlog* - - !Go through all "background" size-modes (kcomp=1-10) - do kcomp=1,nbmodes + ! Go through all "background" size-modes (kcomp=1-10) + do kcomp=1,nbmodes - camUg(:,:) = cam(:,:,kcomp)*1.e9_r8 - nConccm3(:,:) = 1e-6_r8*numberConcentration(:,:,kcomp) + camUg(:,:) = cam(:,:,kcomp)*1.e9_r8 + nConccm3(:,:) = 1e-6_r8*numberConcentration(:,:,kcomp) - !Calculate growth from knowing added process specific internally mixed mass to each background mode - !(level sent but not needed, and kcomp not needed for intlog4_sub) + ! Calculate growth from knowing added process specific internally mixed mass to each background mode + ! (level sent but not needed, and kcomp not needed for intlog4_sub) - if( kcomp .ge. MODE_IDX_SO4SOA_AIT .and. kcomp .le. MODE_IDX_BC_AIT)then ! kcomp=1,2 + if ( kcomp .ge. MODE_IDX_SO4SOA_AIT .and. kcomp .le. MODE_IDX_BC_AIT) then ! kcomp=1,2 - do k=1,pver - call intlog1to3_sub( & - ncol & !I number of points - , ind & !I [idx] mappoing of points to use - , kcomp & !I [idx] mode index - , camUg(:,k) & !I [ug/m3] mass concentration - , nConccm3(:,k) & !I [#/cm3] number concentration - , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. - , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table - , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance - , radius_tmp(:,k) & !O [m] Number median radius - ) - - end do !loop on levels - - else if(kcomp .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT)then ! kcomp=4 + ! Remove this later? + do i=1,ncol + ind(i) = i + end do - do k=1,pver - call intlog4_sub( & - ncol & !I number of points - , ind & !I [idx] mappoing of points to use - , kcomp & !I [idx] mode index - , camUg(:,k) & !I [ug/m3] mass concentration - , nConccm3(:,k) & !I [#/cm3] number concentration - , f_ocm(:,k,kcomp) & !I [frc] mass fraction which is SOA cond. or OC coag. - , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous - , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table - , log10sig(:,k) & !O [-]sigma, is later thrown away begause of volume balance - , radius_tmp(:,k) & !O [m] Number median radius - ) - end do + do k=1,pver + call intlog1to3_sub( & + ncol, & !I number of points + ind, & !I [idx] mappoing of points to use + kcomp, & !I [idx] mode index + camUg(:,k), & !I [ug/m3] mass concentration + nConccm3(:,k), & !I [#/cm3] number concentration + f_ocm(:,k,kcomp), & !I [frc] mass fraction which is SOA cond. or OC coag. + cxs(:,k,kcomp), & !O [ug/m3] mass which did not fit the table + log10sig(:,k), & !O [-]sigma, is later thrown away begause of volume balance + radius_tmp(:,k) & !O [m] Number median radius + ) + end do !loop on levels - else if (kcomp .ge. MODE_IDX_SO4_AC .and. kcomp .le. MODE_IDX_SS_A3)then ! kcomp=5-10 + else if (kcomp .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) then ! kcomp=4 - do k=1,pver - call intlog5to10_sub( & - ncol & !I [nbr] number of points used - , ind & !I [mapping] (not used) - , kcomp & !I [mode index] - , camUg(:,k) & !I [ug/m3] mass concentration - , nConccm3(:,k) & !I [#/cm3] number concentration - , f_acm(:,k,kcomp) & !I [frc] fraction of aerosol which is carbon - , f_bcm(:,k,kcomp) & !I [frc] fraction of carbon which is bc - , f_aqm(:,k,kcomp) & !I [frc] fraction of sulfate which is aquous - , cxs(:,k,kcomp) & !O [ug/m3] mass which did not fit the table (not given to any mode) - , log10sig(:,k) & !O logarithm (base 10) sigma, is later thrown away begause of volume balance - , radius_tmp(:,k) & !O [m] Number median radius - ) - end do ! k + do k=1,pver + call intlog4_sub( & + ncol, & !I number of points + ind, & !I [idx] mappoing of points to use + kcomp, & !I [idx] mode index + camUg(:,k), & !I [ug/m3] mass concentration + nConccm3(:,k), & !I [#/cm3] number concentration + f_ocm(:,k,kcomp), & !I [frc] mass fraction which is SOA cond. or OC coag. + f_aqm(:,k,kcomp), & !I [frc] fraction of sulfate which is aquous + cxs(:,k,kcomp), & !O [ug/m3] mass which did not fit the table + log10sig(:,k), & !O [-]sigma, is later thrown away begause of volume balance + radius_tmp(:,k) & !O [m] Number median radius + ) + end do - endif + else if (kcomp .ge. MODE_IDX_SO4_AC .and. kcomp .le. MODE_IDX_SS_A3)then ! kcomp=5-10 - !initialize - lnsigma(:,:,kcomp) = log(2.0_r8) + do k=1,pver + call intlog5to10_sub( & + ncol, & !I [nbr] number of points used + ind, & !I [mapping] (not used) + kcomp, & !I [mode index] + camUg(:,k), & !I [ug/m3] mass concentration + nConccm3(:,k), & !I [#/cm3] number concentration + f_acm(:,k,kcomp), & !I [frc] fraction of aerosol which is carbon + f_bcm(:,k,kcomp), & !I [frc] fraction of carbon which is bc + f_aqm(:,k,kcomp), & !I [frc] fraction of sulfate which is aquous + cxs(:,k,kcomp), & !O [ug/m3] mass which did not fit the table (not given to any mode) + log10sig(:,k), & !O logarithm (base 10) sigma, is later thrown away begause of volume balance + radius_tmp(:,k) & !O [m] Number median radius + ) + end do ! k - !The whole point of the interpolation routines is to get the new sigma ==> so trust the sigma + endif - !This means that in order to conserve the volume (which is known), we have to throw away - !the number concentration. Should create a diagnostic or a warning if number concenration is very different - !from the original number concentration since in principal, the number concentration is - !also conserved! - do k=1,pver - !Don't change number concentration unless "hasAerosol" is true - where(hasAerosol(:ncol,k,kcomp)) + !initialize + lnsigma(:,:,kcomp) = log(2.0_r8) - lnsigma(:ncol,k,kcomp) = ln10*log10sig(:ncol,k) + !The whole point of the interpolation routines is to get the new sigma ==> so trust the sigma - numberConcentration(:ncol,k,kcomp) = volumeConcentration(:ncol,k,kcomp)*6.0_r8/pi & - /(2.0_r8*radius_tmp(:ncol,k))**3 & - *DEXP(-4.5_r8*lnsigma(:ncol,k,kcomp)*lnsigma(:ncol,k,kcomp)) + !This means that in order to conserve the volume (which is known), we have to throw away + !the number concentration. Should create a diagnostic or a warning if number concenration is very different + !from the original number concentration since in principal, the number concentration is + !also conserved! + do k=1,pver + !Don't change number concentration unless "hasAerosol" is true + where(hasAerosol(:ncol,k,kcomp)) - !==> Now we have a set of n, vol, sigma which is consistent and gives back whatever the - !lookup tables told us! If the look up tables were conserving volume we didn't have to do - !the step just above!! + lnsigma(:ncol,k,kcomp) = ln10*log10sig(:ncol,k) - !Sum up all mass which was not added to any mode (mass exceeding the max limit in the look-up tables) - !cxstot(:ncol,k) = cxstot(:ncol,k) + cxs(:ncol,k,kcomp)*1.e-9_r8 ! ug/m3 ==> kg/m3 + numberConcentration(:ncol,k,kcomp) = volumeConcentration(:ncol,k,kcomp)*6.0_r8/pi & + /(2.0_r8*radius_tmp(:ncol,k))**3 & + *DEXP(-4.5_r8*lnsigma(:ncol,k,kcomp)*lnsigma(:ncol,k,kcomp)) - end where - end do + !==> Now we have a set of n, vol, sigma which is consistent and gives back whatever the + !lookup tables told us! If the look up tables were conserving volume we didn't have to do + !the step just above!! - end do !kcomp + !Sum up all mass which was not added to any mode (mass exceeding the max limit in the look-up tables) + !cxstot(:ncol,k) = cxstot(:ncol,k) + cxs(:ncol,k,kcomp)*1.e-9_r8 ! ug/m3 ==> kg/m3 - !The modes which do not have any added aerosol: - do kcomp=nbmodes+1,nmodes - do k=1,pver - lnsigma(:ncol,k,kcomp) = log(originalSigma(kcomp)) - end do + end where end do - !AK (fxm): "unactivated" code below... - !Excessive internally mixed process mass added to the background modes (exceeding the max limit in the look-up tables) - !is instead added to / lumped with the externally mixed non-background modes (kcomp=11,12,14) - !numberConcentration(:,:,MODE_IDX_SO4_NUC) = numberConcentration(:,:,MODE_IDX_SO4_NUC) & - ! + (volumeToNumber(MODE_IDX_SO4_NUC) & !excess sulfate mass is moved to this mode - ! *RESHAPE(cxstot,(/pcols,pver/)) & - ! *(1.0_r8-f_c(:,:))/rhopart(l_so4_n)) + end do !kcomp - !numberConcentration(:,:,MODE_IDX_BC_NUC) = numberConcentration(:,:,MODE_IDX_BC_NUC) & - ! + (volumeToNumber(MODE_IDX_BC_NUC) & !excess carbon mass is moved to this mode - ! * RESHAPE(cxstot,(/pcols,pver/)) & - ! * f_c(:,:)/rhopart(l_bc_n)) + !The modes which do not have any added aerosol: + do kcomp=nbmodes+1,nmodes + do k=1,pver + lnsigma(:ncol,k,kcomp) = log(originalSigma(kcomp)) + end do + end do - !SKIP LUMPING OF OC-MODE TO MODE MODE_IDX_LUMPED ORGANICS SINCE THIS WILL MESS UP THE HASAEROSOL-MASK! - ! modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) = efact_omn & !excess OM mass is moved to this mode (originally kcomp=13) - ! * (modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) + cxstot(i)*modedefs(i)%f_c*(1.0_r8-modedefs(i)%f_bc)) + !AK (fxm): "unactivated" code below... + !Excessive internally mixed process mass added to the background modes (exceeding the max limit in the look-up tables) + !is instead added to / lumped with the externally mixed non-background modes (kcomp=11,12,14) + !numberConcentration(:,:,MODE_IDX_SO4_NUC) = numberConcentration(:,:,MODE_IDX_SO4_NUC) & + ! + (volumeToNumber(MODE_IDX_SO4_NUC) & !excess sulfate mass is moved to this mode + ! *RESHAPE(cxstot,(/pcols,pver/)) & + ! *(1.0_r8-f_c(:,:))/rhopart(l_so4_n)) + !numberConcentration(:,:,MODE_IDX_BC_NUC) = numberConcentration(:,:,MODE_IDX_BC_NUC) & + ! + (volumeToNumber(MODE_IDX_BC_NUC) & !excess carbon mass is moved to this mode + ! * RESHAPE(cxstot,(/pcols,pver/)) & + ! * f_c(:,:)/rhopart(l_bc_n)) - enddo ! iloop + !SKIP LUMPING OF OC-MODE TO MODE MODE_IDX_LUMPED ORGANICS SINCE THIS WILL MESS UP THE HASAEROSOL-MASK! + ! modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) = efact_omn & !excess OM mass is moved to this mode (originally kcomp=13) + ! * (modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) + cxstot(i)*modedefs(i)%f_c*(1.0_r8-modedefs(i)%f_bc)) end subroutine doLognormalInterpolation @@ -676,13 +659,13 @@ subroutine modalapp2d(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm,fbc ! mass between the various background mineral and sea-salt modes. ! Now also Aitken-modes are subject to condensation of H2SO4, and both n and ! Aitken modes may coagulate onto the mineral/sea-salt background aerosol. - !SOA + ! SOA ! May 2013: The SO4(Ait) mode now takes into account condensed SOA in addition ! to H2SO4, but as long as SOA is not allowed to condense on more than one ! mode, no changes are necessary here. NB: to allow SOA to condense also on ! the BC(Ait) and/or other modes, change this code accordingly! Without any ! changes, Cam(pcols,1) = condensed SO4 onto the SO4(ait) mode still. - !SOA + ! SOA ! Alf Grini, february 2014 : Added info about units, ! used values calculated at initialization. ! changed in-out variables to components of derived data types (modedefs) diff --git a/src/chemistry/oslo_aero/oslo_aero_linear_interp.F90 b/src/chemistry/oslo_aero/oslo_aero_linear_interp.F90 new file mode 100644 index 0000000000..7385e25d0c --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_aero_linear_interp.F90 @@ -0,0 +1,134 @@ +module oslo_aero_linear_interp + + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + private + + public :: lininterpol3dim + public :: lininterpol4dim + public :: lininterpol5dim + +! ========================================================== +contains +! ========================================================== + + subroutine lininterpol3dim (d2mx, dxm1, invd, opt3d, optout1, optout2) + + ! arguments + real(r8), intent(in) :: opt3d(2,2,2) + real(r8), intent(in) :: d2mx(3) + real(r8), intent(in) :: dxm1(3) + real(r8), intent(in) :: invd(3) + real(r8), intent(out) :: optout1 + real(r8), intent(out) :: optout2 + ! + ! local variables + real(r8) :: opt2d(2,2) + !------------------------------------ + + ! interpolation in the third dimension (except invd(3) factor) + opt2d(1,1) = d2mx(3)*opt3d(1,1,1) + dxm1(3)*opt3d(1,1,2) + opt2d(1,2) = d2mx(3)*opt3d(1,2,1) + dxm1(3)*opt3d(1,2,2) + opt2d(2,1) = d2mx(3)*opt3d(2,1,1) + dxm1(3)*opt3d(2,1,2) + opt2d(2,2) = d2mx(3)*opt3d(2,2,1) + dxm1(3)*opt3d(2,2,2) + + ! interpolation in the (third and) second dimension + optout1 = (d2mx(2)*opt2d(1,1) + dxm1(2)*opt2d(1,2))*invd(3)*invd(2) + optout2 = (d2mx(2)*opt2d(2,1) + dxm1(2)*opt2d(2,2))*invd(3)*invd(2) + + end subroutine lininterpol3dim + + ! ========================================================== + subroutine lininterpol4dim (d2mx, dxm1, invd, opt4d, optout1, optout2) + + ! arguments + real(r8), intent(in) :: opt4d(2,2,2,2) + real(r8), intent(in) :: d2mx(4) + real(r8), intent(in) :: dxm1(4) + real(r8), intent(in) :: invd(4) + real(r8), intent(out) :: optout1 + real(r8), intent(out) :: optout2 + ! + ! local variables + real(r8) :: opt3d(2,2,2), opt2d(2,2) + !------------------------------------ + + ! interpolation in the fourth dimension (except invd(4) factor) + opt3d(1,1,1) = d2mx(4)*opt4d(1,1,1,1) + dxm1(4)*opt4d(1,1,1,2) + opt3d(1,1,2) = d2mx(4)*opt4d(1,1,2,1) + dxm1(4)*opt4d(1,1,2,2) + opt3d(1,2,1) = d2mx(4)*opt4d(1,2,1,1) + dxm1(4)*opt4d(1,2,1,2) + opt3d(1,2,2) = d2mx(4)*opt4d(1,2,2,1) + dxm1(4)*opt4d(1,2,2,2) + opt3d(2,1,1) = d2mx(4)*opt4d(2,1,1,1) + dxm1(4)*opt4d(2,1,1,2) + opt3d(2,1,2) = d2mx(4)*opt4d(2,1,2,1) + dxm1(4)*opt4d(2,1,2,2) + opt3d(2,2,1) = d2mx(4)*opt4d(2,2,1,1) + dxm1(4)*opt4d(2,2,1,2) + opt3d(2,2,2) = d2mx(4)*opt4d(2,2,2,1) + dxm1(4)*opt4d(2,2,2,2) + + ! interpolation in the third dimension (except invd(3) factor) + opt2d(1,1) = d2mx(3)*opt3d(1,1,1) + dxm1(3)*opt3d(1,1,2) + opt2d(1,2) = d2mx(3)*opt3d(1,2,1) + dxm1(3)*opt3d(1,2,2) + opt2d(2,1) = d2mx(3)*opt3d(2,1,1) + dxm1(3)*opt3d(2,1,2) + opt2d(2,2) = d2mx(3)*opt3d(2,2,1) + dxm1(3)*opt3d(2,2,2) + + ! interpolation in the (fourth, third and) second dimension + optout1 = (d2mx(2)*opt2d(1,1) + dxm1(2)*opt2d(1,2))*invd(4)*invd(3)*invd(2) + optout2 = (d2mx(2)*opt2d(2,1) + dxm1(2)*opt2d(2,2))*invd(4)*invd(3)*invd(2) + + end subroutine lininterpol4dim + + ! ========================================================== + subroutine lininterpol5dim (d2mx, dxm1, invd, opt5d, optout1, optout2) + + ! arguments + real(r8), intent(in) :: opt5d(2,2,2,2,2) + real(r8), intent(in) :: d2mx(5) + real(r8), intent(in) :: dxm1(5) + real(r8), intent(in) :: invd(5) + real(r8), intent(out) :: optout1 + real(r8), intent(out) :: optout2 + + ! local variables + real(r8) :: opt4d(2,2,2,2), opt3d(2,2,2), opt2d(2,2) + !------------------------------------ + + ! interpolation in the fifth dimension (except invd(5) factor) + opt4d(1,1,1,1) = d2mx(5)*opt5d(1,1,1,1,1) + dxm1(5)*opt5d(1,1,1,1,2) + opt4d(1,1,1,2) = d2mx(5)*opt5d(1,1,1,2,1) + dxm1(5)*opt5d(1,1,1,2,2) + opt4d(1,1,2,1) = d2mx(5)*opt5d(1,1,2,1,1) + dxm1(5)*opt5d(1,1,2,1,2) + opt4d(1,1,2,2) = d2mx(5)*opt5d(1,1,2,2,1) + dxm1(5)*opt5d(1,1,2,2,2) + opt4d(1,2,1,1) = d2mx(5)*opt5d(1,2,1,1,1) + dxm1(5)*opt5d(1,2,1,1,2) + opt4d(1,2,1,2) = d2mx(5)*opt5d(1,2,1,2,1) + dxm1(5)*opt5d(1,2,1,2,2) + opt4d(1,2,2,1) = d2mx(5)*opt5d(1,2,2,1,1) + dxm1(5)*opt5d(1,2,2,1,2) + opt4d(1,2,2,2) = d2mx(5)*opt5d(1,2,2,2,1) + dxm1(5)*opt5d(1,2,2,2,2) + opt4d(2,1,1,1) = d2mx(5)*opt5d(2,1,1,1,1) + dxm1(5)*opt5d(2,1,1,1,2) + opt4d(2,1,1,2) = d2mx(5)*opt5d(2,1,1,2,1) + dxm1(5)*opt5d(2,1,1,2,2) + opt4d(2,1,2,1) = d2mx(5)*opt5d(2,1,2,1,1) + dxm1(5)*opt5d(2,1,2,1,2) + opt4d(2,1,2,2) = d2mx(5)*opt5d(2,1,2,2,1) + dxm1(5)*opt5d(2,1,2,2,2) + opt4d(2,2,1,1) = d2mx(5)*opt5d(2,2,1,1,1) + dxm1(5)*opt5d(2,2,1,1,2) + opt4d(2,2,1,2) = d2mx(5)*opt5d(2,2,1,2,1) + dxm1(5)*opt5d(2,2,1,2,2) + opt4d(2,2,2,1) = d2mx(5)*opt5d(2,2,2,1,1) + dxm1(5)*opt5d(2,2,2,1,2) + opt4d(2,2,2,2) = d2mx(5)*opt5d(2,2,2,2,1) + dxm1(5)*opt5d(2,2,2,2,2) + + ! interpolation in the fourth dimension (except invd(4) factor) + opt3d(1,1,1) = d2mx(4)*opt4d(1,1,1,1) + dxm1(4)*opt4d(1,1,1,2) + opt3d(1,1,2) = d2mx(4)*opt4d(1,1,2,1) + dxm1(4)*opt4d(1,1,2,2) + opt3d(1,2,1) = d2mx(4)*opt4d(1,2,1,1) + dxm1(4)*opt4d(1,2,1,2) + opt3d(1,2,2) = d2mx(4)*opt4d(1,2,2,1) + dxm1(4)*opt4d(1,2,2,2) + opt3d(2,1,1) = d2mx(4)*opt4d(2,1,1,1) + dxm1(4)*opt4d(2,1,1,2) + opt3d(2,1,2) = d2mx(4)*opt4d(2,1,2,1) + dxm1(4)*opt4d(2,1,2,2) + opt3d(2,2,1) = d2mx(4)*opt4d(2,2,1,1) + dxm1(4)*opt4d(2,2,1,2) + opt3d(2,2,2) = d2mx(4)*opt4d(2,2,2,1) + dxm1(4)*opt4d(2,2,2,2) + + ! interpolation in the third dimension (except invd(3) factor) + opt2d(1,1) = d2mx(3)*opt3d(1,1,1) + dxm1(3)*opt3d(1,1,2) + opt2d(1,2) = d2mx(3)*opt3d(1,2,1) + dxm1(3)*opt3d(1,2,2) + opt2d(2,1) = d2mx(3)*opt3d(2,1,1) + dxm1(3)*opt3d(2,1,2) + opt2d(2,2) = d2mx(3)*opt3d(2,2,1) + dxm1(3)*opt3d(2,2,2) + + ! interpolation in the (fifth, fourth, third and) second dimension + optout1 = (d2mx(2)*opt2d(1,1) + dxm1(2)*opt2d(1,2))*(invd(5)*invd(4)*invd(3)*invd(2)) + optout2 = (d2mx(2)*opt2d(2,1) + dxm1(2)*opt2d(2,2))*(invd(5)*invd(4)*invd(3)*invd(2)) + + end subroutine lininterpol5dim + +end module oslo_aero_linear_interp diff --git a/src/chemistry/oslo_aero/intlog.F90 b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 similarity index 76% rename from src/chemistry/oslo_aero/intlog.F90 rename to src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 index 008a7f9968..3c430e1d36 100644 --- a/src/chemistry/oslo_aero/intlog.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 @@ -1,12 +1,13 @@ -module oslo_aero_interp_log - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols - use cam_logfile, only: iulog - use oslo_control, only: oslo_getopts,dir_string_length - use commondefinitions, only: nmodes, nbmodes - use oslo_aero_sw_tables, only: cate, fac, faq, fbc, cat - use lininterpol_mod, only: lininterpol3dim, lininterpol4dim +module oslo_aero_logn_tables + + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols + use cam_logfile, only: iulog + ! + use oslo_control, only: oslo_getopts,dir_string_length + use commondefinitions, only: nmodes, nbmodes + use oslo_aero_sw_tables, only: cate, fac, faq, fbc, cat + use oslo_aero_linear_interp, only: lininterpol3dim, lininterpol4dim use aerosoldef implicit none @@ -265,46 +266,47 @@ end subroutine initlogn subroutine intlog1to3_sub (ncol, ind, kcomp, xctin, & Nnat, xfacin, cxs, xstdv, xrk) - ! Created by Trude Storelvmo, fall 2007. This subroutine gives as output - ! the "new" modal radius and standard deviation for a given aerosol mode, kcomp - ! 1-3. These parameters are calculated for a best lognormal fit approximation of - ! the aerosol size distribution. This because the aerosol activation routine - ! (developed by Abdul-Razzak & Ghan, 2000) requiers the size distribution to be - ! described by lognormal modes. - ! Changed by Alf KirkevÃ¥g to take into account condensation of SOA, September 2015, - - integer, intent(in) :: ncol - integer, intent(in) :: ind(pcols) - integer, intent(in) :: kcomp - real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration - real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) - real(r8), intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass - real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit - real(r8), intent(out) :: xrk(pcols) ! Modal radius for lognormal fit - real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. - - real(r8) camdiff - real(r8) xct(pcols) - real(r8) xfac(ncol) - integer lon, long - integer i, ictot, ict1, ict2 - real(r8) r1, r2, s1, s2 - integer ifac, ifac1, ifac2 - real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2 - real(r8) r11, r12, r21, r22, s11, s12, s21, s22 - real(r8) d2mx(2), dxm1(2), invd(2) - real(r8) esssf10, ess + ! Created by Trude Storelvmo, fall 2007. This subroutine gives as output + ! the "new" modal radius and standard deviation for a given aerosol mode, kcomp + ! 1-3. These parameters are calculated for a best lognormal fit approximation of + ! the aerosol size distribution. This because the aerosol activation routine + ! (developed by Abdul-Razzak & Ghan, 2000) requiers the size distribution to be + ! described by lognormal modes. + ! Changed by Alf KirkevÃ¥g to take into account condensation of SOA, September 2015, + + integer , intent(in) :: ncol + integer , intent(in) :: ind(pcols) + integer , intent(in) :: kcomp + real(r8) , intent(in) :: Nnat(pcols) ! Modal number concentration + real(r8) , intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) + real(r8) , intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass + real(r8) , intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit + real(r8) , intent(out) :: xrk(pcols) ! Modal radius for lognormal fit + real(r8) , intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. + + ! local variables + real(r8) :: camdiff + real(r8) :: xct(pcols) + real(r8) :: xfac(ncol) + integer :: lon, long + integer :: i, ictot, ict1, ict2 + real(r8) :: r1, r2, s1, s2 + integer :: ifac, ifac1, ifac2 + real(r8) :: t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2 + real(r8) :: r11, r12, r21, r22, s11, s12, s21, s22 + real(r8) :: d2mx(2), dxm1(2), invd(2) + real(r8) :: ess real(r8), parameter :: eps= 1.0e-10_r8 - ! Initialize excess mass cxs, wrt. maximum allowed internal mixing + ! Initialize excess mass cxs, wrt. maximum allowed internal mixing do lon=1,ncol cxs(lon) = 0.0_r8 xct(lon) = 0.0_r8 xfac(lon) = 0.0_r8 enddo - do long=1,ncol - lon=ind(long) + do long = 1,ncol + lon = ind(long) xstdv(lon) = 0._r8 xrk(lon) = 0._r8 @@ -316,8 +318,7 @@ subroutine intlog1to3_sub (ncol, ind, kcomp, xctin, & ictot=1 ess = xct(lon) - do while (ictot.lt.15.and.(ess.lt.cate(kcomp,ictot).or. & - ess.gt.cate(kcomp,ictot+1))) + do while (ictot.lt.15 .and. (ess.lt.cate(kcomp,ictot) .or. ess.gt.cate(kcomp,ictot+1))) ictot=ictot+1 enddo ict1=ictot @@ -325,15 +326,14 @@ subroutine intlog1to3_sub (ncol, ind, kcomp, xctin, & ifac=1 ess = xfac(lon) - do while (ifac.lt.5.and.(ess.lt.fac(ifac).or. & - ess.gt.fac(ifac+1))) + do while (ifac.lt.5 .and. (ess.lt.fac(ifac) .or. ess.gt.fac(ifac+1))) ifac=ifac+1 enddo ifac1=ifac ifac2=ifac+1 - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing t_cat1 = cate(kcomp,ict1) t_cat2 = cate(kcomp,ict2) @@ -343,7 +343,7 @@ subroutine intlog1to3_sub (ncol, ind, kcomp, xctin, & t_xct = xct(lon) t_xfac = xfac(lon) - ! partial lengths along each dimension (1-2) for interpolation + ! partial lengths along each dimension (1-2) for interpolation d2mx(1) = (t_cat2-t_xct) dxm1(1) = (t_xct-t_cat1) @@ -352,7 +352,7 @@ subroutine intlog1to3_sub (ncol, ind, kcomp, xctin, & dxm1(2) = (t_xfac-t_fac1) invd(2) = 1.0_r8/(t_fac2-t_fac1) - ! interpolated (in 2 dimensions) modal median radius: + ! interpolated (in 2 dimensions) modal median radius: r11=rrr1to3(kcomp,ict1,ifac1) r12=rrr1to3(kcomp,ict1,ifac2) @@ -364,7 +364,7 @@ subroutine intlog1to3_sub (ncol, ind, kcomp, xctin, & xrk(lon) = (d2mx(1)*r1+dxm1(1)*r2)*invd(2)*invd(1)*1.e-6_r8 !Look-up table radii in um - ! interpolated (in 2 dimensions) modal standard deviation: + ! interpolated (in 2 dimensions) modal standard deviation: s11=sss1to3(kcomp,ict1,ifac1) s12=sss1to3(kcomp,ict1,ifac2) @@ -383,56 +383,50 @@ end subroutine intlog1to3_sub subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & xfacin, xfaqin, cxs, xstdv, xrk) - ! Created by Trude Storelvmo, fall 2007. This subroutine gives as output - ! the "new" modal radius and standard deviation for aerosol mode kcomp=4. - ! These parameters are calculated for a best lognormal fit approximation of - ! the aerosol size distribution. This because the aerosol activation routine - ! (developed by Abdul-Razzak & Ghan, 2000) requires the size distribution - ! to be described by lognormal modes. - ! Changed by Alf KirkevÃ¥g to take into account condensation of SOA, September - ! 2015, and also rewritten to a more generalized for for interpolations using - ! common subroutines interpol*dim. - - integer, intent(in) :: ncol - integer, intent(in) :: ind(pcols) - integer, intent(in) :: kcomp - real(r8), intent(in) :: Nnat(pcols) ! Modal number concentration - real(r8), intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) - real(r8), intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass - real(r8), intent(in) :: xfaqin(pcols) ! = Cso4a2/(Cso4a1+Cso4a2) - real(r8), intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit - real(r8), intent(out) :: xrk(pcols) ! Modal radius for lognormal fit - real(r8), intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. - - real(r8) camdiff - real(r8), dimension(pcols) :: xct, xfac, xfaq - - integer lon, long - - integer i, ictot, ifac, ifaq, & - ict1, ict2, ifac1, ifac2, ifaq1, ifaq2 - - real(r8) t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2, & - t_faq1, t_faq2, t_xfaq - real(r8) r1, r2, s1, s2, tmp, e - real(r8) d2mx(3), dxm1(3), invd(3) - real(r8) sizepar3d(2,2,2) - - !ces: New local variables introduced by (or inspired by) Egil Stoeren: - - real(r8), parameter :: eps=1.0e-60_r8 - - ! Initialize excess mass cxs, wrt. maximum allowed internal mixing + ! Created by Trude Storelvmo, fall 2007. This subroutine gives as output + ! the "new" modal radius and standard deviation for aerosol mode kcomp=4. + ! These parameters are calculated for a best lognormal fit approximation of + ! the aerosol size distribution. This because the aerosol activation routine + ! (developed by Abdul-Razzak & Ghan, 2000) requires the size distribution + ! to be described by lognormal modes. + ! Changed by Alf KirkevÃ¥g to take into account condensation of SOA, September + ! 2015, and also rewritten to a more generalized for for interpolations using + ! common subroutines interpol*dim. + + integer , intent(in) :: ncol + integer , intent(in) :: ind(pcols) + integer , intent(in) :: kcomp + real(r8) , intent(in) :: Nnat(pcols) ! Modal number concentration + real(r8) , intent(in) :: xctin(pcols) ! total internally mixed conc. (ug/m3) + real(r8) , intent(in) :: xfacin(pcols) ! SOA/(SOA+H2SO4) for condensated mass + real(r8) , intent(in) :: xfaqin(pcols) ! = Cso4a2/(Cso4a1+Cso4a2) + real(r8) , intent(out) :: xstdv(pcols) ! log10 of standard deviation for lognormal fit + real(r8) , intent(out) :: xrk(pcols) ! Modal radius for lognormal fit + real(r8) , intent(out) :: cxs(pcols) ! excess (modal) internally mixed conc. + + ! local variables + real(r8) :: camdiff + real(r8) :: xct(pcols) + real(r8) :: xfac(pcols) + real(r8) :: xfaq(pcols) + integer :: lon, long + integer :: i, ictot, ifac, ifaq + integer :: ict1, ict2, ifac1, ifac2, ifaq1, ifaq2 + real(r8) :: t_fac1, t_fac2, t_xfac, t_xct, t_cat1, t_cat2 + real(r8) :: t_faq1, t_faq2, t_xfaq + real(r8) :: r1, r2, s1, s2, tmp, e + real(r8) :: d2mx(3), dxm1(3), invd(3) + real(r8) :: sizepar3d(2,2,2) + real(r8), parameter :: eps=1.0e-60_r8 ! introduced by (or inspired by) Egil Stoeren: + + ! Initialize excess mass cxs, wrt. maximum allowed internal mixing do lon=1,ncol - cxs(lon) = 0.0_r8 + cxs(lon) = 0.0_r8 xct(lon) = 0.0_r8 xfac(lon) = 0.0_r8 xfaq(lon) = 0.0_r8 enddo - !ces: All loops "do long=1,nlons" combined to one loop: - - ! do lon=1,ncol do long=1,ncol lon=ind(long) xstdv(lon) = 0._r8 @@ -448,8 +442,7 @@ subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & ictot=1 tmp = xct(lon) - do while (ictot.lt.15.and.(tmp.lt.cate(kcomp,ictot).or. & - tmp.gt.cate(kcomp,ictot+1))) + do while (ictot.lt.15 .and. (tmp.lt.cate(kcomp,ictot) .or. tmp.gt.cate(kcomp,ictot+1))) ictot=ictot+1 enddo ict1=ictot @@ -457,8 +450,7 @@ subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & ifac=1 tmp = xfac(lon) - do while (ifac.lt.5.and.(tmp.lt.fac(ifac).or. & - tmp.gt.fac(ifac+1))) + do while (ifac.lt.5 .and. (tmp.lt.fac(ifac) .or. tmp.gt.fac(ifac+1))) ifac=ifac+1 enddo ifac1=ifac @@ -466,15 +458,14 @@ subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & ifaq=1 tmp = xfaq(lon) - do while (ifaq.lt.5.and.(tmp.lt.faq(ifaq) & - .or.tmp.gt.faq(ifaq+1))) + do while (ifaq.lt.5 .and. (tmp.lt.faq(ifaq) .or. tmp.gt.faq(ifaq+1))) ifaq=ifaq+1 enddo ifaq1=ifaq ifaq2=ifaq+1 - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing t_cat1 = cate(kcomp,ict1) t_cat2 = cate(kcomp,ict2) t_fac1 = fac(ifac1) @@ -486,7 +477,7 @@ subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & t_xfac = xfac(lon) t_xfaq = xfaq(lon) - ! partial lengths along each dimension (1-4) for interpolation + ! partial lengths along each dimension (1-4) for interpolation d2mx(1) = (t_cat2-t_xct) dxm1(1) = (t_xct-t_cat1) invd(1) = 1.0_r8/(t_cat2-t_cat1) @@ -497,8 +488,8 @@ subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & dxm1(3) = (t_xfaq-t_faq1) invd(3) = 1.0_r8/(t_faq2-t_faq1) - ! Table points as basis for multidimentional linear interpolation, - ! modal median radius: + ! Table points as basis for multidimentional linear interpolation, + ! modal median radius: sizepar3d(1,1,1)=rrr4(ict1,ifac1,ifaq1) sizepar3d(1,1,2)=rrr4(ict1,ifac1,ifaq2) @@ -509,15 +500,15 @@ subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & sizepar3d(2,2,1)=rrr4(ict2,ifac2,ifaq1) sizepar3d(2,2,2)=rrr4(ict2,ifac2,ifaq2) - ! interpolation in the faq and fac dimension + ! interpolation in the faq and fac dimension call lininterpol3dim (d2mx, dxm1, invd, sizepar3d, r1, r2) - ! finally, interpolation in the cate dimension + ! finally, interpolation in the cate dimension xrk(lon)=(d2mx(1)*r1+dxm1(1)*r2)*invd(1)*1.e-6_r8 ! look up table radii in um - ! Table points as basis for multidimentional linear interpolation, - ! modal standard deviation: + ! Table points as basis for multidimentional linear interpolation, + ! modal standard deviation: sizepar3d(1,1,1)=sss4(ict1,ifac1,ifaq1) sizepar3d(1,1,2)=sss4(ict1,ifac1,ifaq2) sizepar3d(1,2,1)=sss4(ict1,ifac2,ifaq1) @@ -527,10 +518,10 @@ subroutine intlog4_sub (ncol, ind, kcomp, xctin, Nnat, & sizepar3d(2,2,1)=sss4(ict2,ifac2,ifaq1) sizepar3d(2,2,2)=sss4(ict2,ifac2,ifaq2) - ! interpolation in the faq and fac dimension + ! interpolation in the faq and fac dimension call lininterpol3dim (d2mx, dxm1, invd, sizepar3d, s1, s2) - ! finally, interpolation in the cate dimension + ! finally, interpolation in the cate dimension xstdv(lon)=(d2mx(1)*s1+dxm1(1)*s2)*invd(1) end do ! lon @@ -574,7 +565,7 @@ subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & real(r8), parameter :: eps=1.0e-10_r8 - ! Initialize excess mass cxs, wrt. maximum allowed internal mixing + ! Initialize excess mass cxs, wrt. maximum allowed internal mixing do lon=1,ncol cxs(lon) = 0.0_r8 xct(lon) = 0.0_r8 @@ -585,7 +576,7 @@ subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & !ces: All loops "do long=1,nlons" combined to one loop: - ! do lon=1,ncol + ! do lon=1,ncol do long=1,ncol lon=ind(long) xstdv(lon) = 0._r8 @@ -636,8 +627,8 @@ subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & ifaq1=ifaq ifaq2=ifaq+1 - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing + ! Collect all the vector elements into temporary storage + ! to avoid cache conflicts and excessive cross-referencing t_cat1 = cat(kcomp,ict1) t_cat2 = cat(kcomp,ict2) t_fac1 = fac(ifac1) @@ -652,7 +643,7 @@ subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & t_xfbc = xfbc(lon) t_xfaq = xfaq(lon) - ! partial lengths along each dimension (1-4) for interpolation + ! partial lengths along each dimension (1-4) for interpolation d2mx(1) = (t_cat2-t_xct) dxm1(1) = (t_xct-t_cat1) invd(1) = 1.0_r8/(t_cat2-t_cat1) @@ -666,8 +657,8 @@ subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & dxm1(4) = (t_xfaq-t_faq1) invd(4) = 1.0_r8/(t_faq2-t_faq1) - ! Table points as basis for multidimentional linear interpolation, - ! modal median radius: + ! Table points as basis for multidimentional linear interpolation, + ! modal median radius: sizepar4d(1,1,1,1)=rrr(kcomp,ict1,ifac1,ifbc1,ifaq1) sizepar4d(1,1,1,2)=rrr(kcomp,ict1,ifac1,ifbc1,ifaq2) @@ -686,14 +677,14 @@ subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & sizepar4d(2,2,2,1)=rrr(kcomp,ict2,ifac2,ifbc2,ifaq1) sizepar4d(2,2,2,2)=rrr(kcomp,ict2,ifac2,ifbc2,ifaq2) - ! interpolation in the faq, fbc, fac and cat dimensions + ! interpolation in the faq, fbc, fac and cat dimensions call lininterpol4dim (d2mx, dxm1, invd, sizepar4d, r1, r2) - ! finally, interpolation in the cat dimension + ! finally, interpolation in the cat dimension xrk(lon)=(d2mx(1)*r1+dxm1(1)*r2)*invd(1)*1.e-6_r8 ! look-up table radii in um - ! Table points as basis for multidimentional linear interpolation, - ! modal standard deviation: + ! Table points as basis for multidimentional linear interpolation, + ! modal standard deviation: sizepar4d(1,1,1,1)=sss(kcomp,ict1,ifac1,ifbc1,ifaq1) sizepar4d(1,1,1,2)=sss(kcomp,ict1,ifac1,ifbc1,ifaq2) @@ -712,10 +703,10 @@ subroutine intlog5to10_sub (ncol, ind, kcomp, xctin, Nnat, & sizepar4d(2,2,2,1)=sss(kcomp,ict2,ifac2,ifbc2,ifaq1) sizepar4d(2,2,2,2)=sss(kcomp,ict2,ifac2,ifbc2,ifaq2) - ! interpolation in the faq, fbc, fac and cat dimensions + ! interpolation in the faq, fbc, fac and cat dimensions call lininterpol4dim (d2mx, dxm1, invd, sizepar4d, s1, s2) - ! finally, interpolation in the cat dimension + ! finally, interpolation in the cat dimension xstdv(lon)=(d2mx(1)*s1+dxm1(1)*s2)*invd(1) end do ! lon @@ -723,9 +714,13 @@ end subroutine intlog5to10_sub !******************************************************************************************** subroutine checkTableHeader (ifil) + ! Read the header-text in a look-up table (in file with iu=ifil). + ! arguments integer, intent(in) :: ifil + + ! local variables character*80 :: headertext character*12 :: text0, text1 @@ -737,5 +732,5 @@ subroutine checkTableHeader (ifil) enddo end subroutine checkTableHeader -end module oslo_aero_interp_log +end module oslo_aero_logn_tables diff --git a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 index 98fefc6a94..12eaec4eec 100644 --- a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 @@ -36,12 +36,13 @@ module oslo_aero_sw_tables ! faq : mass fraction of sulfate which is produced in wet-phase, SO4aq/SO4. ! The remaining SO4 mass, SO4*(1-faq), is from condensation. - use shr_kind_mod , only: r8 => shr_kind_r8 - use ppgrid , only: pcols, pver - use cam_logfile , only: iulog - use oslo_control , only: oslo_getopts, dir_string_length - use commondefinitions , only: nmodes, nbmodes - use lininterpol_mod , only: lininterpol3dim, lininterpol4dim, lininterpol5dim + use shr_kind_mod , only: r8 => shr_kind_r8 + use ppgrid , only: pcols, pver + use cam_logfile , only: iulog + ! + use commondefinitions , only: nmodes, nbmodes + use oslo_control , only: oslo_getopts, dir_string_length + use oslo_aero_linear_interp , only: lininterpol3dim, lininterpol4dim, lininterpol5dim implicit none private From c5dda2f8599ef82618ea0733da5c90bec5f2bacd Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sat, 2 Sep 2023 20:06:03 +0200 Subject: [PATCH 41/71] more cleanup --- src/chemistry/oslo_aero/oslo_aero_conc.F90 | 11 +- .../oslo_aero/oslo_aero_logn_tables.F90 | 157 ++++++++---------- 2 files changed, 70 insertions(+), 98 deletions(-) diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 index e46f8a9536..3c88bf0702 100644 --- a/src/chemistry/oslo_aero/oslo_aero_conc.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_conc.F90 @@ -505,7 +505,6 @@ subroutine doLognormalInterpolation(ncol, numberConcentration, hasAerosol, & real(r8) :: log10sig(pcols,pver) ! [-] logarithm (base 10) of look up tables real(r8) :: f_ocm(pcols,pver,4) ! [-] fraction of added mass which is either SOA condensate or OC coagulate real(r8) :: cxs(pcols,pver,nbmodes) ![ug/m3] NOTE NON-SI UNITS non-allocated mass - integer :: ind(pcols) ![idx] index in mapping (not really used) real(r8) :: radius_tmp(pcols,pver) ![m] radius in look up tables ! Initialize logn tables for interpolation @@ -539,15 +538,9 @@ subroutine doLognormalInterpolation(ncol, numberConcentration, hasAerosol, & if ( kcomp .ge. MODE_IDX_SO4SOA_AIT .and. kcomp .le. MODE_IDX_BC_AIT) then ! kcomp=1,2 - ! Remove this later? - do i=1,ncol - ind(i) = i - end do - do k=1,pver call intlog1to3_sub( & ncol, & !I number of points - ind, & !I [idx] mappoing of points to use kcomp, & !I [idx] mode index camUg(:,k), & !I [ug/m3] mass concentration nConccm3(:,k), & !I [#/cm3] number concentration @@ -562,8 +555,7 @@ subroutine doLognormalInterpolation(ncol, numberConcentration, hasAerosol, & do k=1,pver call intlog4_sub( & - ncol, & !I number of points - ind, & !I [idx] mappoing of points to use + ncol, & !I [nbr] number of points kcomp, & !I [idx] mode index camUg(:,k), & !I [ug/m3] mass concentration nConccm3(:,k), & !I [#/cm3] number concentration @@ -580,7 +572,6 @@ subroutine doLognormalInterpolation(ncol, numberConcentration, hasAerosol, & do k=1,pver call intlog5to10_sub( & ncol, & !I [nbr] number of points used - ind, & !I [mapping] (not used) kcomp, & !I [mode index] camUg(:,k), & !I [ug/m3] mass concentration nConccm3(:,k), & !I [#/cm3] number concentration diff --git a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 index 3c430e1d36..deaaa93a18 100644 --- a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 @@ -3,6 +3,7 @@ module oslo_aero_logn_tables use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols use cam_logfile, only: iulog + use spmd_utils, only: masterproc ! use oslo_control, only: oslo_getopts,dir_string_length use commondefinitions, only: nmodes, nbmodes @@ -18,12 +19,12 @@ module oslo_aero_logn_tables public :: intlog4_sub public :: intlog5to10_sub - real(r8) :: rrr1to3 (3,16,6) ! Modal radius array, mode 1 - 3 - real(r8) :: sss1to3 (3,16,6) ! Standard deviation array, Mode 1 -3 - real(r8) :: rrr4 (16,6,6) ! Modal radius array, mode 4 - real(r8) :: sss4 (16,6,6) ! Modal radius array, mode 4 - real(r8) :: rrr (5:10,6,6,6,6) ! Modal radius array, mode 5 - 10 - real(r8) :: sss (5:10,6,6,6,6) ! Standard deviation array, mode 5 - 10 + real(r8) :: rrr1to3 (3,16,6) ! Modal radius array, mode 1 - 3 + real(r8) :: sss1to3 (3,16,6) ! Standard deviation array, Mode 1 -3 + real(r8) :: rrr4 (16,6,6) ! Modal radius array, mode 4 + real(r8) :: sss4 (16,6,6) ! Modal radius array, mode 4 + real(r8) :: rrr (5:10,6,6,6,6) ! Modal radius array, mode 5 - 10 + real(r8) :: sss (5:10,6,6,6,6) ! Standard deviation array, mode 5 - 10 real(r8) :: calog1to3(3,96) ! Array for reading catot from file real(r8) :: rk1to3 (3,96) ! Array for reading modal radius from file @@ -31,8 +32,8 @@ module oslo_aero_logn_tables real(r8) :: fraclog1to3 (3,96) ! Same as frac4, but for initlogn.F90 real(r8) :: calog4(576) ! Same as catot4, but for initlogn.F90 - real(r8) :: fraclog4 (576) ! Same as frac4, but for initlogn.F90 - real(r8) :: fraqlog4 (576) ! Same as fraq4, but for initlogn.F90 + real(r8) :: fraclog4(576) ! Same as frac4, but for initlogn.F90 + real(r8) :: fraqlog4(576) ! Same as fraq4, but for initlogn.F90 real(r8) :: rk4 (576) ! Array for reading modal radius from file real(r8) :: stdv4 (576) ! Array for reading std. dev. from file @@ -52,11 +53,11 @@ subroutine initlogn() ! Reads the tabulated parameters for "best lognormal fits" of the ! aerosol size distribution wrt CCN activation as calculated by Alf Kirkevaag. - integer kcomp, ictot, ifac, ifbc, ifaq, irk, istdv - integer ic, ifil, lin - character(len=dir_string_length) :: aerotab_table_dir + integer :: kcomp, ictot, ifac, ifbc, ifaq + integer :: ic, ifil, lin real(r8) :: eps2 = 1.e-2_r8 real(r8) :: eps4 = 1.e-4_r8 + character(len=dir_string_length) :: aerotab_table_dir ! Where are the tables stored?? call oslo_getopts(aerotab_table_dir_out=aerotab_table_dir) @@ -71,7 +72,9 @@ subroutine initlogn() open(27,file=trim(aerotab_table_dir)//'/logntilp8.out' ,form='formatted',status='old') ! SEASF open(28,file=trim(aerotab_table_dir)//'/logntilp9.out' ,form='formatted',status='old') ! SEASACC open(29,file=trim(aerotab_table_dir)//'/logntilp10.out',form='formatted',status='old') ! SEASCOA - write(iulog,*)'nlog open ok' + if (masterproc) then + write(iulog,*)'nlog open ok' + end if ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) do ifil = 20,29 @@ -103,7 +106,6 @@ subroutine initlogn() exit endif end do - sss1to3(kcomp,ictot,ifac) = stdv1to3(ifil,lin) rrr1to3(kcomp,ictot,ifac) = rk1to3(ifil,lin) end do ! lin @@ -134,8 +136,9 @@ subroutine initlogn() enddo enddo enddo - write(iulog,*)'nlog mode 1-3 ok' - + if (masterproc) then + write(iulog,*)'nlog mode 1-3 ok' + end if ! ************************************************************************ ! Mode 4 (BC&OC + condesate from H2SO4 + wetphase (NH4)2SO4) @@ -185,7 +188,9 @@ subroutine initlogn() enddo enddo enddo - write(iulog,*)'nlog mode 4 ok' + if (masterproc) then + write(iulog,*)'nlog mode 4 ok' + end if ! ************************************************************************ ! Modes 5 to 10 (SO4(ait75) and mineral and seasalt-modes + cond./coag./aq.) @@ -193,9 +198,9 @@ subroutine initlogn() do ifil = 5,10 do lin = 1,1296 ! 6**4 entries - read(19+ifil,995) kcomp, calog(ifil,lin) & - ,fraclog5to10(ifil,lin), fabclog5to10(ifil,lin), fraqlog5to10(ifil,lin) & - ,rk5to10(ifil,lin), stdv5to10(ifil,lin) + read(19+ifil,995) kcomp, calog(ifil,lin), & + fraclog5to10(ifil,lin), fabclog5to10(ifil,lin), fraqlog5to10(ifil,lin), & + rk5to10(ifil,lin), stdv5to10(ifil,lin) do ic=1,6 if(abs((calog(ifil,lin)-cat(kcomp,ic))/cat(kcomp,ic)) Date: Sun, 3 Sep 2023 11:47:23 +0200 Subject: [PATCH 42/71] more refactoring --- .../oslo_aero/{oslo_control.F90 => oslo_aero_control.F90} | 0 1 file changed, 0 insertions(+), 0 deletions(-) rename src/chemistry/oslo_aero/{oslo_control.F90 => oslo_aero_control.F90} (100%) diff --git a/src/chemistry/oslo_aero/oslo_control.F90 b/src/chemistry/oslo_aero/oslo_aero_control.F90 similarity index 100% rename from src/chemistry/oslo_aero/oslo_control.F90 rename to src/chemistry/oslo_aero/oslo_aero_control.F90 From 7762cb1fda30231774ab1be05632c6e5ef4cebd4 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 3 Sep 2023 11:47:31 +0200 Subject: [PATCH 43/71] more refactoring --- src/chemistry/oslo_aero/aerocom_dry_mod.F90 | 4 +- src/chemistry/oslo_aero/aerocom_opt_mod.F90 | 4 +- src/chemistry/oslo_aero/oslo_aero_control.F90 | 101 ++++++------ .../oslo_aero/oslo_aero_logn_tables.F90 | 6 +- src/chemistry/oslo_aero/oslo_aero_ocean.F90 | 4 +- .../oslo_aero/oslo_aero_sw_tables.F90 | 10 +- src/control/runtime_opts.F90 | 4 +- src/physics/cam_oslo/radiation.F90 | 151 +++++++++++------- src/physics/cam_oslo/radlw.F90 | 6 + src/physics/cam_oslo/radsw.F90 | 33 +++- 10 files changed, 198 insertions(+), 125 deletions(-) diff --git a/src/chemistry/oslo_aero/aerocom_dry_mod.F90 b/src/chemistry/oslo_aero/aerocom_dry_mod.F90 index 983164ce0b..77df9b1cae 100644 --- a/src/chemistry/oslo_aero/aerocom_dry_mod.F90 +++ b/src/chemistry/oslo_aero/aerocom_dry_mod.F90 @@ -9,7 +9,7 @@ module aerocom_dry_mod use commondefinitions , only: nmodes, nbmodes use oslo_aero_sw_tables , only: cate, cat, fac, faq, fbc, fombg, fbcbg, nbmp1 use oslo_aero_linear_interp , only: lininterpol3dim, lininterpol4dim, lininterpol5dim - use oslo_control , only: oslo_getopts, dir_string_length + use oslo_aero_control , only: oslo_aero_getopts, dir_string_length implicit none private @@ -113,7 +113,7 @@ subroutine initdryp() real(r8) :: eps7 = 1.e-7_r8 character(len=dir_string_length) :: aerotab_table_dir - call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + call oslo_aero_getopts(aerotab_table_dir_out = aerotab_table_dir) open(20,file=trim(aerotab_table_dir)//'/aerodryk0.out' ,form='formatted',status='old') open(21,file=trim(aerotab_table_dir)//'/aerodryk1.out' ,form='formatted',status='old') diff --git a/src/chemistry/oslo_aero/aerocom_opt_mod.F90 b/src/chemistry/oslo_aero/aerocom_opt_mod.F90 index db3bdb46bc..700c982abd 100644 --- a/src/chemistry/oslo_aero/aerocom_opt_mod.F90 +++ b/src/chemistry/oslo_aero/aerocom_opt_mod.F90 @@ -8,7 +8,7 @@ module aerocom_opt_mod ! use commondefinitions , only : nmodes, nbmodes use oslo_aero_sw_tables , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg - use oslo_control , only : oslo_getopts, dir_string_length + use oslo_aero_control , only : oslo_aero_getopts, dir_string_length use oslo_aero_linear_interp , only : lininterpol3dim, lininterpol4dim, lininterpol5dim implicit none @@ -138,7 +138,7 @@ subroutine initaeropt() character(len=dir_string_length) :: aerotab_table_dir !----------------------------------------------------------- - call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + call oslo_aero_getopts(aerotab_table_dir_out = aerotab_table_dir) open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' , form='formatted',status='old') open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' , form='formatted',status='old') diff --git a/src/chemistry/oslo_aero/oslo_aero_control.F90 b/src/chemistry/oslo_aero/oslo_aero_control.F90 index c9cad9434d..02c3bf373e 100644 --- a/src/chemistry/oslo_aero/oslo_aero_control.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_control.F90 @@ -1,26 +1,24 @@ -module oslo_control +module oslo_aero_control + !----------------------------------------------------------------------- - ! Purpose: - ! ! Provides a control interface to CAM-Oslo packages !----------------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8 use spmd_utils, only: masterproc use cam_logfile, only: iulog use cam_abortutils, only: endrun - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_cpl_indices, only:index_x2a_Faoo_fdms_ocn implicit none private - public :: oslo_ctl_readnl ! read namelist from file - public :: oslo_getopts ! generic query method + public :: oslo_aero_ctl_readnl ! read namelist from file + public :: oslo_aero_getopts ! generic query method ! Private module data - integer, parameter,public :: dir_string_length=256 character(len=16), parameter :: unset_str = 'UNSET' integer, parameter :: unset_int = huge(1) + integer, parameter, public :: dir_string_length=256 ! Namelist variables: real(r8) :: volc_fraction_coarse = 0.0_r8 !Fraction of volcanic aerosols in coarse mode @@ -40,14 +38,15 @@ module oslo_control contains !======================================================================= - subroutine oslo_ctl_readnl(nlfile) + subroutine oslo_aero_ctl_readnl(nlfile) use namelist_utils, only: find_group_name use mpishorthand + ! arguments character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - ! Local variables + ! local variables integer :: unitn, ierr character(len=*), parameter :: subname = 'oslo_ctl_readnl' logical :: dirExists=.FALSE. @@ -59,7 +58,7 @@ subroutine oslo_ctl_readnl(nlfile) !----------------------------------------------------------------------------- if (masterproc) then - open(newunit=unitn, file=trim(nlfile), status='old' ) + open (newunit=unitn, file=trim(nlfile), status='old' ) call find_group_name(unitn, 'oslo_ctl_nl', status=ierr) if (ierr == 0) then read(unitn, oslo_ctl_nl, iostat=ierr) @@ -69,21 +68,24 @@ subroutine oslo_ctl_readnl(nlfile) end if close(unitn) end if - #ifdef SPMD ! Broadcast namelist variables - call mpibcast(volc_fraction_coarse, 1 , mpir8, 0, mpicom) - call mpibcast(aerotab_table_dir, len(aerotab_table_dir) , mpichar, 0, mpicom) + call mpibcast(volc_fraction_coarse, 1 , mpir8, 0, mpicom) + call mpibcast(aerotab_table_dir, len(aerotab_table_dir) , mpichar, 0, mpicom) ! dms variables - call mpibcast(dms_source, len(dms_source) , mpichar, 0, mpicom) - call mpibcast(dms_source_type, len(dms_source_type) , mpichar, 0, mpicom) - call mpibcast(opom_source, len(opom_source) , mpichar, 0, mpicom) - call mpibcast(opom_source_type, len(opom_source_type) , mpichar, 0, mpicom) - call mpibcast(ocean_filename, len(ocean_filename) , mpichar, 0, mpicom) - call mpibcast(ocean_filepath, len(ocean_filepath) , mpichar, 0, mpicom) - call mpibcast(dms_cycle_year, 1 , mpiint, 0, mpicom) - call mpibcast(opom_cycle_year, 1 , mpiint, 0, mpicom) + call mpibcast(dms_source, len(dms_source), mpichar, 0, mpicom) + call mpibcast(dms_source_type, len(dms_source_type) , mpichar, 0, mpicom) + call mpibcast(dms_cycle_year, 1 , mpiint, 0, mpicom) + + ! opom variables + call mpibcast(opom_source, len(opom_source), mpichar, 0, mpicom) + call mpibcast(opom_source_type, len(opom_source_type), mpichar, 0, mpicom) + call mpibcast(opom_cycle_year, 1, mpiint, 0, mpicom) + + ! ocean variables + call mpibcast(ocean_filename, len(ocean_filename), mpichar, 0, mpicom) + call mpibcast(ocean_filepath, len(ocean_filepath), mpichar, 0, mpicom) #endif ! Error checking: @@ -102,7 +104,7 @@ subroutine oslo_ctl_readnl(nlfile) #else !Don't know how to check this on other compilres.. Assume exists !and let crash later.. - dirExists = .TRUE. + dirExists = .true. #endif if(.not. dirExists)then call endrun("cam_oslo: can not find aerotab table directory "//trim(aerotab_table_dir)) @@ -114,34 +116,39 @@ subroutine oslo_ctl_readnl(nlfile) ! can ocean file be found? inquire( file=trim(ocean_filepath)//'/'//trim(ocean_filename), exist=fileExists ) if(.not. fileExists)then - call endrun("oslo_control: can not find ocean file "//trim(ocean_filepath)//'/'//trim(ocean_filename)) + call endrun("oslo_aero_control: can not find ocean file "//trim(ocean_filepath)//'/'//trim(ocean_filename)) else write(iulog,*)"Reading ocean tracers from : " // trim(ocean_filepath)//'/'//trim(ocean_filename) endif ! Error check for dms_source from namelist if (dms_source=='ocean_flux')then - if (index_x2a_Faoo_fdms_ocn == 0) then - call endrun("cam_oslo: dms source set to "//trim(dms_source)//" but bgc is off") - else + ! TODO: need to reimplement this so that index_x2a_Faoo_fdms is not used - this is only valid for mct + ! if (index_x2a_Faoo_fdms_ocn == 0) then + ! call endrun("cam_oslo: dms source set to "//trim(dms_source)//" but bgc is off") + ! else + ! write(iulog,*)"DMS emission source is : "// trim(dms_source) + ! endif + elseif (dms_source=='kettle' .or. dms_source=='lana' .or. dms_source=='emission_file')then + if (masterproc) then write(iulog,*)"DMS emission source is : "// trim(dms_source) - endif - elseif(dms_source=='kettle' .or. dms_source=='lana' .or. dms_source=='emission_file')then - write(iulog,*)"DMS emission source is : "// trim(dms_source) + end if else - call endrun("oslo_control: no valid dms source from namelist: " //trim(dms_source)) + call endrun("oslo_aero_control: no valid dms source from namelist: " //trim(dms_source)) endif ! Error check for opom_source from namelist if(opom_source=='no_file' .or. opom_source=='nilsson' .or. opom_source=='odowd')then write(iulog,*)"Ocean POM emission source is : "// trim(opom_source) else - call endrun("oslo_control: no valid opom source from namelist: " //trim(opom_source)) + call endrun("oslo_aero_control: no valid opom source from namelist: " //trim(opom_source)) endif - end subroutine oslo_ctl_readnl + end subroutine oslo_aero_ctl_readnl - subroutine oslo_getopts(volc_fraction_coarse_out, & + !========================================================================== + subroutine oslo_aero_getopts( & + volc_fraction_coarse_out, & aerotab_table_dir_out, & dms_source_out, & dms_source_type_out, & @@ -156,17 +163,16 @@ subroutine oslo_getopts(volc_fraction_coarse_out, & ! Purpose: Return runtime settings !----------------------------------------------------------------------- - real(r8), intent(out), optional :: volc_fraction_coarse_out - character(len=dir_string_length), intent(out), optional :: aerotab_table_dir_out - - character(len=dir_string_length), intent(out), optional :: ocean_filename_out - character(len=dir_string_length), intent(out), optional :: ocean_filepath_out - character(len=20), intent(out), optional :: dms_source_out - character(len=32), intent(out), optional :: dms_source_type_out - integer , intent(out), optional :: dms_cycle_year_out - character(len=20), intent(out), optional :: opom_source_out - character(len=32), intent(out), optional :: opom_source_type_out - integer , intent(out), optional :: opom_cycle_year_out + real(r8) , intent(out), optional :: volc_fraction_coarse_out + character(len=dir_string_length) , intent(out), optional :: aerotab_table_dir_out + character(len=dir_string_length) , intent(out), optional :: ocean_filename_out + character(len=dir_string_length) , intent(out), optional :: ocean_filepath_out + character(len=20) , intent(out), optional :: dms_source_out + character(len=32) , intent(out), optional :: dms_source_type_out + integer , intent(out), optional :: dms_cycle_year_out + character(len=20) , intent(out), optional :: opom_source_out + character(len=32) , intent(out), optional :: opom_source_type_out + integer , intent(out), optional :: opom_cycle_year_out if ( present(volc_fraction_coarse_out ) ) volc_fraction_coarse_out = volc_fraction_coarse if ( present(aerotab_table_dir_out ) ) aerotab_table_dir_out = aerotab_table_dir @@ -178,6 +184,7 @@ subroutine oslo_getopts(volc_fraction_coarse_out, & if ( present(opom_source_out ) ) opom_source_out = opom_source if ( present(opom_source_type_out ) ) opom_source_type_out= opom_source_type if ( present(opom_cycle_year_out ) ) opom_cycle_year_out = opom_cycle_year - end subroutine oslo_getopts -end module oslo_control + end subroutine oslo_aero_getopts + +end module oslo_aero_control diff --git a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 index deaaa93a18..36b665c86f 100644 --- a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 @@ -5,10 +5,10 @@ module oslo_aero_logn_tables use cam_logfile, only: iulog use spmd_utils, only: masterproc ! - use oslo_control, only: oslo_getopts,dir_string_length - use commondefinitions, only: nmodes, nbmodes + use oslo_aero_control, only: oslo_aero_getopts,dir_string_length use oslo_aero_sw_tables, only: cate, fac, faq, fbc, cat use oslo_aero_linear_interp, only: lininterpol3dim, lininterpol4dim + use commondefinitions, only: nmodes, nbmodes use aerosoldef implicit none @@ -60,7 +60,7 @@ subroutine initlogn() character(len=dir_string_length) :: aerotab_table_dir ! Where are the tables stored?? - call oslo_getopts(aerotab_table_dir_out=aerotab_table_dir) + call oslo_aero_getopts(aerotab_table_dir_out=aerotab_table_dir) open(20,file=trim(aerotab_table_dir)//'/logntilp1.out' ,form='formatted',status='old') ! SO4&SOA(n/Ait) open(21,file=trim(aerotab_table_dir)//'/logntilp2.out' ,form='formatted',status='old') ! BC(n/Ait) diff --git a/src/chemistry/oslo_aero/oslo_aero_ocean.F90 b/src/chemistry/oslo_aero/oslo_aero_ocean.F90 index c2a5a135ec..e48270ab6a 100644 --- a/src/chemistry/oslo_aero/oslo_aero_ocean.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_ocean.F90 @@ -25,7 +25,7 @@ module oslo_aero_ocean use physics_buffer, only : physics_buffer_desc use tracer_data, only : trfld, trfile, trcdata_init, advance_trcdata ! - use oslo_control, only: oslo_getopts + use oslo_aero_control, only: oslo_aero_getopts implicit none private @@ -100,7 +100,7 @@ subroutine oslo_aero_ocean_getnl() in_opom_data_source = opom_source ! Read namelist. - call oslo_getopts(dms_source_out = in_dms_data_source, & + call oslo_aero_getopts(dms_source_out = in_dms_data_source, & dms_source_type_out = in_dms_data_type, & dms_cycle_year_out = in_dms_cycle_yr, & opom_source_out = in_opom_data_source, & diff --git a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 index 12eaec4eec..b9720790f5 100644 --- a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 @@ -40,9 +40,9 @@ module oslo_aero_sw_tables use ppgrid , only: pcols, pver use cam_logfile , only: iulog ! - use commondefinitions , only: nmodes, nbmodes - use oslo_control , only: oslo_getopts, dir_string_length + use oslo_aero_control , only: oslo_aero_getopts, dir_string_length use oslo_aero_linear_interp , only: lininterpol3dim, lininterpol4dim, lininterpol5dim + use commondefinitions , only: nmodes, nbmodes implicit none private @@ -119,8 +119,6 @@ subroutine initopt() ! by Alf Kirkevaag in December 2013, and for SOA in August 2015. !--------------------------------------------------------------- - use oslo_control, only : oslo_getopts, dir_string_length - ! Local variables integer :: kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq, i, irf integer :: ifombg, ifbcbg @@ -197,7 +195,7 @@ subroutine initopt() end do end do - call oslo_getopts(aerotab_table_dir_out= aerotab_table_dir) + call oslo_aero_getopts(aerotab_table_dir_out= aerotab_table_dir) ! Opening the 'kcomp'-files: @@ -562,7 +560,7 @@ subroutine initopt_lw real(r8) :: eps7 = 1.e-7_r8 character(len=dir_string_length) :: aerotab_table_dir - call oslo_getopts(aerotab_table_dir_out = aerotab_table_dir) + call oslo_aero_getopts(aerotab_table_dir_out = aerotab_table_dir) open(40,file=trim(aerotab_table_dir)//'/lwkcomp1.out' ,form="formatted",status="old") open(41,file=trim(aerotab_table_dir)//'/lwkcomp2.out' ,form="formatted",status="old") diff --git a/src/control/runtime_opts.F90 b/src/control/runtime_opts.F90 index 53b36d061f..daffce8c4f 100644 --- a/src/control/runtime_opts.F90 +++ b/src/control/runtime_opts.F90 @@ -39,7 +39,7 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) use physics_buffer, only: pbuf_readnl use phys_control, only: phys_ctl_readnl #ifdef OSLO_AERO - use oslo_control, only: oslo_ctl_readnl + use oslo_aero_control, only: oslo_aero_ctl_readnl #endif use wv_saturation, only: wv_sat_readnl use ref_pres, only: ref_pres_readnl @@ -184,7 +184,7 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) call metdata_readnl(nlfilename) #endif #if (defined OSLO_AERO) - call oslo_ctl_readnl(nlfilename) + call oslo_aero_ctl_readnl(nlfilename) #endif call offline_driver_readnl(nlfilename) call analytic_ic_readnl(nlfilename) diff --git a/src/physics/cam_oslo/radiation.F90 b/src/physics/cam_oslo/radiation.F90 index 4089e4fd78..a3e699a0ef 100644 --- a/src/physics/cam_oslo/radiation.F90 +++ b/src/physics/cam_oslo/radiation.F90 @@ -42,10 +42,11 @@ module radiation use error_messages, only: handle_err use perf_mod, only: t_startf, t_stopf use cam_logfile, only: iulog - use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands - ! - use oslo_aero_optical_params, only: oslo_aero_optical_params_calc - use commondefinitions, only: nmodes, nbmodes +#ifdef OSLO_AERO + use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands + use oslo_aero_optical_params, only: oslo_aero_optical_params_calc + use commondefinitions, only: nmodes, nbmodes +#endif implicit none private @@ -142,7 +143,9 @@ module radiation integer :: flnt_idx = 0 integer :: cldfsnow_idx = 0 integer :: cld_idx = 0 +#ifdef OSLO_AERO integer :: volc_idx = 0 +#endif character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) @@ -515,8 +518,10 @@ subroutine radiation_init(pbuf2d) end if end do +#ifdef OSLO_AERO call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') +#endif if (scm_crm_mode) then call add_default('FUS ', 1, ' ') @@ -692,7 +697,6 @@ subroutine radiation_tend( & ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. ! - ! ! 2019-05-06 A. KirkevÃ¥g: Changes for testing the ! "simple plumes" aerosols, based on NorESM1 code P. Räisänen. !----------------------------------------------------------------------- @@ -723,17 +727,21 @@ subroutine radiation_tend( & use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps - use commondefinitions - use aerosoldef use constituents, only: pcnst - use oslo_control, only: oslo_getopts +#ifdef OSLO_AERO use physics_buffer, only: pbuf_get_index + use oslo_aero_control, only: oslo_aero_getopts + use commondefinitions + use aerosoldef +#endif - real(r8) flnt_tmp(pcols) ! Net outgoing lw flux at model top for AIE calculations - real(r8) volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode - integer :: band +#ifdef OSLO_AERO + real(r8) :: flnt_tmp(pcols) ! Net outgoing lw flux at model top for AIE calculations + real(r8) :: volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode + integer :: band character(len=3) :: c3 - logical idrf + logical :: idrf +#endif ! Arguments type(physics_state), intent(in), target :: state @@ -756,8 +764,10 @@ subroutine radiation_tend( & integer :: lchnk, ncol logical :: dosw, dolw +#ifdef OSLO_AERO real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) +#endif real(r8) :: calday ! current calendar day real(r8) :: delta ! Solar declination angle in radians real(r8) :: eccf ! Earth orbit eccentricity factor @@ -843,36 +853,37 @@ subroutine radiation_tend( & real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) - +#ifdef OSLO_AERO ! Local variables used for calculating aerosol optics and direct and indirect forcings. ! aodvis and absvis are AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values - real(r8) qdirind(pcols,pver,pcnst) ! Common tracers for indirect and direct calculations - real(r8) aodvis(pcols) ! AOD vis - real(r8) absvis(pcols) ! absorptive AOD vis - real(r8) clearodvis(pcols), clearabsvis(pcols), cloudfree(pcols), cloudfreemax(pcols) - ! AEROCOM beg - real(r8) dod440(pcols),dod550(pcols),dod870(pcols),abs550(pcols),abs550alt(pcols) - real(r8) clearod440(pcols),clearod550(pcols),clearod870(pcols),clearabs550(pcols),clearabs550alt(pcols) - ! AEROCOM end - real(r8) ftem_1d(pcols) ! work-array to avoid NAN and pcols/ncol confusion - real(r8) Nnatk(pcols,pver,0:nmodes) ! Modal aerosol number concentration - real(r8) batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW - real(r8) rhoda(pcols,pver) ! air mass density, unit kg/m^3 - real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn - integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn - real(r8) :: rhtrunc(pcols,pver) ! relative humidity (as fraction) - real(r8) :: per_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth - real(r8) :: per_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8) :: per_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau - real(r8) :: per_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau - real(r8) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) - integer ns ! spectral loop index - real(r8) :: volc_ext_sun(pcols,pver,nswbands) ! volcanic aerosol extinction for solar bands, CMIP6 - real(r8) :: volc_omega_sun(pcols,pver,nswbands) ! volcanic aerosol SSA for solar bands, CMIP6 - real(r8) :: volc_g_sun(pcols,pver,nswbands) ! volcanic aerosol g for solar bands, CMIP6 - real(r8) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 + real(r8) :: qdirind(pcols,pver,pcnst) ! Common tracers for indirect and direct calculations + real(r8) :: aodvis(pcols) ! AOD vis + real(r8) :: absvis(pcols) ! absorptive AOD vis + real(r8) :: clearodvis(pcols), clearabsvis(pcols), cloudfree(pcols), cloudfreemax(pcols) +#ifdef AEROCOM + real(r8) :: dod440(pcols),dod550(pcols),dod870(pcols),abs550(pcols),abs550alt(pcols) + real(r8) :: clearod440(pcols),clearod550(pcols),clearod870(pcols),clearabs550(pcols),clearabs550alt(pcols) +#endif + real(r8) :: ftem_1d(pcols) ! work-array to avoid NAN and pcols/ncol confusion + real(r8) :: Nnatk(pcols,pver,0:nmodes) ! Modal aerosol number concentration + real(r8) :: batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW + real(r8) :: rhoda(pcols,pver) ! air mass density, unit kg/m^3 + real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn + integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn + real(r8) :: rhtrunc(pcols,pver) ! relative humidity (as fraction) + real(r8) :: per_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth + real(r8) :: per_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau + real(r8) :: per_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8) :: per_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau + real(r8) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + integer :: ns ! spectral loop index + real(r8) :: volc_ext_sun(pcols,pver,nswbands) ! volcanic aerosol extinction for solar bands, CMIP6 + real(r8) :: volc_omega_sun(pcols,pver,nswbands) ! volcanic aerosol SSA for solar bands, CMIP6 + real(r8) :: volc_g_sun(pcols,pver,nswbands) ! volcanic aerosol g for solar bands, CMIP6 + real(r8) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 real(r8) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 +#endif real(r8) :: fns(pcols,pverp) ! net shortwave flux real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux @@ -897,11 +908,13 @@ subroutine radiation_tend( & lchnk = state%lchnk ncol = state%ncol +#ifdef OSLO_AERO per_lw_abs(:,:,:)=0._r8 per_tau(:,:,:)=0._r8 per_tau_w(:,:,:)=0._r8 per_tau_w_g(:,:,:)=0._r8 per_tau_w_f(:,:,:)=0._r8 +#endif if (present(rd_out)) then rd => rd_out @@ -968,13 +981,15 @@ subroutine radiation_tend( & end do end if +#ifdef OSLO_AERO qdirind(:ncol,:,:) = state%q(:ncol,:,:) if (has_prescribed_volcaero) then - call oslo_getopts(volc_fraction_coarse_out = volc_fraction_coarse) + call oslo_aero_getopts(volc_fraction_coarse_out = volc_fraction_coarse) call pbuf_get_field(pbuf, volc_idx, rvolcmmr, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) qdirind(:ncol,:,l_so4_pr) = qdirind(:ncol,:,l_so4_pr) + (1.0_r8 - volc_fraction_coarse)*rvolcmmr(:ncol,:) qdirind(:ncol,:,l_ss_a3) = qdirind(:ncol,:,l_ss_a3) + volc_fraction_coarse*rvolcmmr(:ncol,:) end if +#endif ! Find tropopause height if needed for diagnostic output if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then @@ -1147,16 +1162,8 @@ subroutine radiation_tend( & if (dosw) then - !TEST - ! qdirind(:ncol,:,l_soa_a1) = 0.0_r8 - ! qdirind(:ncol,:,l_soa_na) = 0.0_r8 - ! qdirind(:ncol,:,l_so4_a1) = 0.0_r8 - ! qdirind(:ncol,:,l_so4_na) = 0.0_r8 - !TEST - !cak+ Calculate CAM5-Oslo/NorESM2 aerosol optical parameters - ! (move to aer_rad_props.F90? No, then it cannot be called for night-time calculations...) - ! - ! Volcanic optics for solar (SW) bands +#ifdef OSLO_AERO + ! Volcanic optics for solar (SW) bands do band=1, solar_bands volc_ext_sun(1:ncol,1:pver,band)=0.0_r8 volc_omega_sun(1:ncol,1:pver,band)=0.999_r8 @@ -1202,6 +1209,7 @@ subroutine radiation_tend( & volc_ext_sun, volc_omega_sun, volc_g_sun, volc_ext_earth, volc_omega_earth, & aodvis, absvis) +#endif call get_variability(sfac) ! Get the active climate/diagnostic shortwave calculations @@ -1215,6 +1223,7 @@ subroutine radiation_tend( & ! update the concentrations in the RRTMG state object call rrtmg_state_update(state, pbuf, icall, r_state) +#ifdef OSLO_AERO !call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & ! aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) ! A first call with Oslo aerosols set to zero for radiative forcing diagnostics @@ -1259,29 +1268,46 @@ subroutine radiation_tend( & call outfld('FSDSCDRF',rd%fsdsc(:) ,pcols,lchnk) end if idrf = .false. +#else + call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & + aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) +#endif rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) - ! Then the usual call with Oslo aerosols for radiative forcing diagnostics - +#ifdef OSLO_AERO call rad_rrtmg_sw( & lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & + cldfprime, per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & eccf, coszrs, rd%solin, sfac, cam_in%asdir, & cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & ! Note the extra idrf IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) +#else + call rad_rrtmg_sw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + cldfprime, aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & + eccf, coszrs, rd%solin, sfac, cam_in%asdir, & + cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & + fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & + rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & + rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & + cam_out%solld, fns, fcns, Nday, Nnite, & + IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & + E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & + E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) +#endif ! Output net fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) if (hist_fld_active('FSNR')) then @@ -1289,17 +1315,19 @@ subroutine radiation_tend( & call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) end do end if + if (write_output) call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) + end if end do end if +#ifdef OSLO_AERO !Calculate cloud-free fraction assuming random overlap !(kind of duplicated from cloud_cover_diags::cldsav) cloudfree(1:ncol) = 1.0_r8 cloudfreemax(1:ncol) = 1.0_r8 - !Find cloud-free fraction (note this duplicated code and may not be consistent with cldtot calculated elsewhere) do k = 1, pver do i=1,ncol @@ -1313,11 +1341,13 @@ subroutine radiation_tend( & clearodvis(i)=cloudfree(i)*aodvis(i) clearabsvis(i)=cloudfree(i)*absvis(i) end do + ! clear-sky AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) ! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values call outfld('CAODVIS ',clearodvis,pcols,lchnk) call outfld('CABSVIS ',clearabsvis,pcols,lchnk) call outfld('CLDFREE ',cloudfree,pcols,lchnk) +#ifdef AEROCOM if (do_aerocom) then do i = 1, ncol clearod440(i)=cloudfree(i)*dod440(i) @@ -1332,6 +1362,8 @@ subroutine radiation_tend( & call outfld('CABS550 ',clearabs550 ,pcols,lchnk) call outfld('CABS550A',clearabs550alt,pcols,lchnk) end if +#endif +#endif ! Output aerosol mmr call rad_cnst_out(0, state, pbuf) @@ -1354,6 +1386,7 @@ subroutine radiation_tend( & ! for calculation of direct and direct radiative forcing +#ifdef OSLO_AERO call rad_rrtmg_lw( & lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & per_lw_abs*0.0_r8, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & @@ -1374,6 +1407,14 @@ subroutine radiation_tend( & ! FLNT_ORG is just for temporary testing vs. FLNT ftem_1d(1:ncol) = cam_out%flwds(1:ncol) - flns(1:ncol) call outfld('FLUS ',ftem_1d ,pcols,lchnk) +#else + call rad_rrtmg_lw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + aer_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & + flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & + rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & + lu, ld) +#endif ! Output fluxes at 200 mb call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) diff --git a/src/physics/cam_oslo/radlw.F90 b/src/physics/cam_oslo/radlw.F90 index 59fa3d641c..5d29c2198c 100644 --- a/src/physics/cam_oslo/radlw.F90 +++ b/src/physics/cam_oslo/radlw.F90 @@ -229,10 +229,16 @@ subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & fsul(:ncol,pverp-rrtmg_levs+1:pverp)=uflxc(:ncol,rrtmg_levs:1:-1) fsdl(:ncol,pverp-rrtmg_levs+1:pverp)=dflxc(:ncol,rrtmg_levs:1:-1) +#ifndef OSLO_AERO + if (single_column.and.scm_crm_mode) then +#endif call outfld('FUL ',ful,pcols,lchnk) call outfld('FDL ',fdl,pcols,lchnk) call outfld('FULC ',fsul,pcols,lchnk) call outfld('FDLC ',fsdl,pcols,lchnk) +#ifndef OSLO_AERO + endif +#endif fnl(:ncol,:) = ful(:ncol,:) - fdl(:ncol,:) ! mji/ cam excluded this? diff --git a/src/physics/cam_oslo/radsw.F90 b/src/physics/cam_oslo/radsw.F90 index 25bab39646..165fa7a931 100644 --- a/src/physics/cam_oslo/radsw.F90 +++ b/src/physics/cam_oslo/radsw.F90 @@ -49,7 +49,11 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & qrs ,qrsc ,fsnt ,fsntc ,fsntoa,fsutoa, & fsntoac ,fsnirtoa ,fsnrtoac ,fsnrtoaq ,fsns , & fsnsc ,fsdsc ,fsds ,sols ,soll , & +#ifdef OSLO_AERO solsd ,solld ,fns ,fcns ,idrf , & +#else + solsd ,solld ,fns ,fcns , & +#endif Nday ,Nnite ,IdxDay ,IdxNite , & su ,sd , & E_cld_tau, E_cld_tau_w, E_cld_tau_w_g, E_cld_tau_w_f, & @@ -160,6 +164,10 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & real(r8), intent(out) :: fns(pcols,pverp) ! net flux at interfaces real(r8), intent(out) :: fcns(pcols,pverp) ! net clear-sky flux at interfaces +#ifdef OSLO_AERO + logical, intent(in) :: idrf +#endif + real(r8), pointer, dimension(:,:,:) :: su ! shortwave spectral flux up real(r8), pointer, dimension(:,:,:) :: sd ! shortwave spectral flux down @@ -264,8 +272,6 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & real(r8) :: fusc(pcols,pverp) ! Upward clear-sky flux (added for CRM) real(r8) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM) - logical, intent(in) :: idrf - integer :: kk real(r8) :: pmidmb(pcols,rrtmg_levs) ! Level pressure (hPa) @@ -306,10 +312,17 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & qrsc(1:ncol,1:pver) = 0.0_r8 fns(1:ncol,1:pverp) = 0.0_r8 fcns(1:ncol,1:pverp) = 0.0_r8 + +#ifndef OSLO_AERO + if (single_column.and.scm_crm_mode) then +#endif fus(1:ncol,1:pverp) = 0.0_r8 fds(1:ncol,1:pverp) = 0.0_r8 fusc(:ncol,:pverp) = 0.0_r8 fdsc(:ncol,:pverp) = 0.0_r8 +#ifndef OSLO_AERO + endif +#endif if (associated(su)) su(1:ncol,:,:) = 0.0_r8 if (associated(sd)) sd(1:ncol,:,:) = 0.0_r8 @@ -622,20 +635,28 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & end if ! these outfld calls don't work for spmd only outfield in scm mode (nonspmd) - ! Following outputs added for CRM + ! Following outputs added for CRM +#ifndef OSLO_AERO + if (single_column .and. scm_crm_mode) then +#endif call ExpDayNite(fus,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call outfld('FUS ', fus, pcols, lchnk) - call outfld('FUSC ', fusc, pcols, lchnk) call ExpDayNite(fds,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call outfld('FUS ', fus, pcols, lchnk) + call outfld('FUSC ', fusc, pcols, lchnk) call outfld('FDS ', fds, pcols, lchnk) call outfld('FDSC ', fdsc, pcols, lchnk) +#ifndef OSLO_AERO + end if +#endif - if(idrf) then +#ifdef OSLO_AERO + if (idrf) then call outfld('FUSCDRF ', fusc, pcols, lchnk) call outfld('FDSCDRF ', fdsc, pcols, lchnk) endif +#endif end subroutine rad_rrtmg_sw From d00ab8e6993037b87b8c30155969d839384bcb37 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 3 Sep 2023 16:55:06 +0200 Subject: [PATCH 44/71] moved refactored radation to physics/rrtmg --- src/physics/cam_oslo/radiation.F90 | 1702 ---------------- src/physics/cam_oslo/radlw.F90 | 308 --- src/physics/cam_oslo/radsw.F90 | 687 ------- src/physics/rrtmg/radiation.F90 | 2936 +++++++++++++++------------- src/physics/rrtmg/radlw.F90 | 6 + src/physics/rrtmg/radsw.F90 | 32 +- 6 files changed, 1639 insertions(+), 4032 deletions(-) delete mode 100644 src/physics/cam_oslo/radiation.F90 delete mode 100644 src/physics/cam_oslo/radlw.F90 delete mode 100644 src/physics/cam_oslo/radsw.F90 diff --git a/src/physics/cam_oslo/radiation.F90 b/src/physics/cam_oslo/radiation.F90 deleted file mode 100644 index a3e699a0ef..0000000000 --- a/src/physics/cam_oslo/radiation.F90 +++ /dev/null @@ -1,1702 +0,0 @@ -module radiation - - !--------------------------------------------------------------------------------- - ! - ! CAM interface to RRTMG radiation parameterization - ! - !--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8=>shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, pverp, begchunk, endchunk - use physics_types, only: physics_state, physics_ptend - use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx - use camsrfexch, only: cam_out_t, cam_in_t - use physconst, only: cappa, cpair - - use time_manager, only: get_nstep, is_first_restart_step, & - get_curr_calday, get_step_size - - use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_info, & - rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & - liqcldoptics, icecldoptics - - use radconstants, only: nswbands, nlwbands, rrtmg_sw_cloudsim_band, rrtmg_lw_cloudsim_band, & - idx_sw_diag - - use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & - cospsimulator_intr_run, cosp_nradsteps - - use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs - - use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active - use cam_history_support, only: fillvalue - - use pio, only: file_desc_t, var_desc_t, & - pio_int, pio_noerr, & - pio_seterrorhandling, pio_bcast_error, & - pio_inq_varid, pio_def_var, & - pio_put_var, pio_get_var - - use cam_abortutils, only: endrun - use error_messages, only: handle_err - use perf_mod, only: t_startf, t_stopf - use cam_logfile, only: iulog -#ifdef OSLO_AERO - use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands - use oslo_aero_optical_params, only: oslo_aero_optical_params_calc - use commondefinitions, only: nmodes, nbmodes -#endif - - implicit none - private - - public :: & - radiation_readnl, &! read namelist variables - radiation_register, &! registers radiation physics buffer fields - radiation_nextsw_cday, &! calendar day of next radiation calculation - radiation_do, &! query which radiation calcs are done this timestep - radiation_init, &! initialization - radiation_define_restart, &! define variables for restart - radiation_write_restart, &! write variables to restart - radiation_read_restart, &! read variables from restart - radiation_tend, &! compute heating rates and fluxes - rad_out_t ! type for diagnostic outputs - - integer,public, allocatable :: cosp_cnt(:) ! counter for cosp - integer,public :: cosp_cnt_init = 0 !initial value for cosp counter - - type rad_out_t - - real(r8) :: solin(pcols) ! Solar incident flux - - real(r8) :: qrsc(pcols,pver) - - real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux - real(r8) :: fsntoa(pcols) ! Net solar flux at TOA - real(r8) :: fsntoac(pcols) ! Clear sky net solar flux at TOA - real(r8) :: fsutoa(pcols) ! upwelling solar flux at TOA - - real(r8) :: fsnirt(pcols) ! Near-IR flux absorbed at toa - real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa - real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns - - real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb - real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb - real(r8) :: fsnr(pcols) ! fns interpolated to tropopause - - real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux - real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux - - real(r8) :: qrlc(pcols,pver) - - real(r8) :: flntc(pcols) ! Clear sky lw flux at model top - real(r8) :: flut(pcols) ! Upward flux at top of model - real(r8) :: flutc(pcols) ! Upward Clear Sky flux at top of model - real(r8) :: lwcf(pcols) ! longwave cloud forcing - - real(r8) :: fln200(pcols) ! net longwave flux interpolated to 200 mb - real(r8) :: fln200c(pcols) ! net clearsky longwave flux interpolated to 200 mb - real(r8) :: flnr(pcols) ! net longwave flux interpolated to tropopause - - real(r8) :: flnsc(pcols) ! Clear sky lw flux at srf (up-down) - real(r8) :: fldsc(pcols) ! Clear sky lw flux at srf (down) - - real(r8) :: tot_cld_vistau(pcols,pver) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: tot_icld_vistau(pcols,pver) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth (only during day, night = fillvalue) - real(r8) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth for output on history files - - real(r8) :: cld_tau_cloudsim(pcols,pver) - real(r8) :: aer_tau400(pcols,0:pver) - real(r8) :: aer_tau550(pcols,0:pver) - real(r8) :: aer_tau700(pcols,0:pver) - - end type rad_out_t - - ! Namelist variables - - integer :: iradsw = -1 ! freq. of shortwave radiation calc in time steps (positive) - ! or hours (negative). - integer :: iradlw = -1 ! frequency of longwave rad. calc. in time steps (positive) - ! or hours (negative). - - integer :: irad_always = 0 ! Specifies length of time in timesteps (positive) - ! or hours (negative) SW/LW radiation will be - ! run continuously from the start of an - ! initial or restart run - logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations - logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. - - ! Physics buffer indices - integer :: qrs_idx = 0 - integer :: qrl_idx = 0 - integer :: su_idx = 0 - integer :: sd_idx = 0 - integer :: lu_idx = 0 - integer :: ld_idx = 0 - integer :: fsds_idx = 0 - integer :: fsns_idx = 0 - integer :: fsnt_idx = 0 - integer :: flns_idx = 0 - integer :: flnt_idx = 0 - integer :: cldfsnow_idx = 0 - integer :: cld_idx = 0 -#ifdef OSLO_AERO - integer :: volc_idx = 0 -#endif - - character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) - - ! averaging time interval for zenith angle - real(r8) :: dt_avg = 0._r8 - - ! PIO descriptors (for restarts) - type(var_desc_t) :: cospcnt_desc - -#ifdef AEROCOM - logical :: do_aerocom = .true. -#else - logical :: do_aerocom = .false. -#endif - -!=============================================================================== -contains -!=============================================================================== - - subroutine radiation_readnl(nlfile) - - ! Read radiation_nl namelist group. - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - integer :: dtime ! timestep size - character(len=*), parameter :: sub = 'radiation_readnl' - - namelist /radiation_nl/ iradsw, iradlw, irad_always, & - use_rad_dt_cosz, spectralflux - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'radiation_nl', status=ierr) - if (ierr == 0) then - read(unitn, radiation_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if - - ! Broadcast namelist variables - call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradsw") - call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradlw") - call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: irad_always") - call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_dt_cosz") - call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: spectralflux") - - ! Convert iradsw, iradlw and irad_always from hours to timesteps if necessary - dtime = get_step_size() - if (iradsw < 0) iradsw = nint((-iradsw *3600._r8)/dtime) - if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) - if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) - - !----------------------------------------------------------------------- - ! Print runtime options to log. - !----------------------------------------------------------------------- - - if (masterproc) then - write(iulog,*) 'RRTMG radiation scheme parameters:' - write(iulog,10) iradsw, iradlw, irad_always, use_rad_dt_cosz, spectralflux - end if - -10 format(' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & - ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & - ' SW/LW calc done every timestep for first N steps. N=',i5/, & - ' Use average zenith angle: ',l5/, & - ' Output spectrally resolved fluxes: ',l5/) - - end subroutine radiation_readnl - - !================================================================================================ - - subroutine radiation_register - - ! Register radiation fields in the physics buffer - - use physics_buffer, only: pbuf_add_field, dtype_r8 - use radiation_data, only: rad_data_register - - call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate - call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate - - call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux - call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux - call pbuf_add_field('FSNT' , 'global',dtype_r8,(/pcols/), fsnt_idx) ! Top-of-model net shortwave flux - - call pbuf_add_field('FLNS' , 'global',dtype_r8,(/pcols/), flns_idx) ! Surface net longwave flux - call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux - - ! If the namelist has been configured for preserving the spectral fluxes, then create - ! physics buffer variables to store the results. - if (spectralflux) then - call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) - call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) - call pbuf_add_field('LU' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), lu_idx) ! longwave upward flux (per band) - call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) - end if - - call rad_data_register() - - end subroutine radiation_register - - !================================================================================================ - - function radiation_do(op, timestep) - - ! Return true if the specified operation is done this timestep. - - character(len=*), intent(in) :: op ! name of operation - integer, intent(in), optional:: timestep - logical :: radiation_do ! return value - - ! Local variables - integer :: nstep ! current timestep number - !----------------------------------------------------------------------- - - if (present(timestep)) then - nstep = timestep - else - nstep = get_nstep() - end if - - select case (op) - - case ('sw') ! do a shortwave heating calc this timestep? - radiation_do = nstep == 0 .or. iradsw == 1 & - .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - case ('lw') ! do a longwave heating calc this timestep? - radiation_do = nstep == 0 .or. iradlw == 1 & - .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - case default - call endrun('radiation_do: unknown operation:'//op) - - end select - end function radiation_do - - !================================================================================================ - - real(r8) function radiation_nextsw_cday() - - ! Return calendar day of next sw radiation calculation - - ! Local variables - integer :: nstep ! timestep counter - logical :: dosw ! true => do shosrtwave calc - integer :: offset ! offset for calendar day calculation - integer :: dTime ! integer timestep size - real(r8):: calday ! calendar day of - !----------------------------------------------------------------------- - - radiation_nextsw_cday = -1._r8 - dosw = .false. - nstep = get_nstep() - dtime = get_step_size() - offset = 0 - do while (.not. dosw) - nstep = nstep + 1 - offset = offset + dtime - if (radiation_do('sw', nstep)) then - radiation_nextsw_cday = get_curr_calday(offset=offset) - dosw = .true. - end if - end do - if(radiation_nextsw_cday == -1._r8) then - call endrun('error in radiation_nextsw_cday') - end if - - end function radiation_nextsw_cday - - !================================================================================================ - - subroutine radiation_init(pbuf2d) - - ! Initialize the radiation parameterization, add fields to the history buffer - - use physics_buffer, only: pbuf_get_index, pbuf_set_field - use phys_control, only: phys_getopts - use radsw, only: radsw_init - use radlw, only: radlw_init - use rad_solar_var, only: rad_solar_var_init - use radiation_data, only: rad_data_init - use cloud_rad_props, only: cloud_rad_props_init - use modal_aer_opt, only: modal_aer_opt_init - use rrtmg_state, only: rrtmg_state_init - use time_manager, only: is_first_step - - - ! arguments - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local variables - integer :: icall, nmodes - logical :: active_calls(0:N_DIAG) - integer :: nstep ! current timestep number - logical :: history_amwg ! output the variables used by the AMWG diag package - logical :: history_vdiag ! output the variables used by the AMWG variability diag package - logical :: history_budget ! output tendencies and state variables for CAM4 - ! temperature, water vapor, cloud ice and cloud - ! liquid budgets. - integer :: history_budget_histfile_num ! output history file number for budget fields - integer :: err - - integer :: dtime - !----------------------------------------------------------------------- - - call rad_solar_var_init() - call rrtmg_state_init() - call rad_data_init(pbuf2d) ! initialize output fields for offline driver - call radsw_init() - call radlw_init() - call cloud_rad_props_init() - - cld_idx = pbuf_get_index('CLD') - cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err) - - if (is_first_step()) then - call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) - end if - - - ! Set the radiation timestep for cosz calculations if requested using the adjusted iradsw value from radiation - if (use_rad_dt_cosz) then - dtime = get_step_size() - dt_avg = iradsw*dtime - end if - - call phys_getopts(history_amwg_out = history_amwg, & - history_vdiag_out = history_vdiag, & - history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num) - - ! Determine whether modal aerosols are affecting the climate, and if so - ! then initialize the modal aerosol optics module - call rad_cnst_get_info(0, nmodes=nmodes) - if (nmodes > 0) call modal_aer_opt_init() - - ! "irad_always" is number of time steps to execute radiation continuously from start of - ! initial OR restart run - nstep = get_nstep() - if (irad_always > 0) then - nstep = get_nstep() - irad_always = irad_always + nstep - end if - - if (docosp) call cospsimulator_intr_init - - allocate(cosp_cnt(begchunk:endchunk)) - if (is_first_restart_step()) then - cosp_cnt(begchunk:endchunk) = cosp_cnt_init - else - cosp_cnt(begchunk:endchunk) = 0 - end if - - call addfld('O3colAbove', horiz_only, 'A', 'DU', 'Column O3 above model top', sampling_seq='rad_lwsw') - - call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total gbx cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('TOT_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('LIQ_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Liquid in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('ICE_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Ice in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - - if (cldfsnow_idx > 0) then - call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Snow in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - endif - - ! get list of active radiation calls - call rad_cnst_get_call_list(active_calls) - - ! Add shortwave radiation fields to history master field list. - - do icall = 0, N_DIAG - - if (active_calls(icall)) then - - call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') - - call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') - call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & - sampling_seq='rad_lwsw') - call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & - sampling_seq='rad_lwsw') - call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') - - call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - - call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & - sampling_seq='rad_lwsw') - - call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') - call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') - call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') - call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') - - if (history_amwg) then - call add_default('SOLIN'//diag(icall), 1, ' ') - call add_default('QRS'//diag(icall), 1, ' ') - call add_default('FSNT'//diag(icall), 1, ' ') - call add_default('FSNTC'//diag(icall), 1, ' ') - call add_default('FSNTOA'//diag(icall), 1, ' ') - call add_default('FSNTOAC'//diag(icall), 1, ' ') - call add_default('SWCF'//diag(icall), 1, ' ') - call add_default('FSNS'//diag(icall), 1, ' ') - call add_default('FSNSC'//diag(icall), 1, ' ') - call add_default('FSUTOA'//diag(icall), 1, ' ') - call add_default('FSDSC'//diag(icall), 1, ' ') - call add_default('FSDS'//diag(icall), 1, ' ') - endif - - end if - end do - -#ifdef OSLO_AERO - call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') - call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') -#endif - - if (scm_crm_mode) then - call add_default('FUS ', 1, ' ') - call add_default('FUSC ', 1, ' ') - call add_default('FDS ', 1, ' ') - call add_default('FDSC ', 1, ' ') - endif - - ! Add longwave radiation fields to history master field list. - - do icall = 0, N_DIAG - - if (active_calls(icall)) then - - call addfld('QRL'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Longwave heating rate', sampling_seq='rad_lwsw') - call addfld('QRLC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky longwave heating rate', & - sampling_seq='rad_lwsw') - call addfld('FLNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLNTCLR'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky ONLY points net longwave flux at top of model',& - sampling_seq='rad_lwsw') - call addfld('FREQCLR'//diag(icall), horiz_only, 'A', 'Frac', 'Frequency of Occurrence of Clearsky', & - sampling_seq='rad_lwsw') - call addfld('FLUT'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLUTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky upwelling longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('LWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Longwave cloud forcing', sampling_seq='rad_lwsw') - - call addfld('FLN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FLN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FLNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at tropopause', & - sampling_seq='rad_lwsw') - - call addfld('FLNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky Downwelling longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FUL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave upward flux') - call addfld('FDL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave downward flux') - call addfld('FULC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky upward flux') - call addfld('FDLC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky downward flux') - - if (history_amwg) then - call add_default('QRL'//diag(icall), 1, ' ') - call add_default('FLNT'//diag(icall), 1, ' ') - call add_default('FLNTC'//diag(icall), 1, ' ') - call add_default('FLNTCLR'//diag(icall), 1, ' ') - call add_default('FREQCLR'//diag(icall), 1, ' ') - call add_default('FLUT'//diag(icall), 1, ' ') - call add_default('FLUTC'//diag(icall), 1, ' ') - call add_default('LWCF'//diag(icall), 1, ' ') - call add_default('FLNS'//diag(icall), 1, ' ') - call add_default('FLNSC'//diag(icall), 1, ' ') - call add_default('FLDS'//diag(icall), 1, ' ') - endif - - end if - end do - - call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') - - if (scm_crm_mode) then - call add_default ('FUL ', 1, ' ') - call add_default ('FULC ', 1, ' ') - call add_default ('FDL ', 1, ' ') - call add_default ('FDLC ', 1, ' ') - endif - - ! Heating rate needed for d(theta)/dt computation - call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') - - if ( history_budget .and. history_budget_histfile_num > 1 ) then - call add_default ('QRL ', history_budget_histfile_num, ' ') - call add_default ('QRS ', history_budget_histfile_num, ' ') - end if - - if (history_vdiag) then - call add_default('FLUT', 2, ' ') - call add_default('FLUT', 3, ' ') - end if - - end subroutine radiation_init - - !=============================================================================== - - subroutine radiation_define_restart(file) - - ! define variables to be written to restart file - - ! arguments - type(file_desc_t), intent(inout) :: file - - ! local variables - integer :: ierr - !---------------------------------------------------------------------------- - - call pio_seterrorhandling(File, PIO_BCAST_ERROR) - - if (docosp) then - ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) - end if - - end subroutine radiation_define_restart - - !=============================================================================== - - subroutine radiation_write_restart(file) - - ! write variables to restart file - - ! arguments - type(file_desc_t), intent(inout) :: file - - ! local variables - integer :: ierr - !---------------------------------------------------------------------------- - - if (docosp) then - ierr = pio_put_var(File, cospcnt_desc, (/cosp_cnt(begchunk)/)) - end if - - end subroutine radiation_write_restart - - !=============================================================================== - - subroutine radiation_read_restart(file) - - ! read variables from restart file - - ! arguments - type(file_desc_t), intent(inout) :: file - - ! local variables - - integer :: err_handling - integer :: ierr - - type(var_desc_t) :: vardesc - !---------------------------------------------------------------------------- - - if (docosp) then - call pio_seterrorhandling(File, PIO_BCAST_ERROR, err_handling) - ierr = pio_inq_varid(File, 'cosp_cnt_init', vardesc) - call pio_seterrorhandling(File, err_handling) - if (ierr /= PIO_NOERR) then - cosp_cnt_init = 0 - else - ierr = pio_get_var(File, vardesc, cosp_cnt_init) - end if - end if - - end subroutine radiation_read_restart - - !=============================================================================== - - subroutine radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) - - !----------------------------------------------------------------------- - ! - ! Driver for radiation computation. - ! - ! Revision history: - ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. - ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. - ! - ! 2019-05-06 A. KirkevÃ¥g: Changes for testing the - ! "simple plumes" aerosols, based on NorESM1 code P. Räisänen. - !----------------------------------------------------------------------- - - use phys_grid, only: get_rlat_all_p, get_rlon_all_p - use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr - use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz - - use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw - - use cloud_rad_props, only: get_ice_optics_sw, get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & - ice_cloud_get_rad_props_lw, cloud_rad_props_get_lw, & - snow_cloud_get_rad_props_lw, get_snow_optics_sw - use slingo, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw - use ebert_curry, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw - - use rad_solar_var, only: get_variability - use radsw, only: rad_rrtmg_sw - use radlw, only: rad_rrtmg_lw - use radheat, only: radheat_tend - - use radiation_data, only: rad_data_write - use rrtmg_state, only: rrtmg_state_create, rrtmg_state_update, rrtmg_state_destroy, rrtmg_state_t, & - num_rrtmg_levs - - use interpolate_data, only: vertinterp - use tropopause, only: tropopause_find, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE - - use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps - - use constituents, only: pcnst -#ifdef OSLO_AERO - use physics_buffer, only: pbuf_get_index - use oslo_aero_control, only: oslo_aero_getopts - use commondefinitions - use aerosoldef -#endif - -#ifdef OSLO_AERO - real(r8) :: flnt_tmp(pcols) ! Net outgoing lw flux at model top for AIE calculations - real(r8) :: volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode - integer :: band - character(len=3) :: c3 - logical :: idrf -#endif - - ! Arguments - type(physics_state), intent(in), target :: state - type(physics_ptend), intent(out) :: ptend - - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(inout) :: cam_out - type(cam_in_t), intent(in) :: cam_in - real(r8), intent(out) :: net_flx(pcols) - - type(rad_out_t), target, optional, intent(out) :: rd_out - - - ! Local variables - type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object - ! if the argument is not present - logical :: write_output - - integer :: i, k - integer :: lchnk, ncol - logical :: dosw, dolw - -#ifdef OSLO_AERO - real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr - real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) -#endif - real(r8) :: calday ! current calendar day - real(r8) :: delta ! Solar declination angle in radians - real(r8) :: eccf ! Earth orbit eccentricity factor - real(r8) :: clat(pcols) ! current latitudes(radians) - real(r8) :: clon(pcols) ! current longitudes(radians) - real(r8) :: coszrs(pcols) ! Cosine solar zenith angle - - ! Gathered indices of day and night columns - ! chunk_column_index = IdxDay(daylight_column_index) - integer :: Nday ! Number of daylight columns - integer :: Nnite ! Number of night columns - integer :: IdxDay(pcols) ! Indices of daylight columns - integer :: IdxNite(pcols) ! Indices of night columns - - integer :: itim_old - - real(r8), pointer :: cld(:,:) ! cloud fraction - real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" - real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate - real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate - real(r8), pointer :: fsds(:) ! Surface solar down flux - real(r8), pointer :: fsns(:) ! Surface solar absorbed flux - real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top - real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux - real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top - - real(r8), pointer, dimension(:,:,:) :: su => NULL() ! shortwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: sd => NULL() ! shortwave spectral flux down - real(r8), pointer, dimension(:,:,:) :: lu => NULL() ! longwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: ld => NULL() ! longwave spectral flux down - - ! tropopause diagnostic - integer :: troplev(pcols) - real(r8) :: p_trop(pcols) - - type(rrtmg_state_t), pointer :: r_state ! contains the atm concentrations in layers needed for RRTMG - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: ice_tau (nswbands,pcols,pver) ! ice extinction optical depth - real(r8) :: ice_tau_w (nswbands,pcols,pver) ! ice single scattering albedo * tau - real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice assymetry parameter * tau * w - real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! ice forward scattered fraction * tau * w - real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth - real(r8) :: liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau - real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w - real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w - real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: cld_tau (nswbands,pcols,pver) ! cloud extinction optical depth - real(r8) :: cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau - real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau - real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau - real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth - real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau - real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow assymetry parameter * tau * w - real(r8) :: snow_tau_w_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w - real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) - - ! combined cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) - real(r8) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth - real(r8) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau - real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau - real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau - real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) - - real(r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band - - integer :: icall ! index through climate/diagnostic radiation calls - logical :: active_calls(0:N_DIAG) - - ! Aerosol radiative properties - real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth - real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau - real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau - real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) - -#ifdef OSLO_AERO - ! Local variables used for calculating aerosol optics and direct and indirect forcings. - ! aodvis and absvis are AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) - ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values - real(r8) :: qdirind(pcols,pver,pcnst) ! Common tracers for indirect and direct calculations - real(r8) :: aodvis(pcols) ! AOD vis - real(r8) :: absvis(pcols) ! absorptive AOD vis - real(r8) :: clearodvis(pcols), clearabsvis(pcols), cloudfree(pcols), cloudfreemax(pcols) -#ifdef AEROCOM - real(r8) :: dod440(pcols),dod550(pcols),dod870(pcols),abs550(pcols),abs550alt(pcols) - real(r8) :: clearod440(pcols),clearod550(pcols),clearod870(pcols),clearabs550(pcols),clearabs550alt(pcols) -#endif - real(r8) :: ftem_1d(pcols) ! work-array to avoid NAN and pcols/ncol confusion - real(r8) :: Nnatk(pcols,pver,0:nmodes) ! Modal aerosol number concentration - real(r8) :: batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW - real(r8) :: rhoda(pcols,pver) ! air mass density, unit kg/m^3 - real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn - integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn - real(r8) :: rhtrunc(pcols,pver) ! relative humidity (as fraction) - real(r8) :: per_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth - real(r8) :: per_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8) :: per_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau - real(r8) :: per_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau - real(r8) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) - integer :: ns ! spectral loop index - real(r8) :: volc_ext_sun(pcols,pver,nswbands) ! volcanic aerosol extinction for solar bands, CMIP6 - real(r8) :: volc_omega_sun(pcols,pver,nswbands) ! volcanic aerosol SSA for solar bands, CMIP6 - real(r8) :: volc_g_sun(pcols,pver,nswbands) ! volcanic aerosol g for solar bands, CMIP6 - real(r8) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 - real(r8) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 -#endif - - real(r8) :: fns(pcols,pverp) ! net shortwave flux - real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux - real(r8) :: fnl(pcols,pverp) ! net longwave flux - real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux - - ! for COSP - real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity - real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau - real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth - - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables - - real(r8) :: freqclr(pcols) ! Frequency of occurrence of clear sky columns - real(r8) :: flntclr(pcols) ! Clearsky only columns (zero if cloudy) - - character(*), parameter :: name = 'radiation_tend' - - logical, parameter :: cosz_rad_call=.true. !+tht - !-------------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - -#ifdef OSLO_AERO - per_lw_abs(:,:,:)=0._r8 - per_tau(:,:,:)=0._r8 - per_tau_w(:,:,:)=0._r8 - per_tau_w_g(:,:,:)=0._r8 - per_tau_w_f(:,:,:)=0._r8 -#endif - - if (present(rd_out)) then - rd => rd_out - write_output = .false. - else - allocate(rd) - write_output=.true. - end if - - dosw = radiation_do('sw') ! do shortwave heating calc this timestep? - dolw = radiation_do('lw') ! do longwave heating calc this timestep? - - ! Cosine solar zenith angle for current time step - calday = get_curr_calday() - call get_rlat_all_p(lchnk, ncol, clat) - call get_rlon_all_p(lchnk, ncol, clon) - - call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & - delta, eccf) - do i = 1, ncol - coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, cosz_rad_call) !+tht - end do - - ! Gather night/day column indices. - Nday = 0 - Nnite = 0 - do i = 1, ncol - if ( coszrs(i) > 0.0_r8 ) then - Nday = Nday + 1 - IdxDay(Nday) = i - else - Nnite = Nnite + 1 - IdxNite(Nnite) = i - end if - end do - - ! Associate pointers to physics buffer fields - itim_old = pbuf_old_tim_idx() - if (cldfsnow_idx > 0) then - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - endif - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, qrl_idx, qrl) - - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, fsds_idx, fsds) - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, flns_idx, flns) - call pbuf_get_field(pbuf, flnt_idx, flnt) - - if (spectralflux) then - call pbuf_get_field(pbuf, su_idx, su) - call pbuf_get_field(pbuf, sd_idx, sd) - call pbuf_get_field(pbuf, lu_idx, lu) - call pbuf_get_field(pbuf, ld_idx, ld) - end if - - ! For CRM, make cloud equal to input observations: - if (scm_crm_mode .and. have_cld) then - do k = 1, pver - cld(:ncol,k)= cldobs(k) - end do - end if - -#ifdef OSLO_AERO - qdirind(:ncol,:,:) = state%q(:ncol,:,:) - if (has_prescribed_volcaero) then - call oslo_aero_getopts(volc_fraction_coarse_out = volc_fraction_coarse) - call pbuf_get_field(pbuf, volc_idx, rvolcmmr, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - qdirind(:ncol,:,l_so4_pr) = qdirind(:ncol,:,l_so4_pr) + (1.0_r8 - volc_fraction_coarse)*rvolcmmr(:ncol,:) - qdirind(:ncol,:,l_ss_a3) = qdirind(:ncol,:,l_ss_a3) + volc_fraction_coarse*rvolcmmr(:ncol,:) - end if -#endif - - ! Find tropopause height if needed for diagnostic output - if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then - call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) - endif - - if (dosw .or. dolw) then - - ! construct an RRTMG state object - r_state => rrtmg_state_create( state, cam_in ) - - call t_startf('cldoptics') - - if (cldfsnow_idx > 0) then - do k = 1, pver - do i = 1, ncol - cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) - end do - end do - else - cldfprime(:ncol,:) = cld(:ncol,:) - end if - - - if (dosw) then - - - if (oldcldoptics) then - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) - case ('mitchell') - call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) - case default - call endrun('iccldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) - case ('gammadist') - - call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) - - case default - call endrun('liqcldoptics must be either slingo or gammadist') - end select - end if - - cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) - cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) - cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) - cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) - - if (cldfsnow_idx > 0) then - ! add in snow - call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) - do i = 1, ncol - do k = 1, pver - - if (cldfprime(i,k) > 0._r8) then - - c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & - + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & - + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & - + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & - + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) - else - c_cld_tau(:,i,k) = 0._r8 - c_cld_tau_w(:,i,k) = 0._r8 - c_cld_tau_w_g(:,i,k) = 0._r8 - c_cld_tau_w_f(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) - c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) - c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) - c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) - end if - - ! Output cloud optical depth fields for the visible band - rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) - rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) - rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) - - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) - endif - - ! multiply by total cloud fraction to get gridbox value - rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) - - ! add fillvalue for night columns - do i = 1, Nnite - rd%tot_cld_vistau(IdxNite(i),:) = fillvalue - rd%tot_icld_vistau(IdxNite(i),:) = fillvalue - rd%liq_icld_vistau(IdxNite(i),:) = fillvalue - rd%ice_icld_vistau(IdxNite(i),:) = fillvalue - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(IdxNite(i),:) = fillvalue - end if - end do - - if (write_output) call radiation_output_cld(lchnk, ncol, rd) - - end if ! if (dosw) - - if (dolw) then - - if (oldcldoptics) then - call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) - case ('mitchell') - call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) - case default - call endrun('iccldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) - case ('gammadist') - call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) - case default - call endrun('liqcldoptics must be either slingo or gammadist') - end select - - cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) - - end if - - if (cldfsnow_idx > 0) then - - ! add in snow - call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) - - do i = 1, ncol - do k = 1, pver - if (cldfprime(i,k) > 0._r8) then - c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & - + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) - else - c_cld_lw_abs(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) - end if - - end if ! if (dolw) - - call t_stopf('cldoptics') - - ! Solar radiation computation - - if (dosw) then - -#ifdef OSLO_AERO - ! Volcanic optics for solar (SW) bands - do band=1, solar_bands - volc_ext_sun(1:ncol,1:pver,band)=0.0_r8 - volc_omega_sun(1:ncol,1:pver,band)=0.999_r8 - volc_g_sun(1:ncol,1:pver,band)=0.5_r8 - enddo - if (has_prescribed_volcaero_cmip6) then - do band=1, solar_bands - write(c3,'(i3)') band - volc_idx = pbuf_get_index('ext_sun'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_ext_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - volc_idx = pbuf_get_index('omega_sun'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_omega_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - volc_idx = pbuf_get_index('g_sun'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_g_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - enddo - endif - ! Volcanic optics for terrestrial (LW) bands (g is not used here) - do band=1, terrestrial_bands - volc_ext_earth(1:ncol,1:pver,band)=0.0_r8 - volc_omega_earth(1:ncol,1:pver,band)=0.999_r8 - enddo - if (has_prescribed_volcaero_cmip6) then - do band=1, terrestrial_bands - write(c3,'(i3)') band - volc_idx = pbuf_get_index('ext_earth'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_ext_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - - volc_idx = pbuf_get_index('omega_earth'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_omega_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - enddo - endif - - ! No aerocom variables passed for now - ! dod440, dod550, dod870, abs550, abs550alt - call oslo_aero_optical_params_calc(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & - coszrs, state, state%t, cld, qdirind, Nnatk, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, volc_ext_earth, volc_omega_earth, & - aodvis, absvis) - -#endif - call get_variability(sfac) - - ! Get the active climate/diagnostic shortwave calculations - call rad_cnst_get_call_list(active_calls) - - ! The climate (icall==0) calculation must occur last. - do icall = N_DIAG, 0, -1 - - if (active_calls(icall)) then - - ! update the concentrations in the RRTMG state object - call rrtmg_state_update(state, pbuf, icall, r_state) - -#ifdef OSLO_AERO - !call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & - ! aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) - ! A first call with Oslo aerosols set to zero for radiative forcing diagnostics - ! follwoing the Ghan (2013) method: - - ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore - ! (just nudged), but with an extra call with 0 aerosol extiction. - ! - idrf = .true. - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, & - per_tau*0.0_r8, per_tau_w, per_tau_w_g, per_tau_w_f, & - eccf, coszrs, rd%solin, sfac, cam_in%asdir, & - cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & - fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & - rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & - rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & - IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & - E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & - E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) - - - ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair - ! - ! Dump shortwave radiation information to history tape buffer (diagnostics) - ! - ! Note that DRF fields are now from the per_tau=0 call (clean), no longer with per_tau from pmxsub - call outfld('QRS_DRF ',ftem ,pcols,lchnk) - ftem(:ncol,:pver) = rd%qrsc(:ncol,:pver)/cpair - call outfld('QRSC_DRF',ftem ,pcols,lchnk) - call outfld('FSNT_DRF',fsnt(:) ,pcols,lchnk) - call outfld('FSNS_DRF',fsns(:) ,pcols,lchnk) - call outfld('FSNTCDRF',rd%fsntc(:) ,pcols,lchnk) - call outfld('FSNSCDRF',rd%fsnsc(:) ,pcols,lchnk) - if (do_aerocom) then - call outfld('FSUTADRF',rd%fsutoa(:),pcols,lchnk) - call outfld('FSDS_DRF',fsds(:) ,pcols,lchnk) - ftem_1d(1:ncol) = fsds(1:ncol)-fsns(1:ncol) - call outfld('FSUS_DRF',ftem_1d,pcols,lchnk) - call outfld('FSDSCDRF',rd%fsdsc(:) ,pcols,lchnk) - end if - idrf = .false. -#else - call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & - aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) -#endif - - rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) - rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) - rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) - rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) - -#ifdef OSLO_AERO - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & - eccf, coszrs, rd%solin, sfac, cam_in%asdir, & - cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & - fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & - rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & - rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & ! Note the extra idrf - IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & - E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & - E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) -#else - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & - eccf, coszrs, rd%solin, sfac, cam_in%asdir, & - cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & - fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & - rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & - rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, Nday, Nnite, & - IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & - E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & - E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) -#endif - - ! Output net fluxes at 200 mb - - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) - if (hist_fld_active('FSNR')) then - do i = 1,ncol - call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) - end do - end if - - if (write_output) call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) - - end if - end do - - end if - -#ifdef OSLO_AERO - !Calculate cloud-free fraction assuming random overlap - !(kind of duplicated from cloud_cover_diags::cldsav) - cloudfree(1:ncol) = 1.0_r8 - cloudfreemax(1:ncol) = 1.0_r8 - !Find cloud-free fraction (note this duplicated code and may not be consistent with cldtot calculated elsewhere) - do k = 1, pver - do i=1,ncol - cloudfree(i) = cloudfree(i) * cloudfreemax(i) - cloudfreemax(i) = min(cloudfreemax(i),1.0_r8-cld(i,k)) - end do - end do - - !Calculate AOD (visible) for cloud free - do i = 1, ncol - clearodvis(i)=cloudfree(i)*aodvis(i) - clearabsvis(i)=cloudfree(i)*absvis(i) - end do - - ! clear-sky AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) - ! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values - call outfld('CAODVIS ',clearodvis,pcols,lchnk) - call outfld('CABSVIS ',clearabsvis,pcols,lchnk) - call outfld('CLDFREE ',cloudfree,pcols,lchnk) -#ifdef AEROCOM - if (do_aerocom) then - do i = 1, ncol - clearod440(i)=cloudfree(i)*dod440(i) - clearod550(i)=cloudfree(i)*dod550(i) - clearod870(i)=cloudfree(i)*dod870(i) - clearabs550(i)=cloudfree(i)*abs550(i) - clearabs550alt(i)=cloudfree(i)*abs550alt(i) - end do - call outfld('CDOD440 ',clearod440 ,pcols,lchnk) - call outfld('CDOD550 ',clearod550 ,pcols,lchnk) - call outfld('CDOD870 ',clearod870 ,pcols,lchnk) - call outfld('CABS550 ',clearabs550 ,pcols,lchnk) - call outfld('CABS550A',clearabs550alt,pcols,lchnk) - end if -#endif -#endif - - ! Output aerosol mmr - call rad_cnst_out(0, state, pbuf) - - ! Longwave radiation computation - - if (dolw) then - - call rad_cnst_get_call_list(active_calls) - - ! The climate (icall==0) calculation must occur last. - do icall = N_DIAG, 0, -1 - - if (active_calls(icall)) then - - ! update the conctrations in the RRTMG state object - call rrtmg_state_update( state, pbuf, icall, r_state) - - call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) - - ! for calculation of direct and direct radiative forcing - -#ifdef OSLO_AERO - call rad_rrtmg_lw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - per_lw_abs*0.0_r8, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & - flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & - rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & - lu, ld) - - call outfld('FLNT_DRF',flnt(:) ,pcols,lchnk) - call outfld('FLNTCDRF',rd%flntc(:) ,pcols,lchnk) - - call rad_rrtmg_lw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - per_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & - flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & - rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & - lu, ld) - - ! FLNT_ORG is just for temporary testing vs. FLNT - ftem_1d(1:ncol) = cam_out%flwds(1:ncol) - flns(1:ncol) - call outfld('FLUS ',ftem_1d ,pcols,lchnk) -#else - call rad_rrtmg_lw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - aer_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & - flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & - rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & - lu, ld) -#endif - - ! Output fluxes at 200 mb - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) - if (hist_fld_active('FLNR')) then - do i = 1,ncol - call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fnl(i,:), rd%flnr(i)) - end do - end if - - flntclr(:) = 0._r8 - freqclr(:) = 0._r8 - do i = 1, ncol - if (maxval(cldfprime(i,:)) <= 0.1_r8) then - freqclr(i) = 1._r8 - flntclr(i) = rd%flntc(i) - end if - end do - - if (write_output) call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) - - end if - end do - - end if - - ! deconstruct the RRTMG state object - call rrtmg_state_destroy(r_state) - - if (docosp) then - - ! initialize and calculate emis - emis(:,:) = 0._r8 - emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(rrtmg_lw_cloudsim_band,:ncol,:)) - call outfld('EMIS', emis, pcols, lchnk) - - ! compute grid-box mean SW and LW snow optical depth for use by COSP - gb_snow_tau(:,:) = 0._r8 - gb_snow_lw(:,:) = 0._r8 - if (cldfsnow_idx > 0) then - do i = 1, ncol - do k = 1, pver - if (cldfsnow(i,k) > 0._r8) then - gb_snow_tau(i,k) = snow_tau(rrtmg_sw_cloudsim_band,i,k)*cldfsnow(i,k) - gb_snow_lw(i,k) = snow_lw_abs(rrtmg_lw_cloudsim_band,i,k)*cldfsnow(i,k) - end if - end do - end do - end if - - ! advance counter for this timestep (chunk dimension required for thread safety) - cosp_cnt(lchnk) = cosp_cnt(lchnk) + 1 - - ! if counter is the same as cosp_nradsteps, run cosp and reset counter - if (cosp_nradsteps .eq. cosp_cnt(lchnk)) then - - ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave - ! optical depths are passed. - call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & - cld_swtau_in=cld_tau(rrtmg_sw_cloudsim_band,:,:),& - snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) - cosp_cnt(lchnk) = 0 - end if - end if - - else ! if (dosw .or. dolw) then - - ! convert radiative heating rates from Q*dp to Q for energy conservation - do k =1 , pver - do i = 1, ncol - qrs(i,k) = qrs(i,k)/state%pdel(i,k) - qrl(i,k) = qrl(i,k)/state%pdel(i,k) - end do - end do - - end if ! if (dosw .or. dolw) then - - ! output rad inputs and resulting heating rates - call rad_data_write( pbuf, state, cam_in, coszrs ) - - ! Compute net radiative heating tendency - call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & - fsnt, flns, flnt, cam_in%asdir, net_flx) - - if (write_output) then - ! Compute heating rate for dtheta/dt - do k = 1, pver - do i = 1, ncol - ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa - end do - end do - call outfld('HR', ftem, pcols, lchnk) - end if - - ! convert radiative heating rates to Q*dp for energy conservation - do k = 1, pver - do i = 1, ncol - qrs(i,k) = qrs(i,k)*state%pdel(i,k) - qrl(i,k) = qrl(i,k)*state%pdel(i,k) - end do - end do - - cam_out%netsw(:ncol) = fsns(:ncol) - - if (.not. present(rd_out)) then - deallocate(rd) - end if - - end subroutine radiation_tend - - !=============================================================================== - - subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) - - ! Dump shortwave radiation information to history buffer. - - integer , intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: icall - type(rad_out_t), intent(in) :: rd - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(in) :: cam_out - - ! local variables - real(r8), pointer :: qrs(:,:) - real(r8), pointer :: fsnt(:) - real(r8), pointer :: fsns(:) - real(r8), pointer :: fsds(:) - - real(r8) :: ftem(pcols) - !---------------------------------------------------------------------------- - - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, fsds_idx, fsds) - - call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) - - call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) - call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) - - call outfld('FSNT'//diag(icall), fsnt, pcols, lchnk) - call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) - call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) - call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) - - ftem(:ncol) = rd%fsntoa(:ncol) - rd%fsntoac(:ncol) - call outfld('SWCF'//diag(icall), ftem, pcols, lchnk) - - call outfld('FSUTOA'//diag(icall), rd%fsutoa, pcols, lchnk) - - call outfld('FSNIRTOA'//diag(icall), rd%fsnirt, pcols, lchnk) - call outfld('FSNRTOAC'//diag(icall), rd%fsnrtc, pcols, lchnk) - call outfld('FSNRTOAS'//diag(icall), rd%fsnirtsq, pcols, lchnk) - - call outfld('FSN200'//diag(icall), rd%fsn200, pcols, lchnk) - call outfld('FSN200C'//diag(icall), rd%fsn200c, pcols, lchnk) - - call outfld('FSNR'//diag(icall), rd%fsnr, pcols, lchnk) - - call outfld('SOLS'//diag(icall), cam_out%sols, pcols, lchnk) - call outfld('SOLL'//diag(icall), cam_out%soll, pcols, lchnk) - call outfld('SOLSD'//diag(icall), cam_out%solsd, pcols, lchnk) - call outfld('SOLLD'//diag(icall), cam_out%solld, pcols, lchnk) - - call outfld('FSNS'//diag(icall), fsns, pcols, lchnk) - call outfld('FSNSC'//diag(icall), rd%fsnsc, pcols, lchnk) - - call outfld('FSDS'//diag(icall), fsds, pcols, lchnk) - call outfld('FSDSC'//diag(icall), rd%fsdsc, pcols, lchnk) - - end subroutine radiation_output_sw - - - !=============================================================================== - - subroutine radiation_output_cld(lchnk, ncol, rd) - - ! Dump shortwave cloud optics information to history buffer. - - integer , intent(in) :: lchnk - integer, intent(in) :: ncol - type(rad_out_t), intent(in) :: rd - !---------------------------------------------------------------------------- - - call outfld('TOT_CLD_VISTAU', rd%tot_cld_vistau, pcols, lchnk) - call outfld('TOT_ICLD_VISTAU', rd%tot_icld_vistau, pcols, lchnk) - call outfld('LIQ_ICLD_VISTAU', rd%liq_icld_vistau, pcols, lchnk) - call outfld('ICE_ICLD_VISTAU', rd%ice_icld_vistau, pcols, lchnk) - if (cldfsnow_idx > 0) then - call outfld('SNOW_ICLD_VISTAU', rd%snow_icld_vistau, pcols, lchnk) - endif - - end subroutine radiation_output_cld - - !=============================================================================== - - subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) - - ! Dump longwave radiation information to history buffer - - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: icall ! icall=0 for climate diagnostics - type(rad_out_t), intent(in) :: rd - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(in) :: cam_out - real(r8), intent(in) :: freqclr(pcols) - real(r8), intent(in) :: flntclr(pcols) - - ! local variables - real(r8), pointer :: qrl(:,:) - real(r8), pointer :: flnt(:) - real(r8), pointer :: flns(:) - - real(r8) :: ftem(pcols) - !---------------------------------------------------------------------------- - - call pbuf_get_field(pbuf, qrl_idx, qrl) - call pbuf_get_field(pbuf, flnt_idx, flnt) - call pbuf_get_field(pbuf, flns_idx, flns) - - call outfld('QRL'//diag(icall), qrl(:ncol,:)/cpair, ncol, lchnk) - call outfld('QRLC'//diag(icall), rd%qrlc(:ncol,:)/cpair, ncol, lchnk) - - call outfld('FLNT'//diag(icall), flnt, pcols, lchnk) - call outfld('FLNTC'//diag(icall), rd%flntc, pcols, lchnk) - - call outfld('FREQCLR'//diag(icall), freqclr, pcols, lchnk) - call outfld('FLNTCLR'//diag(icall), flntclr, pcols, lchnk) - - call outfld('FLUT'//diag(icall), rd%flut, pcols, lchnk) - call outfld('FLUTC'//diag(icall), rd%flutc, pcols, lchnk) - - ftem(:ncol) = rd%flutc(:ncol) - rd%flut(:ncol) - call outfld('LWCF'//diag(icall), ftem, pcols, lchnk) - - call outfld('FLN200'//diag(icall), rd%fln200, pcols, lchnk) - call outfld('FLN200C'//diag(icall), rd%fln200c, pcols, lchnk) - - call outfld('FLNR'//diag(icall), rd%flnr, pcols, lchnk) - - call outfld('FLNS'//diag(icall), flns, pcols, lchnk) - call outfld('FLNSC'//diag(icall), rd%flnsc, pcols, lchnk) - - call outfld('FLDS'//diag(icall), cam_out%flwds, pcols, lchnk) - call outfld('FLDSC'//diag(icall), rd%fldsc, pcols, lchnk) - - end subroutine radiation_output_lw - - !=============================================================================== - - subroutine calc_col_mean(state, mmr_pointer, mean_value) - - ! Compute the column mean mass mixing ratio. - - type(physics_state), intent(in) :: state - real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) - real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr - - integer :: i, k, ncol - real(r8) :: ptot(pcols) - !----------------------------------------------------------------------- - - ncol = state%ncol - mean_value = 0.0_r8 - ptot = 0.0_r8 - - do k=1,pver - do i=1,ncol - mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) - ptot(i) = ptot(i) + state%pdeldry(i,k) - end do - end do - do i=1,ncol - mean_value(i) = mean_value(i) / ptot(i) - end do - - end subroutine calc_col_mean - - !=============================================================================== - -end module radiation - diff --git a/src/physics/cam_oslo/radlw.F90 b/src/physics/cam_oslo/radlw.F90 deleted file mode 100644 index 5d29c2198c..0000000000 --- a/src/physics/cam_oslo/radlw.F90 +++ /dev/null @@ -1,308 +0,0 @@ - -module radlw -!----------------------------------------------------------------------- -! -! Purpose: Longwave radiation calculations. -! -!----------------------------------------------------------------------- - -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver, pverp -use scamMod, only: single_column, scm_crm_mode -use parrrtm, only: nbndlw, ngptlw -use rrtmg_lw_init, only: rrtmg_lw_ini -use rrtmg_lw_rad, only: rrtmg_lw -use spmd_utils, only: masterproc -use perf_mod, only: t_startf, t_stopf -use cam_logfile, only: iulog -use cam_abortutils, only: endrun -use radconstants, only: nlwbands - -implicit none - -private -save - -! Public methods - -public ::& - radlw_init, &! initialize constants - rad_rrtmg_lw ! driver for longwave radiation code - -! Private data -integer :: ntoplw ! top level to solve for longwave cooling - -! Flag for cloud overlap method -! 0=clear, 1=random, 2=maximum/random, 3=maximum -integer, parameter :: icld = 2 - - -!=============================================================================== -CONTAINS -!=============================================================================== - -subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & - pmid ,aer_lw_abs,cld ,tauc_lw, & - qrl ,qrlc , & - flns ,flnt ,flnsc ,flntc ,flwds, & - flut ,flutc ,fnl ,fcnl ,fldsc, & - lu ,ld ) - -!----------------------------------------------------------------------- - use cam_history, only: outfld - use mcica_subcol_gen_lw, only: mcica_subcol_lw - use physconst, only: cpair - use rrtmg_state, only: rrtmg_state_t - -!------------------------------Arguments-------------------------------- -! -! Input arguments -! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: rrtmg_levs ! number of levels rad is applied - -! -! Input arguments which are only passed to other routines -! - type(rrtmg_state_t), intent(in) :: r_state - - real(r8), intent(in) :: pmid(pcols,pver) ! Level pressure (Pascals) - - real(r8), intent(in) :: aer_lw_abs (pcols,pver,nbndlw) ! aerosol absorption optics depth (LW) - - real(r8), intent(in) :: cld(pcols,pver) ! Cloud cover - real(r8), intent(in) :: tauc_lw(nbndlw,pcols,pver) ! Cloud longwave optical depth by band - -! -! Output arguments -! - real(r8), intent(out) :: qrl (pcols,pver) ! Longwave heating rate - real(r8), intent(out) :: qrlc(pcols,pver) ! Clearsky longwave heating rate - real(r8), intent(out) :: flns(pcols) ! Surface cooling flux - real(r8), intent(out) :: flnt(pcols) ! Net outgoing flux - real(r8), intent(out) :: flut(pcols) ! Upward flux at top of model - real(r8), intent(out) :: flnsc(pcols) ! Clear sky surface cooing - real(r8), intent(out) :: flntc(pcols) ! Net clear sky outgoing flux - real(r8), intent(out) :: flutc(pcols) ! Upward clear-sky flux at top of model - real(r8), intent(out) :: flwds(pcols) ! Down longwave flux at surface - real(r8), intent(out) :: fldsc(pcols) ! Down longwave clear flux at surface - real(r8), intent(out) :: fcnl(pcols,pverp) ! clear sky net flux at interfaces - real(r8), intent(out) :: fnl(pcols,pverp) ! net flux at interfaces - - real(r8), pointer, dimension(:,:,:) :: lu ! longwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: ld ! longwave spectral flux down - -! -!---------------------------Local variables----------------------------- -! - integer :: i, k, kk, nbnd ! indices - - real(r8) :: ful(pcols,pverp) ! Total upwards longwave flux - real(r8) :: fsul(pcols,pverp) ! Clear sky upwards longwave flux - real(r8) :: fdl(pcols,pverp) ! Total downwards longwave flux - real(r8) :: fsdl(pcols,pverp) ! Clear sky downwards longwv flux - - real(r8) :: tsfc(pcols) ! surface temperature - real(r8) :: emis(pcols,nbndlw) ! surface emissivity - - real(r8) :: taua_lw(pcols,rrtmg_levs-1,nbndlw) ! aerosol optical depth by band - - real(r8), parameter :: dps = 1._r8/86400._r8 ! Inverse of seconds per day - - ! Cloud arrays for McICA - integer, parameter :: nsubclw = ngptlw ! rrtmg_lw g-point (quadrature point) dimension - integer :: permuteseed ! permute seed for sub-column generator - - real(r8) :: cicewp(pcols,rrtmg_levs-1) ! in-cloud cloud ice water path - real(r8) :: cliqwp(pcols,rrtmg_levs-1) ! in-cloud cloud liquid water path - real(r8) :: rei(pcols,rrtmg_levs-1) ! ice particle effective radius (microns) - real(r8) :: rel(pcols,rrtmg_levs-1) ! liquid particle radius (micron) - - real(r8) :: cld_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud fraction (mcica) - real(r8) :: cicewp_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud ice water path (mcica) - real(r8) :: cliqwp_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud liquid water path (mcica) - real(r8) :: rei_stolw(pcols,rrtmg_levs-1) ! ice particle size (mcica) - real(r8) :: rel_stolw(pcols,rrtmg_levs-1) ! liquid particle size (mcica) - real(r8) :: tauc_stolw(nsubclw, pcols, rrtmg_levs-1) ! cloud optical depth (mcica - optional) - - ! Includes extra layer above model top - real(r8) :: uflx(pcols,rrtmg_levs+1) ! Total upwards longwave flux - real(r8) :: uflxc(pcols,rrtmg_levs+1) ! Clear sky upwards longwave flux - real(r8) :: dflx(pcols,rrtmg_levs+1) ! Total downwards longwave flux - real(r8) :: dflxc(pcols,rrtmg_levs+1) ! Clear sky downwards longwv flux - real(r8) :: hr(pcols,rrtmg_levs) ! Longwave heating rate (K/d) - real(r8) :: hrc(pcols,rrtmg_levs) ! Clear sky longwave heating rate (K/d) - real(r8) lwuflxs(nbndlw,pcols,pverp+1) ! Longwave spectral flux up - real(r8) lwdflxs(nbndlw,pcols,pverp+1) ! Longwave spectral flux down - !----------------------------------------------------------------------- - - ! mji/rrtmg - - ! Calculate cloud optical properties here if using CAM method, or if using one of the - ! methods in RRTMG_LW, then pass in cloud physical properties and zero out cloud optical - ! properties here - - ! Zero optional cloud optical depth input array tauc_lw, - ! if inputting cloud physical properties into RRTMG_LW - ! tauc_lw(:,:,:) = 0. - ! Or, pass in CAM cloud longwave optical depth to RRTMG_LW - ! do nbnd = 1, nbndlw - ! tauc_lw(nbnd,:ncol,:pver) = cldtau(:ncol,:pver) - ! end do - - ! Call mcica sub-column generator for RRTMG_LW - - ! Call sub-column generator for McICA in radiation - call t_startf('mcica_subcol_lw') - - ! Set permute seed (must be offset between LW and SW by at least 140 to insure - ! effective randomization) - permuteseed = 150 - - ! These fields are no longer supplied by CAM. - cicewp = 0.0_r8 - cliqwp = 0.0_r8 - rei = 0.0_r8 - rel = 0.0_r8 - - call mcica_subcol_lw(lchnk, ncol, rrtmg_levs-1, icld, permuteseed, pmid(:, pverp-rrtmg_levs+1:pverp-1), & - cld(:, pverp-rrtmg_levs+1:pverp-1), cicewp, cliqwp, rei, rel, tauc_lw(:, :ncol, pverp-rrtmg_levs+1:pverp-1), & - cld_stolw, cicewp_stolw, cliqwp_stolw, rei_stolw, rel_stolw, tauc_stolw) - - call t_stopf('mcica_subcol_lw') - - - call t_startf('rrtmg_lw') - - ! Convert incoming water amounts from specific humidity to vmr as needed; - ! Convert other incoming molecular amounts from mmr to vmr as needed; - ! Convert pressures from Pa to hPa; - ! Set surface emissivity to 1.0 here, this is treated in land surface model; - ! Set surface temperature - ! Set aerosol optical depth to zero for now - - emis(:ncol,:nbndlw) = 1._r8 - tsfc(:ncol) = r_state%tlev(:ncol,rrtmg_levs+1) - taua_lw(:ncol, 1:rrtmg_levs-1, :nbndlw) = aer_lw_abs(:ncol,pverp-rrtmg_levs+1:pverp-1,:nbndlw) - - - if (associated(lu)) lu(1:ncol,:,:) = 0.0_r8 - if (associated(ld)) ld(1:ncol,:,:) = 0.0_r8 - - call rrtmg_lw(lchnk ,ncol ,rrtmg_levs ,icld , & - r_state%pmidmb ,r_state%pintmb ,r_state%tlay ,r_state%tlev ,tsfc ,r_state%h2ovmr, & - r_state%o3vmr ,r_state%co2vmr ,r_state%ch4vmr ,r_state%o2vmr ,r_state%n2ovmr ,r_state%cfc11vmr,r_state%cfc12vmr, & - r_state%cfc22vmr,r_state%ccl4vmr ,emis ,& - cld_stolw,tauc_stolw,cicewp_stolw,cliqwp_stolw ,rei, rel, & - taua_lw, & - uflx ,dflx ,hr ,uflxc ,dflxc ,hrc, & - lwuflxs, lwdflxs) - - ! - !---------------------------------------------------------------------- - ! All longitudes: store history tape quantities - ! Flux units are in W/m2 on output from rrtmg_lw and contain output for - ! extra layer above model top with vertical indexing from bottom to top. - ! Heating units are in K/d on output from RRTMG and contain output for - ! extra layer above model top with vertical indexing from bottom to top. - ! Heating units are converted to J/kg/s below for use in CAM. - - flwds(:ncol) = dflx (:ncol,1) - fldsc(:ncol) = dflxc(:ncol,1) - flns(:ncol) = uflx (:ncol,1) - dflx (:ncol,1) - flnsc(:ncol) = uflxc(:ncol,1) - dflxc(:ncol,1) - flnt(:ncol) = uflx (:ncol,rrtmg_levs) - dflx (:ncol,rrtmg_levs) - flntc(:ncol) = uflxc(:ncol,rrtmg_levs) - dflxc(:ncol,rrtmg_levs) - flut(:ncol) = uflx (:ncol,rrtmg_levs) - flutc(:ncol) = uflxc(:ncol,rrtmg_levs) - - ! - ! Reverse vertical indexing here for CAM arrays to go from top to bottom. - ! - ful = 0._r8 - fdl = 0._r8 - fsul = 0._r8 - fsdl = 0._r8 - ful (:ncol,pverp-rrtmg_levs+1:pverp)= uflx(:ncol,rrtmg_levs:1:-1) - fdl (:ncol,pverp-rrtmg_levs+1:pverp)= dflx(:ncol,rrtmg_levs:1:-1) - fsul(:ncol,pverp-rrtmg_levs+1:pverp)=uflxc(:ncol,rrtmg_levs:1:-1) - fsdl(:ncol,pverp-rrtmg_levs+1:pverp)=dflxc(:ncol,rrtmg_levs:1:-1) - -#ifndef OSLO_AERO - if (single_column.and.scm_crm_mode) then -#endif - call outfld('FUL ',ful,pcols,lchnk) - call outfld('FDL ',fdl,pcols,lchnk) - call outfld('FULC ',fsul,pcols,lchnk) - call outfld('FDLC ',fsdl,pcols,lchnk) -#ifndef OSLO_AERO - endif -#endif - - fnl(:ncol,:) = ful(:ncol,:) - fdl(:ncol,:) - ! mji/ cam excluded this? - fcnl(:ncol,:) = fsul(:ncol,:) - fsdl(:ncol,:) - - ! Pass longwave heating to CAM arrays and convert from K/d to J/kg/s - qrl = 0._r8 - qrlc = 0._r8 - qrl (:ncol,pverp-rrtmg_levs+1:pver)=hr (:ncol,rrtmg_levs-1:1:-1)*cpair*dps - qrlc(:ncol,pverp-rrtmg_levs+1:pver)=hrc(:ncol,rrtmg_levs-1:1:-1)*cpair*dps - - ! Return 0 above solution domain - if ( ntoplw > 1 )then - qrl(:ncol,:ntoplw-1) = 0._r8 - qrlc(:ncol,:ntoplw-1) = 0._r8 - end if - - ! Pass spectral fluxes, reverse layering - ! order=(/3,1,2/) maps the first index of lwuflxs to the third index of lu. - if (associated(lu)) then - lu(:ncol,pverp-rrtmg_levs+1:pverp,:) = reshape(lwuflxs(:,:ncol,rrtmg_levs:1:-1), & - (/ncol,rrtmg_levs,nbndlw/), order=(/3,1,2/)) - end if - - if (associated(ld)) then - ld(:ncol,pverp-rrtmg_levs+1:pverp,:) = reshape(lwdflxs(:,:ncol,rrtmg_levs:1:-1), & - (/ncol,rrtmg_levs,nbndlw/), order=(/3,1,2/)) - end if - - call t_stopf('rrtmg_lw') - -end subroutine rad_rrtmg_lw - -!------------------------------------------------------------------------------- - -subroutine radlw_init() -!----------------------------------------------------------------------- -! -! Purpose: -! Initialize various constants for radiation scheme. -! -!----------------------------------------------------------------------- - - use ref_pres, only : pref_mid - - integer :: k - - ! If the top model level is above ~90 km (0.1 Pa), set the top level to compute - ! longwave cooling to about 80 km (1 Pa) - if (pref_mid(1) .lt. 0.1_r8) then - do k = 1, pver - if (pref_mid(k) .lt. 1._r8) ntoplw = k - end do - else - ntoplw = 1 - end if - if (masterproc) then - write(iulog,*) 'radlw_init: ntoplw =',ntoplw - endif - - call rrtmg_lw_ini - -end subroutine radlw_init - -!------------------------------------------------------------------------------- - -end module radlw diff --git a/src/physics/cam_oslo/radsw.F90 b/src/physics/cam_oslo/radsw.F90 deleted file mode 100644 index 165fa7a931..0000000000 --- a/src/physics/cam_oslo/radsw.F90 +++ /dev/null @@ -1,687 +0,0 @@ - -module radsw -!----------------------------------------------------------------------- -! -! Purpose: Solar radiation calculations. -! -!----------------------------------------------------------------------- - -use shr_kind_mod, only: r8 => shr_kind_r8 -use ppgrid, only: pcols, pver, pverp -use cam_abortutils, only: endrun -use cam_history, only: outfld -use scamMod, only: single_column,scm_crm_mode,have_asdir, & - asdirobs, have_asdif, asdifobs, have_aldir, & - aldirobs, have_aldif, aldifobs -use cam_logfile, only: iulog -use parrrsw, only: nbndsw, ngptsw -use rrtmg_sw_init, only: rrtmg_sw_ini -use rrtmg_sw_rad, only: rrtmg_sw -use perf_mod, only: t_startf, t_stopf -use radconstants, only: idx_sw_diag - -implicit none - -private - -real(r8) :: fractional_solar_irradiance(1:nbndsw) ! fraction of solar irradiance in each band -real(r8) :: solar_band_irrad(1:nbndsw) ! rrtmg-assumed solar irradiance in each sw band - -! Public methods - -public ::& - radsw_init, &! initialize constants - rad_rrtmg_sw ! driver for solar radiation code - -! Flag for cloud overlap method -! 0=clear, 1=random, 2=maximum-random, 3=maximum -integer, parameter :: icld = 2 - -!=============================================================================== -CONTAINS -!=============================================================================== - -subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & - E_pmid ,E_cld , & - E_aer_tau,E_aer_tau_w,E_aer_tau_w_g,E_aer_tau_w_f, & - eccf ,E_coszrs ,solin ,sfac , & - E_asdir ,E_asdif ,E_aldir ,E_aldif , & - qrs ,qrsc ,fsnt ,fsntc ,fsntoa,fsutoa, & - fsntoac ,fsnirtoa ,fsnrtoac ,fsnrtoaq ,fsns , & - fsnsc ,fsdsc ,fsds ,sols ,soll , & -#ifdef OSLO_AERO - solsd ,solld ,fns ,fcns ,idrf , & -#else - solsd ,solld ,fns ,fcns , & -#endif - Nday ,Nnite ,IdxDay ,IdxNite , & - su ,sd , & - E_cld_tau, E_cld_tau_w, E_cld_tau_w_g, E_cld_tau_w_f, & - old_convert) - - -!----------------------------------------------------------------------- -! -! Purpose: -! Solar radiation code -! -! Method: -! mji/rrtmg -! RRTMG, two-stream, with McICA -! -! Divides solar spectrum into 14 intervals from 0.2-12.2 micro-meters. -! solar flux fractions specified for each interval. allows for -! seasonally and diurnally varying solar input. Includes molecular, -! cloud, aerosol, and surface scattering, along with h2o,o3,co2,o2,cloud, -! and surface absorption. Computes delta-eddington reflections and -! transmissions assuming homogeneously mixed layers. Adds the layers -! assuming scattering between layers to be isotropic, and distinguishes -! direct solar beam from scattered radiation. -! -! Longitude loops are broken into 1 or 2 sections, so that only daylight -! (i.e. coszrs > 0) computations are done. -! -! Note that an extra layer above the model top layer is added. -! -! mks units are used. -! -! Special diagnostic calculation of the clear sky surface and total column -! absorbed flux is also done for cloud forcing diagnostics. -! -!----------------------------------------------------------------------- - - use cmparray_mod, only: CmpDayNite, ExpDayNite - use phys_control, only: phys_getopts - use mcica_subcol_gen_sw, only: mcica_subcol_sw - use physconst, only: cpair - use rrtmg_state, only: rrtmg_state_t - - ! Minimum cloud amount (as a fraction of the grid-box area) to - ! distinguish from clear sky - real(r8), parameter :: cldmin = 1.0e-80_r8 - - ! Decimal precision of cloud amount (0 -> preserve full resolution; - ! 10^-n -> preserve n digits of cloud amount) - real(r8), parameter :: cldeps = 0.0_r8 - - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: rrtmg_levs ! number of levels rad is applied - - type(rrtmg_state_t), intent(in) :: r_state - - integer, intent(in) :: Nday ! Number of daylight columns - integer, intent(in) :: Nnite ! Number of night columns - integer, intent(in), dimension(pcols) :: IdxDay ! Indicies of daylight coumns - integer, intent(in), dimension(pcols) :: IdxNite ! Indicies of night coumns - - real(r8), intent(in) :: E_pmid(pcols,pver) ! Level pressure (Pascals) - real(r8), intent(in) :: E_cld(pcols,pver) ! Fractional cloud cover - - real(r8), intent(in) :: E_aer_tau (pcols, 0:pver, nbndsw) ! aerosol optical depth - real(r8), intent(in) :: E_aer_tau_w (pcols, 0:pver, nbndsw) ! aerosol OD * ssa - real(r8), intent(in) :: E_aer_tau_w_g(pcols, 0:pver, nbndsw) ! aerosol OD * ssa * asm - real(r8), intent(in) :: E_aer_tau_w_f(pcols, 0:pver, nbndsw) ! aerosol OD * ssa * fwd - - real(r8), intent(in) :: eccf ! Eccentricity factor (1./earth-sun dist^2) - real(r8), intent(in) :: E_coszrs(pcols) ! Cosine solar zenith angle - real(r8), intent(in) :: E_asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad - real(r8), intent(in) :: E_aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad - real(r8), intent(in) :: E_asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad - real(r8), intent(in) :: E_aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad - real(r8), intent(in) :: sfac(nbndsw) ! factor to account for solar variability in each band - - real(r8), optional, intent(in) :: E_cld_tau (nbndsw, pcols, pver) ! cloud optical depth - real(r8), optional, intent(in) :: E_cld_tau_w (nbndsw, pcols, pver) ! cloud optical - real(r8), optional, intent(in) :: E_cld_tau_w_g(nbndsw, pcols, pver) ! cloud optical - real(r8), optional, intent(in) :: E_cld_tau_w_f(nbndsw, pcols, pver) ! cloud optical - logical, optional, intent(in) :: old_convert - - ! Output arguments - - real(r8), intent(out) :: solin(pcols) ! Incident solar flux - real(r8), intent(out) :: qrs (pcols,pver) ! Solar heating rate - real(r8), intent(out) :: qrsc(pcols,pver) ! Clearsky solar heating rate - real(r8), intent(out) :: fsns(pcols) ! Surface absorbed solar flux - real(r8), intent(out) :: fsnt(pcols) ! Total column absorbed solar flux - real(r8), intent(out) :: fsntoa(pcols) ! Net solar flux at TOA - real(r8), intent(out) :: fsutoa(pcols) ! Upward solar flux at TOA - real(r8), intent(out) :: fsds(pcols) ! Flux shortwave downwelling surface - - real(r8), intent(out) :: fsnsc(pcols) ! Clear sky surface absorbed solar flux - real(r8), intent(out) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux - real(r8), intent(out) :: fsntc(pcols) ! Clear sky total column absorbed solar flx - real(r8), intent(out) :: fsntoac(pcols) ! Clear sky net solar flx at TOA - real(r8), intent(out) :: sols(pcols) ! Direct solar rad on surface (< 0.7) - real(r8), intent(out) :: soll(pcols) ! Direct solar rad on surface (>= 0.7) - real(r8), intent(out) :: solsd(pcols) ! Diffuse solar rad on surface (< 0.7) - real(r8), intent(out) :: solld(pcols) ! Diffuse solar rad on surface (>= 0.7) - real(r8), intent(out) :: fsnirtoa(pcols) ! Near-IR flux absorbed at toa - real(r8), intent(out) :: fsnrtoac(pcols) ! Clear sky near-IR flux absorbed at toa - real(r8), intent(out) :: fsnrtoaq(pcols) ! Net near-IR flux at toa >= 0.7 microns - - real(r8), intent(out) :: fns(pcols,pverp) ! net flux at interfaces - real(r8), intent(out) :: fcns(pcols,pverp) ! net clear-sky flux at interfaces - -#ifdef OSLO_AERO - logical, intent(in) :: idrf -#endif - - real(r8), pointer, dimension(:,:,:) :: su ! shortwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: sd ! shortwave spectral flux down - - !---------------------------Local variables----------------------------- - - ! Local and reordered copies of the intent(in) variables - - real(r8) :: pmid(pcols,pver) ! Level pressure (Pascals) - - real(r8) :: cld(pcols,rrtmg_levs-1) ! Fractional cloud cover - real(r8) :: cicewp(pcols,rrtmg_levs-1) ! in-cloud cloud ice water path - real(r8) :: cliqwp(pcols,rrtmg_levs-1) ! in-cloud cloud liquid water path - real(r8) :: rel(pcols,rrtmg_levs-1) ! Liquid effective drop size (microns) - real(r8) :: rei(pcols,rrtmg_levs-1) ! Ice effective drop size (microns) - - real(r8) :: coszrs(pcols) ! Cosine solar zenith angle - real(r8) :: asdir(pcols) ! 0.2-0.7 micro-meter srfc alb: direct rad - real(r8) :: aldir(pcols) ! 0.7-5.0 micro-meter srfc alb: direct rad - real(r8) :: asdif(pcols) ! 0.2-0.7 micro-meter srfc alb: diffuse rad - real(r8) :: aldif(pcols) ! 0.7-5.0 micro-meter srfc alb: diffuse rad - - real(r8) :: h2ovmr(pcols,rrtmg_levs) ! h2o volume mixing ratio - real(r8) :: o3vmr(pcols,rrtmg_levs) ! o3 volume mixing ratio - real(r8) :: co2vmr(pcols,rrtmg_levs) ! co2 volume mixing ratio - real(r8) :: ch4vmr(pcols,rrtmg_levs) ! ch4 volume mixing ratio - real(r8) :: o2vmr(pcols,rrtmg_levs) ! o2 volume mixing ratio - real(r8) :: n2ovmr(pcols,rrtmg_levs) ! n2o volume mixing ratio - - real(r8) :: tsfc(pcols) ! surface temperature - - integer :: dyofyr ! Set to day of year for Earth/Sun distance calculation in - ! rrtmg_sw, or pass in adjustment directly into adjes - real(r8) :: solvar(nbndsw) ! solar irradiance variability in each band - - integer, parameter :: nsubcsw = ngptsw ! rrtmg_sw g-point (quadrature point) dimension - integer :: permuteseed ! permute seed for sub-column generator - - real(r8) :: diagnostic_od(pcols, pver) ! cloud optical depth - diagnostic temp variable - - real(r8) :: tauc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud optical depth - real(r8) :: ssac_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud single scat. albedo - real(r8) :: asmc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud asymmetry parameter - real(r8) :: fsfc_sw(nbndsw, pcols, rrtmg_levs-1) ! cloud forward scattering fraction - - real(r8) :: tau_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer optical depth - real(r8) :: ssa_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer single scat. albedo - real(r8) :: asm_aer_sw(pcols, rrtmg_levs-1, nbndsw) ! aer asymmetry parameter - - real(r8) :: cld_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud fraction - real(r8) :: rei_stosw(pcols, rrtmg_levs-1) ! stochastic ice particle size - real(r8) :: rel_stosw(pcols, rrtmg_levs-1) ! stochastic liquid particle size - real(r8) :: cicewp_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud ice water path - real(r8) :: cliqwp_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud liquid wter path - real(r8) :: tauc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud optical depth (optional) - real(r8) :: ssac_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud single scat. albedo (optional) - real(r8) :: asmc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud asymmetry parameter (optional) - real(r8) :: fsfc_stosw(nsubcsw, pcols, rrtmg_levs-1) ! stochastic cloud forward scattering fraction (optional) - - real(r8), parameter :: dps = 1._r8/86400._r8 ! Inverse of seconds per day - - real(r8) :: swuflx(pcols,rrtmg_levs+1) ! Total sky shortwave upward flux (W/m2) - real(r8) :: swdflx(pcols,rrtmg_levs+1) ! Total sky shortwave downward flux (W/m2) - real(r8) :: swhr(pcols,rrtmg_levs) ! Total sky shortwave radiative heating rate (K/d) - real(r8) :: swuflxc(pcols,rrtmg_levs+1) ! Clear sky shortwave upward flux (W/m2) - real(r8) :: swdflxc(pcols,rrtmg_levs+1) ! Clear sky shortwave downward flux (W/m2) - real(r8) :: swhrc(pcols,rrtmg_levs) ! Clear sky shortwave radiative heating rate (K/d) - real(r8) :: swuflxs(nbndsw,pcols,rrtmg_levs+1) ! Shortwave spectral flux up - real(r8) :: swdflxs(nbndsw,pcols,rrtmg_levs+1) ! Shortwave spectral flux down - - real(r8) :: dirdnuv(pcols,rrtmg_levs+1) ! Direct downward shortwave flux, UV/vis - real(r8) :: difdnuv(pcols,rrtmg_levs+1) ! Diffuse downward shortwave flux, UV/vis - real(r8) :: dirdnir(pcols,rrtmg_levs+1) ! Direct downward shortwave flux, near-IR - real(r8) :: difdnir(pcols,rrtmg_levs+1) ! Diffuse downward shortwave flux, near-IR - - ! Added for net near-IR diagnostic - real(r8) :: ninflx(pcols,rrtmg_levs+1) ! Net shortwave flux, near-IR - real(r8) :: ninflxc(pcols,rrtmg_levs+1) ! Net clear sky shortwave flux, near-IR - - ! Other - - integer :: i, k, ns ! indices - - ! Cloud radiative property arrays - real(r8) :: tauxcl(pcols,0:pver) ! water cloud extinction optical depth - real(r8) :: tauxci(pcols,0:pver) ! ice cloud extinction optical depth - real(r8) :: wcl(pcols,0:pver) ! liquid cloud single scattering albedo - real(r8) :: gcl(pcols,0:pver) ! liquid cloud asymmetry parameter - real(r8) :: fcl(pcols,0:pver) ! liquid cloud forward scattered fraction - real(r8) :: wci(pcols,0:pver) ! ice cloud single scattering albedo - real(r8) :: gci(pcols,0:pver) ! ice cloud asymmetry parameter - real(r8) :: fci(pcols,0:pver) ! ice cloud forward scattered fraction - - ! Aerosol radiative property arrays - real(r8) :: tauxar(pcols,0:pver) ! aerosol extinction optical depth - real(r8) :: wa(pcols,0:pver) ! aerosol single scattering albedo - real(r8) :: ga(pcols,0:pver) ! aerosol assymetry parameter - real(r8) :: fa(pcols,0:pver) ! aerosol forward scattered fraction - - ! CRM - real(r8) :: fus(pcols,pverp) ! Upward flux (added for CRM) - real(r8) :: fds(pcols,pverp) ! Downward flux (added for CRM) - real(r8) :: fusc(pcols,pverp) ! Upward clear-sky flux (added for CRM) - real(r8) :: fdsc(pcols,pverp) ! Downward clear-sky flux (added for CRM) - - integer :: kk - - real(r8) :: pmidmb(pcols,rrtmg_levs) ! Level pressure (hPa) - real(r8) :: pintmb(pcols,rrtmg_levs+1) ! Model interface pressure (hPa) - real(r8) :: tlay(pcols,rrtmg_levs) ! mid point temperature - real(r8) :: tlev(pcols,rrtmg_levs+1) ! interface temperature - - !----------------------------------------------------------------------- - ! START OF CALCULATION - !----------------------------------------------------------------------- - - ! Initialize output fields: - - fsds(1:ncol) = 0.0_r8 - - fsnirtoa(1:ncol) = 0.0_r8 - fsnrtoac(1:ncol) = 0.0_r8 - fsnrtoaq(1:ncol) = 0.0_r8 - - fsns(1:ncol) = 0.0_r8 - fsnsc(1:ncol) = 0.0_r8 - fsdsc(1:ncol) = 0.0_r8 - - fsnt(1:ncol) = 0.0_r8 - fsntc(1:ncol) = 0.0_r8 - fsntoa(1:ncol) = 0.0_r8 - fsutoa(1:ncol) = 0.0_r8 - fsntoac(1:ncol) = 0.0_r8 - - solin(1:ncol) = 0.0_r8 - - sols(1:ncol) = 0.0_r8 - soll(1:ncol) = 0.0_r8 - solsd(1:ncol) = 0.0_r8 - solld(1:ncol) = 0.0_r8 - - qrs (1:ncol,1:pver) = 0.0_r8 - qrsc(1:ncol,1:pver) = 0.0_r8 - fns(1:ncol,1:pverp) = 0.0_r8 - fcns(1:ncol,1:pverp) = 0.0_r8 - -#ifndef OSLO_AERO - if (single_column.and.scm_crm_mode) then -#endif - fus(1:ncol,1:pverp) = 0.0_r8 - fds(1:ncol,1:pverp) = 0.0_r8 - fusc(:ncol,:pverp) = 0.0_r8 - fdsc(:ncol,:pverp) = 0.0_r8 -#ifndef OSLO_AERO - endif -#endif - - if (associated(su)) su(1:ncol,:,:) = 0.0_r8 - if (associated(sd)) sd(1:ncol,:,:) = 0.0_r8 - - ! If night everywhere, return: - if ( Nday == 0 ) then - return - endif - - ! Rearrange input arrays - call CmpDayNite(E_pmid(:,pverp-rrtmg_levs+1:pver), pmid(:,1:rrtmg_levs-1), & - Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs-1) - call CmpDayNite(E_cld(:,pverp-rrtmg_levs+1:pver), cld(:,1:rrtmg_levs-1), & - Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs-1) - - call CmpDayNite(r_state%pintmb, pintmb, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs+1) - call CmpDayNite(r_state%pmidmb, pmidmb, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%h2ovmr, h2ovmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%o3vmr, o3vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%co2vmr, co2vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - - call CmpDayNite(E_coszrs, coszrs, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call CmpDayNite(E_asdir, asdir, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call CmpDayNite(E_aldir, aldir, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call CmpDayNite(E_asdif, asdif, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call CmpDayNite(E_aldif, aldif, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - - call CmpDayNite(r_state%tlay, tlay, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%tlev, tlev, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs+1) - call CmpDayNite(r_state%ch4vmr, ch4vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%o2vmr, o2vmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - call CmpDayNite(r_state%n2ovmr, n2ovmr, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, rrtmg_levs) - - ! These fields are no longer input by CAM. - cicewp = 0.0_r8 - cliqwp = 0.0_r8 - rel = 0.0_r8 - rei = 0.0_r8 - - ! Aerosol daylight map - ! Also convert to optical properties of rrtmg interface, even though - ! these quantities are later multiplied back together inside rrtmg ! - ! Why does rrtmg use the factored quantities? - ! There are several different ways this factoring could be done. - ! Other ways might allow for better optimization - do ns = 1, nbndsw - do k = 1, rrtmg_levs-1 - kk=(pverp-rrtmg_levs) + k - do i = 1, Nday - if(E_aer_tau_w(IdxDay(i),kk,ns) > 1.e-80_r8) then - asm_aer_sw(i,k,ns) = E_aer_tau_w_g(IdxDay(i),kk,ns)/E_aer_tau_w(IdxDay(i),kk,ns) - else - asm_aer_sw(i,k,ns) = 0._r8 - endif - if(E_aer_tau(IdxDay(i),kk,ns) > 0._r8) then - ssa_aer_sw(i,k,ns) = E_aer_tau_w(IdxDay(i),kk,ns)/E_aer_tau(IdxDay(i),kk,ns) - tau_aer_sw(i,k,ns) = E_aer_tau(IdxDay(i),kk,ns) - else - ssa_aer_sw(i,k,ns) = 1._r8 - tau_aer_sw(i,k,ns) = 0._r8 - endif - enddo - enddo - enddo - - if (scm_crm_mode) then - ! overwrite albedos for CRM - if(have_asdir) asdir = asdirobs(1) - if(have_asdif) asdif = asdifobs(1) - if(have_aldir) aldir = aldirobs(1) - if(have_aldif) aldif = aldifobs(1) - endif - - ! Define solar incident radiation - do i = 1, Nday - solin(i) = sum(sfac(:)*solar_band_irrad(:)) * eccf * coszrs(i) - end do - - ! Calculate cloud optical properties here if using CAM method, or if using one of the - ! methods in RRTMG_SW, then pass in cloud physical properties and zero out cloud optical - ! properties here - - ! Zero optional cloud optical property input arrays tauc_sw, ssac_sw, asmc_sw, - ! if inputting cloud physical properties to RRTMG_SW - !tauc_sw(:,:,:) = 0.0_r8 - !ssac_sw(:,:,:) = 1.0_r8 - !asmc_sw(:,:,:) = 0.0_r8 - !fsfc_sw(:,:,:) = 0.0_r8 - ! - ! Or, calculate and pass in CAM cloud shortwave optical properties to RRTMG_SW - !if (present(old_convert)) print *, 'old_convert',old_convert - !if (present(ancientmethod)) print *, 'ancientmethod',ancientmethod - if (present(old_convert))then - if (old_convert)then ! convert without limits - do i = 1, Nday - do k = 1, rrtmg_levs-1 - kk=(pverp-rrtmg_levs) + k - do ns = 1, nbndsw - if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then - fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/E_cld_tau_w(ns,IdxDay(i),kk) - asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/E_cld_tau_w(ns,IdxDay(i),kk) - else - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - endif - - tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk) - if (tauc_sw(ns,i,k) > 0._r8) then - ssac_sw(ns,i,k)=E_cld_tau_w(ns,IdxDay(i),kk)/tauc_sw(ns,i,k) - else - tauc_sw(ns,i,k) = 0._r8 - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - ssac_sw(ns,i,k) = 1._r8 - endif - enddo - enddo - enddo - else - ! eventually, when we are done with archaic versions, This set of code will become the default. - do i = 1, Nday - do k = 1, rrtmg_levs-1 - kk=(pverp-rrtmg_levs) + k - do ns = 1, nbndsw - if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then - fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) - asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) - else - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - endif - - tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk) - if (tauc_sw(ns,i,k) > 0._r8) then - ssac_sw(ns,i,k)=max(E_cld_tau_w(ns,IdxDay(i),kk),1.e-80_r8)/max(tauc_sw(ns,i,k),1.e-80_r8) - else - tauc_sw(ns,i,k) = 0._r8 - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - ssac_sw(ns,i,k) = 1._r8 - endif - enddo - enddo - enddo - endif - else - do i = 1, Nday - do k = 1, rrtmg_levs-1 - kk=(pverp-rrtmg_levs) + k - do ns = 1, nbndsw - if (E_cld_tau_w(ns,IdxDay(i),kk) > 0._r8) then - fsfc_sw(ns,i,k)=E_cld_tau_w_f(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) - asmc_sw(ns,i,k)=E_cld_tau_w_g(ns,IdxDay(i),kk)/max(E_cld_tau_w(ns,IdxDay(i),kk), 1.e-80_r8) - else - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - endif - - tauc_sw(ns,i,k)=E_cld_tau(ns,IdxDay(i),kk) - if (tauc_sw(ns,i,k) > 0._r8) then - ssac_sw(ns,i,k)=max(E_cld_tau_w(ns,IdxDay(i),kk),1.e-80_r8)/max(tauc_sw(ns,i,k),1.e-80_r8) - else - tauc_sw(ns,i,k) = 0._r8 - fsfc_sw(ns,i,k) = 0._r8 - asmc_sw(ns,i,k) = 0._r8 - ssac_sw(ns,i,k) = 1._r8 - endif - enddo - enddo - enddo - endif - - ! Call mcica sub-column generator for RRTMG_SW - - ! Call sub-column generator for McICA in radiation - call t_startf('mcica_subcol_sw') - - ! Set permute seed (must be offset between LW and SW by at least 140 to insure - ! effective randomization) - permuteseed = 1 - - - call mcica_subcol_sw(lchnk, Nday, rrtmg_levs-1, icld, permuteseed, pmid, & - cld, cicewp, cliqwp, rei, rel, tauc_sw, ssac_sw, asmc_sw, fsfc_sw, & - cld_stosw, cicewp_stosw, cliqwp_stosw, rei_stosw, rel_stosw, & - tauc_stosw, ssac_stosw, asmc_stosw, fsfc_stosw) - - call t_stopf('mcica_subcol_sw') - - call t_startf('rrtmg_sw') - - ! Call RRTMG_SW for all layers for daylight columns - - - ! Set day of year for Earth/Sun distance calculation in rrtmg_sw, or - ! set to zero and pass E/S adjustment (eccf) directly into array adjes - dyofyr = 0 - - tsfc(:ncol) = tlev(:ncol,rrtmg_levs+1) - - solvar(1:nbndsw) = sfac(1:nbndsw) - - call rrtmg_sw(lchnk, Nday, rrtmg_levs, icld, & - pmidmb, pintmb, tlay, tlev, tsfc, & - h2ovmr, o3vmr, co2vmr, ch4vmr, o2vmr, n2ovmr, & - asdir, asdif, aldir, aldif, & - coszrs, eccf, dyofyr, solvar, & - cld_stosw, tauc_stosw, ssac_stosw, asmc_stosw, fsfc_stosw, & - cicewp_stosw, cliqwp_stosw, rei, rel, & - tau_aer_sw, ssa_aer_sw, asm_aer_sw, & - swuflx, swdflx, swhr, swuflxc, swdflxc, swhrc, & - dirdnuv, dirdnir, difdnuv, difdnir, ninflx, ninflxc, swuflxs, swdflxs) - - ! Flux units are in W/m2 on output from rrtmg_sw and contain output for - ! extra layer above model top with vertical indexing from bottom to top. - ! - ! Heating units are in J/kg/s on output from rrtmg_sw and contain output - ! for extra layer above model top with vertical indexing from bottom to top. - ! - ! Reverse vertical indexing to go from top to bottom for CAM output. - - ! Set the net absorted shortwave flux at TOA (top of extra layer) - fsntoa(1:Nday) = swdflx(1:Nday,rrtmg_levs+1) - swuflx(1:Nday,rrtmg_levs+1) - fsutoa(1:Nday) = swuflx(1:Nday,rrtmg_levs+1) - fsntoac(1:Nday) = swdflxc(1:Nday,rrtmg_levs+1) - swuflxc(1:Nday,rrtmg_levs+1) - - ! Set net near-IR flux at top of the model - fsnirtoa(1:Nday) = ninflx(1:Nday,rrtmg_levs) - fsnrtoaq(1:Nday) = ninflx(1:Nday,rrtmg_levs) - fsnrtoac(1:Nday) = ninflxc(1:Nday,rrtmg_levs) - - ! Set the net absorbed shortwave flux at the model top level - fsnt(1:Nday) = swdflx(1:Nday,rrtmg_levs) - swuflx(1:Nday,rrtmg_levs) - fsntc(1:Nday) = swdflxc(1:Nday,rrtmg_levs) - swuflxc(1:Nday,rrtmg_levs) - - ! Set the downwelling flux at the surface - fsds(1:Nday) = swdflx(1:Nday,1) - fsdsc(1:Nday) = swdflxc(1:Nday,1) - - ! Set the net shortwave flux at the surface - fsns(1:Nday) = swdflx(1:Nday,1) - swuflx(1:Nday,1) - fsnsc(1:Nday) = swdflxc(1:Nday,1) - swuflxc(1:Nday,1) - - ! Set the UV/vis and near-IR direct and dirruse downward shortwave flux at surface - sols(1:Nday) = dirdnuv(1:Nday,1) - soll(1:Nday) = dirdnir(1:Nday,1) - solsd(1:Nday) = difdnuv(1:Nday,1) - solld(1:Nday) = difdnir(1:Nday,1) - - - ! Set the net, up and down fluxes at model interfaces - fns (1:Nday,pverp-rrtmg_levs+1:pverp) = swdflx(1:Nday,rrtmg_levs:1:-1) - swuflx(1:Nday,rrtmg_levs:1:-1) - fcns(1:Nday,pverp-rrtmg_levs+1:pverp) = swdflxc(1:Nday,rrtmg_levs:1:-1) - swuflxc(1:Nday,rrtmg_levs:1:-1) - fus (1:Nday,pverp-rrtmg_levs+1:pverp) = swuflx(1:Nday,rrtmg_levs:1:-1) - fusc(1:Nday,pverp-rrtmg_levs+1:pverp) = swuflxc(1:Nday,rrtmg_levs:1:-1) - fds (1:Nday,pverp-rrtmg_levs+1:pverp) = swdflx(1:Nday,rrtmg_levs:1:-1) - fdsc(1:Nday,pverp-rrtmg_levs+1:pverp) = swdflxc(1:Nday,rrtmg_levs:1:-1) - - ! Set solar heating, reverse layering - ! Pass shortwave heating to CAM arrays and convert from K/d to J/kg/s - qrs (1:Nday,pverp-rrtmg_levs+1:pver) = swhr (1:Nday,rrtmg_levs-1:1:-1)*cpair*dps - qrsc(1:Nday,pverp-rrtmg_levs+1:pver) = swhrc(1:Nday,rrtmg_levs-1:1:-1)*cpair*dps - - ! Set spectral fluxes, reverse layering - ! order=(/3,1,2/) maps the first index of swuflxs to the third index of su. - if (associated(su)) then - su(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swuflxs(:,1:Nday,rrtmg_levs:1:-1), & - (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/)) - end if - - if (associated(sd)) then - sd(1:Nday,pverp-rrtmg_levs+1:pverp,:) = reshape(swdflxs(:,1:Nday,rrtmg_levs:1:-1), & - (/Nday,rrtmg_levs,nbndsw/), order=(/3,1,2/)) - end if - - call t_stopf('rrtmg_sw') - - ! Rearrange output arrays. - ! - ! intent(out) - - call ExpDayNite(solin, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(qrs, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pver) - call ExpDayNite(qrsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pver) - call ExpDayNite(fns, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fcns, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fsns, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnt, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsntoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsutoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsds, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsdsc, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsntc, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsntoac, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(sols, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(soll, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(solsd, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(solld, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnirtoa, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnrtoac, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - call ExpDayNite(fsnrtoaq, Nday, IdxDay, Nnite, IdxNite, 1, pcols) - - if (associated(su)) then - call ExpDayNite(su, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw) - end if - - if (associated(sd)) then - call ExpDayNite(sd, Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp, 1, nbndsw) - end if - - ! these outfld calls don't work for spmd only outfield in scm mode (nonspmd) - ! Following outputs added for CRM -#ifndef OSLO_AERO - if (single_column .and. scm_crm_mode) then -#endif - call ExpDayNite(fus,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fds,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call outfld('FUS ', fus, pcols, lchnk) - call outfld('FUSC ', fusc, pcols, lchnk) - call outfld('FDS ', fds, pcols, lchnk) - call outfld('FDSC ', fdsc, pcols, lchnk) -#ifndef OSLO_AERO - end if -#endif - -#ifdef OSLO_AERO - if (idrf) then - call outfld('FUSCDRF ', fusc, pcols, lchnk) - call outfld('FDSCDRF ', fdsc, pcols, lchnk) - endif -#endif - -end subroutine rad_rrtmg_sw - -!------------------------------------------------------------------------------- - -subroutine radsw_init() -!----------------------------------------------------------------------- -! -! Purpose: -! Initialize various constants for radiation scheme. -! -!----------------------------------------------------------------------- - use radconstants, only: get_solar_band_fraction_irrad, get_ref_solar_band_irrad - - ! get the reference fractional solar irradiance in each band - call get_solar_band_fraction_irrad(fractional_solar_irradiance) - call get_ref_solar_band_irrad( solar_band_irrad ) - - - ! Initialize rrtmg_sw - call rrtmg_sw_ini - -end subroutine radsw_init - - -!------------------------------------------------------------------------------- - -end module radsw diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index e65809c11d..a3e699a0ef 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -1,1428 +1,1702 @@ module radiation -!--------------------------------------------------------------------------------- -! -! CAM interface to RRTMG radiation parameterization -! -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver, pverp, begchunk, endchunk -use physics_types, only: physics_state, physics_ptend -use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx -use camsrfexch, only: cam_out_t, cam_in_t -use physconst, only: cappa, cpair - -use time_manager, only: get_nstep, is_first_restart_step, & - get_curr_calday, get_step_size - -use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_info, & - rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & - liqcldoptics, icecldoptics - -use radconstants, only: nswbands, nlwbands, rrtmg_sw_cloudsim_band, rrtmg_lw_cloudsim_band, & - idx_sw_diag - -use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & - cospsimulator_intr_run, cosp_nradsteps - -use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs - -use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active -use cam_history_support, only: fillvalue - -use pio, only: file_desc_t, var_desc_t, & - pio_int, pio_noerr, & - pio_seterrorhandling, pio_bcast_error, & - pio_inq_varid, pio_def_var, & - pio_put_var, pio_get_var - -use cam_abortutils, only: endrun -use error_messages, only: handle_err -use perf_mod, only: t_startf, t_stopf -use cam_logfile, only: iulog - -implicit none -private -save - -public :: & - radiation_readnl, &! read namelist variables - radiation_register, &! registers radiation physics buffer fields - radiation_nextsw_cday, &! calendar day of next radiation calculation - radiation_do, &! query which radiation calcs are done this timestep - radiation_init, &! initialization - radiation_define_restart, &! define variables for restart - radiation_write_restart, &! write variables to restart - radiation_read_restart, &! read variables from restart - radiation_tend, &! compute heating rates and fluxes - rad_out_t ! type for diagnostic outputs - -integer,public, allocatable :: cosp_cnt(:) ! counter for cosp -integer,public :: cosp_cnt_init = 0 !initial value for cosp counter - -type rad_out_t - real(r8) :: solin(pcols) ! Solar incident flux - - real(r8) :: qrsc(pcols,pver) - - real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux - real(r8) :: fsntoa(pcols) ! Net solar flux at TOA - real(r8) :: fsntoac(pcols) ! Clear sky net solar flux at TOA - real(r8) :: fsutoa(pcols) ! upwelling solar flux at TOA - - real(r8) :: fsnirt(pcols) ! Near-IR flux absorbed at toa - real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa - real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns - - real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb - real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb - real(r8) :: fsnr(pcols) ! fns interpolated to tropopause - - real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux - real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux - - real(r8) :: qrlc(pcols,pver) - - real(r8) :: flntc(pcols) ! Clear sky lw flux at model top - real(r8) :: flut(pcols) ! Upward flux at top of model - real(r8) :: flutc(pcols) ! Upward Clear Sky flux at top of model - real(r8) :: lwcf(pcols) ! longwave cloud forcing - - real(r8) :: fln200(pcols) ! net longwave flux interpolated to 200 mb - real(r8) :: fln200c(pcols) ! net clearsky longwave flux interpolated to 200 mb - real(r8) :: flnr(pcols) ! net longwave flux interpolated to tropopause - - real(r8) :: flnsc(pcols) ! Clear sky lw flux at srf (up-down) - real(r8) :: fldsc(pcols) ! Clear sky lw flux at srf (down) - - real(r8) :: tot_cld_vistau(pcols,pver) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: tot_icld_vistau(pcols,pver) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth (only during day, night = fillvalue) - real(r8) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth for output on history files - - real(r8) :: cld_tau_cloudsim(pcols,pver) - real(r8) :: aer_tau400(pcols,0:pver) - real(r8) :: aer_tau550(pcols,0:pver) - real(r8) :: aer_tau700(pcols,0:pver) - -end type rad_out_t - -! Namelist variables - -integer :: iradsw = -1 ! freq. of shortwave radiation calc in time steps (positive) - ! or hours (negative). -integer :: iradlw = -1 ! frequency of longwave rad. calc. in time steps (positive) - ! or hours (negative). - -integer :: irad_always = 0 ! Specifies length of time in timesteps (positive) - ! or hours (negative) SW/LW radiation will be - ! run continuously from the start of an - ! initial or restart run -logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations -logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. - -! Physics buffer indices -integer :: qrs_idx = 0 -integer :: qrl_idx = 0 -integer :: su_idx = 0 -integer :: sd_idx = 0 -integer :: lu_idx = 0 -integer :: ld_idx = 0 -integer :: fsds_idx = 0 -integer :: fsns_idx = 0 -integer :: fsnt_idx = 0 -integer :: flns_idx = 0 -integer :: flnt_idx = 0 -integer :: cldfsnow_idx = 0 -integer :: cld_idx = 0 - -character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) - -! averaging time interval for zenith angle -real(r8) :: dt_avg = 0._r8 - -! PIO descriptors (for restarts) -type(var_desc_t) :: cospcnt_desc + !--------------------------------------------------------------------------------- + ! + ! CAM interface to RRTMG radiation parameterization + ! + !--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8=>shr_kind_r8 + use spmd_utils, only: masterproc + use ppgrid, only: pcols, pver, pverp, begchunk, endchunk + use physics_types, only: physics_state, physics_ptend + use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx + use camsrfexch, only: cam_out_t, cam_in_t + use physconst, only: cappa, cpair + + use time_manager, only: get_nstep, is_first_restart_step, & + get_curr_calday, get_step_size + + use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_info, & + rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & + liqcldoptics, icecldoptics + + use radconstants, only: nswbands, nlwbands, rrtmg_sw_cloudsim_band, rrtmg_lw_cloudsim_band, & + idx_sw_diag + + use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & + cospsimulator_intr_run, cosp_nradsteps + + use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs + + use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active + use cam_history_support, only: fillvalue + + use pio, only: file_desc_t, var_desc_t, & + pio_int, pio_noerr, & + pio_seterrorhandling, pio_bcast_error, & + pio_inq_varid, pio_def_var, & + pio_put_var, pio_get_var + + use cam_abortutils, only: endrun + use error_messages, only: handle_err + use perf_mod, only: t_startf, t_stopf + use cam_logfile, only: iulog +#ifdef OSLO_AERO + use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands + use oslo_aero_optical_params, only: oslo_aero_optical_params_calc + use commondefinitions, only: nmodes, nbmodes +#endif + + implicit none + private + + public :: & + radiation_readnl, &! read namelist variables + radiation_register, &! registers radiation physics buffer fields + radiation_nextsw_cday, &! calendar day of next radiation calculation + radiation_do, &! query which radiation calcs are done this timestep + radiation_init, &! initialization + radiation_define_restart, &! define variables for restart + radiation_write_restart, &! write variables to restart + radiation_read_restart, &! read variables from restart + radiation_tend, &! compute heating rates and fluxes + rad_out_t ! type for diagnostic outputs + + integer,public, allocatable :: cosp_cnt(:) ! counter for cosp + integer,public :: cosp_cnt_init = 0 !initial value for cosp counter + + type rad_out_t + + real(r8) :: solin(pcols) ! Solar incident flux + + real(r8) :: qrsc(pcols,pver) + + real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux + real(r8) :: fsntoa(pcols) ! Net solar flux at TOA + real(r8) :: fsntoac(pcols) ! Clear sky net solar flux at TOA + real(r8) :: fsutoa(pcols) ! upwelling solar flux at TOA + + real(r8) :: fsnirt(pcols) ! Near-IR flux absorbed at toa + real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa + real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns + + real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb + real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb + real(r8) :: fsnr(pcols) ! fns interpolated to tropopause + + real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux + real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux + + real(r8) :: qrlc(pcols,pver) + + real(r8) :: flntc(pcols) ! Clear sky lw flux at model top + real(r8) :: flut(pcols) ! Upward flux at top of model + real(r8) :: flutc(pcols) ! Upward Clear Sky flux at top of model + real(r8) :: lwcf(pcols) ! longwave cloud forcing + + real(r8) :: fln200(pcols) ! net longwave flux interpolated to 200 mb + real(r8) :: fln200c(pcols) ! net clearsky longwave flux interpolated to 200 mb + real(r8) :: flnr(pcols) ! net longwave flux interpolated to tropopause + + real(r8) :: flnsc(pcols) ! Clear sky lw flux at srf (up-down) + real(r8) :: fldsc(pcols) ! Clear sky lw flux at srf (down) + + real(r8) :: tot_cld_vistau(pcols,pver) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: tot_icld_vistau(pcols,pver) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth (only during day, night = fillvalue) + real(r8) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth for output on history files + + real(r8) :: cld_tau_cloudsim(pcols,pver) + real(r8) :: aer_tau400(pcols,0:pver) + real(r8) :: aer_tau550(pcols,0:pver) + real(r8) :: aer_tau700(pcols,0:pver) + + end type rad_out_t + + ! Namelist variables + + integer :: iradsw = -1 ! freq. of shortwave radiation calc in time steps (positive) + ! or hours (negative). + integer :: iradlw = -1 ! frequency of longwave rad. calc. in time steps (positive) + ! or hours (negative). + + integer :: irad_always = 0 ! Specifies length of time in timesteps (positive) + ! or hours (negative) SW/LW radiation will be + ! run continuously from the start of an + ! initial or restart run + logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations + logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. + + ! Physics buffer indices + integer :: qrs_idx = 0 + integer :: qrl_idx = 0 + integer :: su_idx = 0 + integer :: sd_idx = 0 + integer :: lu_idx = 0 + integer :: ld_idx = 0 + integer :: fsds_idx = 0 + integer :: fsns_idx = 0 + integer :: fsnt_idx = 0 + integer :: flns_idx = 0 + integer :: flnt_idx = 0 + integer :: cldfsnow_idx = 0 + integer :: cld_idx = 0 +#ifdef OSLO_AERO + integer :: volc_idx = 0 +#endif + + character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) + + ! averaging time interval for zenith angle + real(r8) :: dt_avg = 0._r8 + + ! PIO descriptors (for restarts) + type(var_desc_t) :: cospcnt_desc + +#ifdef AEROCOM + logical :: do_aerocom = .true. +#else + logical :: do_aerocom = .false. +#endif !=============================================================================== contains !=============================================================================== -subroutine radiation_readnl(nlfile) + subroutine radiation_readnl(nlfile) - ! Read radiation_nl namelist group. + ! Read radiation_nl namelist group. - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - ! Local variables - integer :: unitn, ierr - integer :: dtime ! timestep size - character(len=*), parameter :: sub = 'radiation_readnl' + ! Local variables + integer :: unitn, ierr + integer :: dtime ! timestep size + character(len=*), parameter :: sub = 'radiation_readnl' - namelist /radiation_nl/ iradsw, iradlw, irad_always, & - use_rad_dt_cosz, spectralflux - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'radiation_nl', status=ierr) - if (ierr == 0) then - read(unitn, radiation_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if + namelist /radiation_nl/ iradsw, iradlw, irad_always, & + use_rad_dt_cosz, spectralflux + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'radiation_nl', status=ierr) + if (ierr == 0) then + read(unitn, radiation_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if - ! Broadcast namelist variables - call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradsw") - call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradlw") - call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: irad_always") - call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_dt_cosz") - call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: spectralflux") + ! Broadcast namelist variables + call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradsw") + call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradlw") + call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: irad_always") + call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_dt_cosz") + call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: spectralflux") - ! Convert iradsw, iradlw and irad_always from hours to timesteps if necessary - dtime = get_step_size() - if (iradsw < 0) iradsw = nint((-iradsw *3600._r8)/dtime) - if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) - if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) - - !----------------------------------------------------------------------- - ! Print runtime options to log. - !----------------------------------------------------------------------- - - if (masterproc) then - write(iulog,*) 'RRTMG radiation scheme parameters:' - write(iulog,10) iradsw, iradlw, irad_always, use_rad_dt_cosz, spectralflux - end if - -10 format(' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & - ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & - ' SW/LW calc done every timestep for first N steps. N=',i5/, & - ' Use average zenith angle: ',l5/, & - ' Output spectrally resolved fluxes: ',l5/) - -end subroutine radiation_readnl - -!================================================================================================ - -subroutine radiation_register - - ! Register radiation fields in the physics buffer - - use physics_buffer, only: pbuf_add_field, dtype_r8 - use radiation_data, only: rad_data_register - - call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate - call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate - - call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux - call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux - call pbuf_add_field('FSNT' , 'global',dtype_r8,(/pcols/), fsnt_idx) ! Top-of-model net shortwave flux - - call pbuf_add_field('FLNS' , 'global',dtype_r8,(/pcols/), flns_idx) ! Surface net longwave flux - call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux - - ! If the namelist has been configured for preserving the spectral fluxes, then create - ! physics buffer variables to store the results. - if (spectralflux) then - call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) - call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) - call pbuf_add_field('LU' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), lu_idx) ! longwave upward flux (per band) - call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) - end if - - call rad_data_register() - -end subroutine radiation_register - -!================================================================================================ - -function radiation_do(op, timestep) - - ! Return true if the specified operation is done this timestep. - - character(len=*), intent(in) :: op ! name of operation - integer, intent(in), optional:: timestep - logical :: radiation_do ! return value - - ! Local variables - integer :: nstep ! current timestep number - !----------------------------------------------------------------------- - - if (present(timestep)) then - nstep = timestep - else - nstep = get_nstep() - end if - - select case (op) - - case ('sw') ! do a shortwave heating calc this timestep? - radiation_do = nstep == 0 .or. iradsw == 1 & - .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - case ('lw') ! do a longwave heating calc this timestep? - radiation_do = nstep == 0 .or. iradlw == 1 & - .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - case default - call endrun('radiation_do: unknown operation:'//op) - - end select -end function radiation_do - -!================================================================================================ - -real(r8) function radiation_nextsw_cday() - - ! Return calendar day of next sw radiation calculation - - ! Local variables - integer :: nstep ! timestep counter - logical :: dosw ! true => do shosrtwave calc - integer :: offset ! offset for calendar day calculation - integer :: dTime ! integer timestep size - real(r8):: calday ! calendar day of - !----------------------------------------------------------------------- - - radiation_nextsw_cday = -1._r8 - dosw = .false. - nstep = get_nstep() - dtime = get_step_size() - offset = 0 - do while (.not. dosw) - nstep = nstep + 1 - offset = offset + dtime - if (radiation_do('sw', nstep)) then - radiation_nextsw_cday = get_curr_calday(offset=offset) - dosw = .true. - end if - end do - if(radiation_nextsw_cday == -1._r8) then - call endrun('error in radiation_nextsw_cday') - end if - -end function radiation_nextsw_cday - -!================================================================================================ - -subroutine radiation_init(pbuf2d) - - ! Initialize the radiation parameterization, add fields to the history buffer - - use physics_buffer, only: pbuf_get_index, pbuf_set_field - use phys_control, only: phys_getopts - use radsw, only: radsw_init - use radlw, only: radlw_init - use rad_solar_var, only: rad_solar_var_init - use radiation_data, only: rad_data_init - use cloud_rad_props, only: cloud_rad_props_init - use modal_aer_opt, only: modal_aer_opt_init - use rrtmg_state, only: rrtmg_state_init - use time_manager, only: is_first_step - - - ! arguments - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local variables - integer :: icall, nmodes - logical :: active_calls(0:N_DIAG) - integer :: nstep ! current timestep number - logical :: history_amwg ! output the variables used by the AMWG diag package - logical :: history_vdiag ! output the variables used by the AMWG variability diag package - logical :: history_budget ! output tendencies and state variables for CAM4 - ! temperature, water vapor, cloud ice and cloud - ! liquid budgets. - integer :: history_budget_histfile_num ! output history file number for budget fields - integer :: err - - integer :: dtime - !----------------------------------------------------------------------- - - call rad_solar_var_init() - call rrtmg_state_init() - call rad_data_init(pbuf2d) ! initialize output fields for offline driver - call radsw_init() - call radlw_init() - call cloud_rad_props_init() - - cld_idx = pbuf_get_index('CLD') - cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err) - - if (is_first_step()) then - call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) - end if - - ! Set the radiation timestep for cosz calculations if requested using the adjusted iradsw value from radiation - if (use_rad_dt_cosz) then - dtime = get_step_size() - dt_avg = iradsw*dtime - end if - - call phys_getopts(history_amwg_out = history_amwg, & - history_vdiag_out = history_vdiag, & - history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num) - - ! Determine whether modal aerosols are affecting the climate, and if so - ! then initialize the modal aerosol optics module - call rad_cnst_get_info(0, nmodes=nmodes) - if (nmodes > 0) call modal_aer_opt_init() - - ! "irad_always" is number of time steps to execute radiation continuously from start of - ! initial OR restart run - nstep = get_nstep() - if (irad_always > 0) then - nstep = get_nstep() - irad_always = irad_always + nstep - end if - - if (docosp) call cospsimulator_intr_init - - allocate(cosp_cnt(begchunk:endchunk)) - if (is_first_restart_step()) then - cosp_cnt(begchunk:endchunk) = cosp_cnt_init - else - cosp_cnt(begchunk:endchunk) = 0 - end if - - call addfld('O3colAbove', horiz_only, 'A', 'DU', 'Column O3 above model top', sampling_seq='rad_lwsw') - - call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total gbx cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('TOT_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('LIQ_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Liquid in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('ICE_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Ice in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - - if (cldfsnow_idx > 0) then - call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Snow in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - endif - - ! get list of active radiation calls - call rad_cnst_get_call_list(active_calls) - - ! Add shortwave radiation fields to history master field list. - - do icall = 0, N_DIAG - - if (active_calls(icall)) then - - call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') - - call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') - call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & - sampling_seq='rad_lwsw') - call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & - sampling_seq='rad_lwsw') - call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') - - call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - - call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & - sampling_seq='rad_lwsw') - - call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') - call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') - call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') - call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') - - if (history_amwg) then - call add_default('SOLIN'//diag(icall), 1, ' ') - call add_default('QRS'//diag(icall), 1, ' ') - call add_default('FSNT'//diag(icall), 1, ' ') - call add_default('FSNTC'//diag(icall), 1, ' ') - call add_default('FSNTOA'//diag(icall), 1, ' ') - call add_default('FSNTOAC'//diag(icall), 1, ' ') - call add_default('SWCF'//diag(icall), 1, ' ') - call add_default('FSNS'//diag(icall), 1, ' ') - call add_default('FSNSC'//diag(icall), 1, ' ') - call add_default('FSUTOA'//diag(icall), 1, ' ') - call add_default('FSDSC'//diag(icall), 1, ' ') - call add_default('FSDS'//diag(icall), 1, ' ') - endif - - end if - end do - - if (scm_crm_mode) then - call add_default('FUS ', 1, ' ') - call add_default('FUSC ', 1, ' ') - call add_default('FDS ', 1, ' ') - call add_default('FDSC ', 1, ' ') - endif - - ! Add longwave radiation fields to history master field list. - - do icall = 0, N_DIAG - - if (active_calls(icall)) then - - call addfld('QRL'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Longwave heating rate', sampling_seq='rad_lwsw') - call addfld('QRLC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky longwave heating rate', & - sampling_seq='rad_lwsw') - call addfld('FLNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLNTCLR'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky ONLY points net longwave flux at top of model',& - sampling_seq='rad_lwsw') - call addfld('FREQCLR'//diag(icall), horiz_only, 'A', 'Frac', 'Frequency of Occurrence of Clearsky', & - sampling_seq='rad_lwsw') - call addfld('FLUT'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLUTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky upwelling longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('LWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Longwave cloud forcing', sampling_seq='rad_lwsw') - - call addfld('FLN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FLN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FLNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at tropopause', & - sampling_seq='rad_lwsw') - - call addfld('FLNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky Downwelling longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FUL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave upward flux') - call addfld('FDL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave downward flux') - call addfld('FULC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky upward flux') - call addfld('FDLC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky downward flux') - - if (history_amwg) then - call add_default('QRL'//diag(icall), 1, ' ') - call add_default('FLNT'//diag(icall), 1, ' ') - call add_default('FLNTC'//diag(icall), 1, ' ') - call add_default('FLNTCLR'//diag(icall), 1, ' ') - call add_default('FREQCLR'//diag(icall), 1, ' ') - call add_default('FLUT'//diag(icall), 1, ' ') - call add_default('FLUTC'//diag(icall), 1, ' ') - call add_default('LWCF'//diag(icall), 1, ' ') - call add_default('FLNS'//diag(icall), 1, ' ') - call add_default('FLNSC'//diag(icall), 1, ' ') - call add_default('FLDS'//diag(icall), 1, ' ') - endif - - end if - end do - - call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') - - if (scm_crm_mode) then - call add_default ('FUL ', 1, ' ') - call add_default ('FULC ', 1, ' ') - call add_default ('FDL ', 1, ' ') - call add_default ('FDLC ', 1, ' ') - endif - - ! Heating rate needed for d(theta)/dt computation - call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') - - if ( history_budget .and. history_budget_histfile_num > 1 ) then - call add_default ('QRL ', history_budget_histfile_num, ' ') - call add_default ('QRS ', history_budget_histfile_num, ' ') - end if - - if (history_vdiag) then - call add_default('FLUT', 2, ' ') - call add_default('FLUT', 3, ' ') - end if - -end subroutine radiation_init + ! Convert iradsw, iradlw and irad_always from hours to timesteps if necessary + dtime = get_step_size() + if (iradsw < 0) iradsw = nint((-iradsw *3600._r8)/dtime) + if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) + if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) -!=============================================================================== - -subroutine radiation_define_restart(file) - - ! define variables to be written to restart file - - ! arguments - type(file_desc_t), intent(inout) :: file + !----------------------------------------------------------------------- + ! Print runtime options to log. + !----------------------------------------------------------------------- - ! local variables - integer :: ierr - !---------------------------------------------------------------------------- - - call pio_seterrorhandling(File, PIO_BCAST_ERROR) - - if (docosp) then - ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) - end if - -end subroutine radiation_define_restart - -!=============================================================================== + if (masterproc) then + write(iulog,*) 'RRTMG radiation scheme parameters:' + write(iulog,10) iradsw, iradlw, irad_always, use_rad_dt_cosz, spectralflux + end if + +10 format(' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & + ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & + ' SW/LW calc done every timestep for first N steps. N=',i5/, & + ' Use average zenith angle: ',l5/, & + ' Output spectrally resolved fluxes: ',l5/) + + end subroutine radiation_readnl + + !================================================================================================ + + subroutine radiation_register + + ! Register radiation fields in the physics buffer + + use physics_buffer, only: pbuf_add_field, dtype_r8 + use radiation_data, only: rad_data_register -subroutine radiation_write_restart(file) + call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate + call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate + + call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux + call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux + call pbuf_add_field('FSNT' , 'global',dtype_r8,(/pcols/), fsnt_idx) ! Top-of-model net shortwave flux + + call pbuf_add_field('FLNS' , 'global',dtype_r8,(/pcols/), flns_idx) ! Surface net longwave flux + call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux + + ! If the namelist has been configured for preserving the spectral fluxes, then create + ! physics buffer variables to store the results. + if (spectralflux) then + call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) + call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) + call pbuf_add_field('LU' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), lu_idx) ! longwave upward flux (per band) + call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) + end if + + call rad_data_register() + + end subroutine radiation_register + + !================================================================================================ + + function radiation_do(op, timestep) + + ! Return true if the specified operation is done this timestep. + + character(len=*), intent(in) :: op ! name of operation + integer, intent(in), optional:: timestep + logical :: radiation_do ! return value + + ! Local variables + integer :: nstep ! current timestep number + !----------------------------------------------------------------------- + + if (present(timestep)) then + nstep = timestep + else + nstep = get_nstep() + end if + + select case (op) + + case ('sw') ! do a shortwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradsw == 1 & + .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + case ('lw') ! do a longwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradlw == 1 & + .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + case default + call endrun('radiation_do: unknown operation:'//op) + + end select + end function radiation_do + + !================================================================================================ + + real(r8) function radiation_nextsw_cday() + + ! Return calendar day of next sw radiation calculation + + ! Local variables + integer :: nstep ! timestep counter + logical :: dosw ! true => do shosrtwave calc + integer :: offset ! offset for calendar day calculation + integer :: dTime ! integer timestep size + real(r8):: calday ! calendar day of + !----------------------------------------------------------------------- + + radiation_nextsw_cday = -1._r8 + dosw = .false. + nstep = get_nstep() + dtime = get_step_size() + offset = 0 + do while (.not. dosw) + nstep = nstep + 1 + offset = offset + dtime + if (radiation_do('sw', nstep)) then + radiation_nextsw_cday = get_curr_calday(offset=offset) + dosw = .true. + end if + end do + if(radiation_nextsw_cday == -1._r8) then + call endrun('error in radiation_nextsw_cday') + end if + + end function radiation_nextsw_cday + + !================================================================================================ + + subroutine radiation_init(pbuf2d) + + ! Initialize the radiation parameterization, add fields to the history buffer + + use physics_buffer, only: pbuf_get_index, pbuf_set_field + use phys_control, only: phys_getopts + use radsw, only: radsw_init + use radlw, only: radlw_init + use rad_solar_var, only: rad_solar_var_init + use radiation_data, only: rad_data_init + use cloud_rad_props, only: cloud_rad_props_init + use modal_aer_opt, only: modal_aer_opt_init + use rrtmg_state, only: rrtmg_state_init + use time_manager, only: is_first_step + + + ! arguments + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + ! local variables + integer :: icall, nmodes + logical :: active_calls(0:N_DIAG) + integer :: nstep ! current timestep number + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_vdiag ! output the variables used by the AMWG variability diag package + logical :: history_budget ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + integer :: history_budget_histfile_num ! output history file number for budget fields + integer :: err + + integer :: dtime + !----------------------------------------------------------------------- + + call rad_solar_var_init() + call rrtmg_state_init() + call rad_data_init(pbuf2d) ! initialize output fields for offline driver + call radsw_init() + call radlw_init() + call cloud_rad_props_init() + + cld_idx = pbuf_get_index('CLD') + cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err) + + if (is_first_step()) then + call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) + end if + + + ! Set the radiation timestep for cosz calculations if requested using the adjusted iradsw value from radiation + if (use_rad_dt_cosz) then + dtime = get_step_size() + dt_avg = iradsw*dtime + end if + + call phys_getopts(history_amwg_out = history_amwg, & + history_vdiag_out = history_vdiag, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num) + + ! Determine whether modal aerosols are affecting the climate, and if so + ! then initialize the modal aerosol optics module + call rad_cnst_get_info(0, nmodes=nmodes) + if (nmodes > 0) call modal_aer_opt_init() + + ! "irad_always" is number of time steps to execute radiation continuously from start of + ! initial OR restart run + nstep = get_nstep() + if (irad_always > 0) then + nstep = get_nstep() + irad_always = irad_always + nstep + end if + + if (docosp) call cospsimulator_intr_init + + allocate(cosp_cnt(begchunk:endchunk)) + if (is_first_restart_step()) then + cosp_cnt(begchunk:endchunk) = cosp_cnt_init + else + cosp_cnt(begchunk:endchunk) = 0 + end if + + call addfld('O3colAbove', horiz_only, 'A', 'DU', 'Column O3 above model top', sampling_seq='rad_lwsw') + + call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total gbx cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('TOT_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('LIQ_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Liquid in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('ICE_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Ice in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + + if (cldfsnow_idx > 0) then + call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Snow in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + endif + + ! get list of active radiation calls + call rad_cnst_get_call_list(active_calls) + + ! Add shortwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + + call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') + + call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') + call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & + sampling_seq='rad_lwsw') + call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & + sampling_seq='rad_lwsw') + call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') + + call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + + call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & + sampling_seq='rad_lwsw') + + call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') + call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') + call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') + call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') + + if (history_amwg) then + call add_default('SOLIN'//diag(icall), 1, ' ') + call add_default('QRS'//diag(icall), 1, ' ') + call add_default('FSNT'//diag(icall), 1, ' ') + call add_default('FSNTC'//diag(icall), 1, ' ') + call add_default('FSNTOA'//diag(icall), 1, ' ') + call add_default('FSNTOAC'//diag(icall), 1, ' ') + call add_default('SWCF'//diag(icall), 1, ' ') + call add_default('FSNS'//diag(icall), 1, ' ') + call add_default('FSNSC'//diag(icall), 1, ' ') + call add_default('FSUTOA'//diag(icall), 1, ' ') + call add_default('FSDSC'//diag(icall), 1, ' ') + call add_default('FSDS'//diag(icall), 1, ' ') + endif + + end if + end do + +#ifdef OSLO_AERO + call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') + call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') +#endif + + if (scm_crm_mode) then + call add_default('FUS ', 1, ' ') + call add_default('FUSC ', 1, ' ') + call add_default('FDS ', 1, ' ') + call add_default('FDSC ', 1, ' ') + endif + + ! Add longwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + + call addfld('QRL'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Longwave heating rate', sampling_seq='rad_lwsw') + call addfld('QRLC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky longwave heating rate', & + sampling_seq='rad_lwsw') + call addfld('FLNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLNTCLR'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky ONLY points net longwave flux at top of model',& + sampling_seq='rad_lwsw') + call addfld('FREQCLR'//diag(icall), horiz_only, 'A', 'Frac', 'Frequency of Occurrence of Clearsky', & + sampling_seq='rad_lwsw') + call addfld('FLUT'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLUTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky upwelling longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('LWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Longwave cloud forcing', sampling_seq='rad_lwsw') + + call addfld('FLN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FLN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FLNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at tropopause', & + sampling_seq='rad_lwsw') + + call addfld('FLNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky Downwelling longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FUL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave upward flux') + call addfld('FDL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave downward flux') + call addfld('FULC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky upward flux') + call addfld('FDLC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky downward flux') + + if (history_amwg) then + call add_default('QRL'//diag(icall), 1, ' ') + call add_default('FLNT'//diag(icall), 1, ' ') + call add_default('FLNTC'//diag(icall), 1, ' ') + call add_default('FLNTCLR'//diag(icall), 1, ' ') + call add_default('FREQCLR'//diag(icall), 1, ' ') + call add_default('FLUT'//diag(icall), 1, ' ') + call add_default('FLUTC'//diag(icall), 1, ' ') + call add_default('LWCF'//diag(icall), 1, ' ') + call add_default('FLNS'//diag(icall), 1, ' ') + call add_default('FLNSC'//diag(icall), 1, ' ') + call add_default('FLDS'//diag(icall), 1, ' ') + endif + + end if + end do + + call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') + + if (scm_crm_mode) then + call add_default ('FUL ', 1, ' ') + call add_default ('FULC ', 1, ' ') + call add_default ('FDL ', 1, ' ') + call add_default ('FDLC ', 1, ' ') + endif + + ! Heating rate needed for d(theta)/dt computation + call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') + + if ( history_budget .and. history_budget_histfile_num > 1 ) then + call add_default ('QRL ', history_budget_histfile_num, ' ') + call add_default ('QRS ', history_budget_histfile_num, ' ') + end if + + if (history_vdiag) then + call add_default('FLUT', 2, ' ') + call add_default('FLUT', 3, ' ') + end if + + end subroutine radiation_init + + !=============================================================================== + + subroutine radiation_define_restart(file) + + ! define variables to be written to restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- + + call pio_seterrorhandling(File, PIO_BCAST_ERROR) + + if (docosp) then + ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) + end if + + end subroutine radiation_define_restart + + !=============================================================================== + + subroutine radiation_write_restart(file) + + ! write variables to restart file + + ! arguments + type(file_desc_t), intent(inout) :: file + + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- + + if (docosp) then + ierr = pio_put_var(File, cospcnt_desc, (/cosp_cnt(begchunk)/)) + end if + + end subroutine radiation_write_restart + + !=============================================================================== - ! write variables to restart file + subroutine radiation_read_restart(file) - ! arguments - type(file_desc_t), intent(inout) :: file + ! read variables from restart file - ! local variables - integer :: ierr - !---------------------------------------------------------------------------- + ! arguments + type(file_desc_t), intent(inout) :: file - if (docosp) then - ierr = pio_put_var(File, cospcnt_desc, (/cosp_cnt(begchunk)/)) - end if + ! local variables -end subroutine radiation_write_restart - -!=============================================================================== + integer :: err_handling + integer :: ierr -subroutine radiation_read_restart(file) + type(var_desc_t) :: vardesc + !---------------------------------------------------------------------------- - ! read variables from restart file + if (docosp) then + call pio_seterrorhandling(File, PIO_BCAST_ERROR, err_handling) + ierr = pio_inq_varid(File, 'cosp_cnt_init', vardesc) + call pio_seterrorhandling(File, err_handling) + if (ierr /= PIO_NOERR) then + cosp_cnt_init = 0 + else + ierr = pio_get_var(File, vardesc, cosp_cnt_init) + end if + end if - ! arguments - type(file_desc_t), intent(inout) :: file + end subroutine radiation_read_restart - ! local variables + !=============================================================================== - integer :: err_handling - integer :: ierr + subroutine radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) - type(var_desc_t) :: vardesc - !---------------------------------------------------------------------------- + !----------------------------------------------------------------------- + ! + ! Driver for radiation computation. + ! + ! Revision history: + ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. + ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. + ! + ! 2019-05-06 A. KirkevÃ¥g: Changes for testing the + ! "simple plumes" aerosols, based on NorESM1 code P. Räisänen. + !----------------------------------------------------------------------- - if (docosp) then - call pio_seterrorhandling(File, PIO_BCAST_ERROR, err_handling) - ierr = pio_inq_varid(File, 'cosp_cnt_init', vardesc) - call pio_seterrorhandling(File, err_handling) - if (ierr /= PIO_NOERR) then - cosp_cnt_init = 0 - else - ierr = pio_get_var(File, vardesc, cosp_cnt_init) - end if - end if + use phys_grid, only: get_rlat_all_p, get_rlon_all_p + use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr + use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz -end subroutine radiation_read_restart - -!=============================================================================== + use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw -subroutine radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) - - !----------------------------------------------------------------------- - ! - ! Driver for radiation computation. - ! - ! Revision history: - ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. - ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. - !----------------------------------------------------------------------- - - use phys_grid, only: get_rlat_all_p, get_rlon_all_p - use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr - use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz - - use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw - - use cloud_rad_props, only: get_ice_optics_sw, get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & - ice_cloud_get_rad_props_lw, cloud_rad_props_get_lw, & - snow_cloud_get_rad_props_lw, get_snow_optics_sw - use slingo, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw - use ebert_curry, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw - - use rad_solar_var, only: get_variability - use radsw, only: rad_rrtmg_sw - use radlw, only: rad_rrtmg_lw - use radheat, only: radheat_tend - - use radiation_data, only: rad_data_write - use rrtmg_state, only: rrtmg_state_create, rrtmg_state_update, rrtmg_state_destroy, rrtmg_state_t, & - num_rrtmg_levs - - use interpolate_data, only: vertinterp - use tropopause, only: tropopause_find, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE - - use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps - - ! Arguments - type(physics_state), intent(in), target :: state - type(physics_ptend), intent(out) :: ptend - - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(inout) :: cam_out - type(cam_in_t), intent(in) :: cam_in - real(r8), intent(out) :: net_flx(pcols) - - type(rad_out_t), target, optional, intent(out) :: rd_out - - - ! Local variables - type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object - ! if the argument is not present - logical :: write_output - - integer :: i, k - integer :: lchnk, ncol - logical :: dosw, dolw - - real(r8) :: calday ! current calendar day - real(r8) :: delta ! Solar declination angle in radians - real(r8) :: eccf ! Earth orbit eccentricity factor - real(r8) :: clat(pcols) ! current latitudes(radians) - real(r8) :: clon(pcols) ! current longitudes(radians) - real(r8) :: coszrs(pcols) ! Cosine solar zenith angle - - ! Gathered indices of day and night columns - ! chunk_column_index = IdxDay(daylight_column_index) - integer :: Nday ! Number of daylight columns - integer :: Nnite ! Number of night columns - integer :: IdxDay(pcols) ! Indices of daylight columns - integer :: IdxNite(pcols) ! Indices of night columns - - integer :: itim_old - - real(r8), pointer :: cld(:,:) ! cloud fraction - real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" - real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate - real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate - real(r8), pointer :: fsds(:) ! Surface solar down flux - real(r8), pointer :: fsns(:) ! Surface solar absorbed flux - real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top - real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux - real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top - - real(r8), pointer, dimension(:,:,:) :: su => NULL() ! shortwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: sd => NULL() ! shortwave spectral flux down - real(r8), pointer, dimension(:,:,:) :: lu => NULL() ! longwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: ld => NULL() ! longwave spectral flux down - - ! tropopause diagnostic - integer :: troplev(pcols) - real(r8) :: p_trop(pcols) - - type(rrtmg_state_t), pointer :: r_state ! contains the atm concentrations in layers needed for RRTMG - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: ice_tau (nswbands,pcols,pver) ! ice extinction optical depth - real(r8) :: ice_tau_w (nswbands,pcols,pver) ! ice single scattering albedo * tau - real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice assymetry parameter * tau * w - real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! ice forward scattered fraction * tau * w - real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth - real(r8) :: liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau - real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w - real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w - real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: cld_tau (nswbands,pcols,pver) ! cloud extinction optical depth - real(r8) :: cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau - real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau - real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau - real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth - real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau - real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow assymetry parameter * tau * w - real(r8) :: snow_tau_w_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w - real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) - - ! combined cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) - real(r8) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth - real(r8) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau - real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau - real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau - real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) - - real(r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band - - integer :: icall ! index through climate/diagnostic radiation calls - logical :: active_calls(0:N_DIAG) - - ! Aerosol radiative properties - real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth - real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau - real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau - real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) - - real(r8) :: fns(pcols,pverp) ! net shortwave flux - real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux - real(r8) :: fnl(pcols,pverp) ! net longwave flux - real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux - - ! for COSP - real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity - real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau - real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth - - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables - - real(r8) :: freqclr(pcols) ! Frequency of occurrence of clear sky columns - real(r8) :: flntclr(pcols) ! Clearsky only columns (zero if cloudy) - - character(*), parameter :: name = 'radiation_tend' - - logical, parameter :: cosz_rad_call=.true. !+tht - !-------------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - - if (present(rd_out)) then - rd => rd_out - write_output = .false. - else - allocate(rd) - write_output=.true. - end if - - dosw = radiation_do('sw') ! do shortwave heating calc this timestep? - dolw = radiation_do('lw') ! do longwave heating calc this timestep? - - ! Cosine solar zenith angle for current time step - calday = get_curr_calday() - call get_rlat_all_p(lchnk, ncol, clat) - call get_rlon_all_p(lchnk, ncol, clon) - - call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & - delta, eccf) - do i = 1, ncol - coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, cosz_rad_call) !+tht - end do - - ! Gather night/day column indices. - Nday = 0 - Nnite = 0 - do i = 1, ncol - if ( coszrs(i) > 0.0_r8 ) then - Nday = Nday + 1 - IdxDay(Nday) = i - else - Nnite = Nnite + 1 - IdxNite(Nnite) = i - end if - end do - - ! Associate pointers to physics buffer fields - itim_old = pbuf_old_tim_idx() - if (cldfsnow_idx > 0) then - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - endif - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, qrl_idx, qrl) - - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, fsds_idx, fsds) - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, flns_idx, flns) - call pbuf_get_field(pbuf, flnt_idx, flnt) - - if (spectralflux) then - call pbuf_get_field(pbuf, su_idx, su) - call pbuf_get_field(pbuf, sd_idx, sd) - call pbuf_get_field(pbuf, lu_idx, lu) - call pbuf_get_field(pbuf, ld_idx, ld) - end if - - ! For CRM, make cloud equal to input observations: - if (scm_crm_mode .and. have_cld) then - do k = 1, pver - cld(:ncol,k)= cldobs(k) - end do - end if - - ! Find tropopause height if needed for diagnostic output - if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then - call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) - endif - - if (dosw .or. dolw) then - - ! construct an RRTMG state object - r_state => rrtmg_state_create( state, cam_in ) - - call t_startf('cldoptics') - - if (cldfsnow_idx > 0) then - do k = 1, pver - do i = 1, ncol - cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) - end do - end do - else - cldfprime(:ncol,:) = cld(:ncol,:) - end if - - - if (dosw) then - - if (oldcldoptics) then - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) - case ('mitchell') - call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) - case default - call endrun('iccldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) - case ('gammadist') - call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) - case default - call endrun('liqcldoptics must be either slingo or gammadist') - end select - end if - - cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) - cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) - cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) - cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) - - if (cldfsnow_idx > 0) then - ! add in snow - call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) - do i = 1, ncol - do k = 1, pver - - if (cldfprime(i,k) > 0._r8) then - - c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & - + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & - + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & - + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & - + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) - else - c_cld_tau(:,i,k) = 0._r8 - c_cld_tau_w(:,i,k) = 0._r8 - c_cld_tau_w_g(:,i,k) = 0._r8 - c_cld_tau_w_f(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) - c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) - c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) - c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) - end if - - ! Output cloud optical depth fields for the visible band - rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) - rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) - rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) - - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) - endif - - ! multiply by total cloud fraction to get gridbox value - rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) - - ! add fillvalue for night columns - do i = 1, Nnite - rd%tot_cld_vistau(IdxNite(i),:) = fillvalue - rd%tot_icld_vistau(IdxNite(i),:) = fillvalue - rd%liq_icld_vistau(IdxNite(i),:) = fillvalue - rd%ice_icld_vistau(IdxNite(i),:) = fillvalue - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(IdxNite(i),:) = fillvalue - end if - end do - - if (write_output) call radiation_output_cld(lchnk, ncol, rd) - - end if ! if (dosw) - - if (dolw) then - - if (oldcldoptics) then - call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) - case ('mitchell') - call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) - case default - call endrun('iccldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) - case ('gammadist') - call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) - case default - call endrun('liqcldoptics must be either slingo or gammadist') - end select - - cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) - - end if - - if (cldfsnow_idx > 0) then - - ! add in snow - call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) - - do i = 1, ncol - do k = 1, pver - if (cldfprime(i,k) > 0._r8) then - c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & - + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) - else - c_cld_lw_abs(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) - end if - - end if ! if (dolw) - - call t_stopf('cldoptics') - - ! Solar radiation computation - - if (dosw) then - - call get_variability(sfac) - - ! Get the active climate/diagnostic shortwave calculations - call rad_cnst_get_call_list(active_calls) - - ! The climate (icall==0) calculation must occur last. - do icall = N_DIAG, 0, -1 - - if (active_calls(icall)) then - - ! update the concentrations in the RRTMG state object - call rrtmg_state_update(state, pbuf, icall, r_state) + use cloud_rad_props, only: get_ice_optics_sw, get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & + ice_cloud_get_rad_props_lw, cloud_rad_props_get_lw, & + snow_cloud_get_rad_props_lw, get_snow_optics_sw + use slingo, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw + use ebert_curry, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw + use rad_solar_var, only: get_variability + use radsw, only: rad_rrtmg_sw + use radlw, only: rad_rrtmg_lw + use radheat, only: radheat_tend + + use radiation_data, only: rad_data_write + use rrtmg_state, only: rrtmg_state_create, rrtmg_state_update, rrtmg_state_destroy, rrtmg_state_t, & + num_rrtmg_levs + + use interpolate_data, only: vertinterp + use tropopause, only: tropopause_find, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE + + use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps + + use constituents, only: pcnst +#ifdef OSLO_AERO + use physics_buffer, only: pbuf_get_index + use oslo_aero_control, only: oslo_aero_getopts + use commondefinitions + use aerosoldef +#endif + +#ifdef OSLO_AERO + real(r8) :: flnt_tmp(pcols) ! Net outgoing lw flux at model top for AIE calculations + real(r8) :: volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode + integer :: band + character(len=3) :: c3 + logical :: idrf +#endif + + ! Arguments + type(physics_state), intent(in), target :: state + type(physics_ptend), intent(out) :: ptend + + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in + real(r8), intent(out) :: net_flx(pcols) + + type(rad_out_t), target, optional, intent(out) :: rd_out + + + ! Local variables + type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object + ! if the argument is not present + logical :: write_output + + integer :: i, k + integer :: lchnk, ncol + logical :: dosw, dolw + +#ifdef OSLO_AERO + real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr + real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) +#endif + real(r8) :: calday ! current calendar day + real(r8) :: delta ! Solar declination angle in radians + real(r8) :: eccf ! Earth orbit eccentricity factor + real(r8) :: clat(pcols) ! current latitudes(radians) + real(r8) :: clon(pcols) ! current longitudes(radians) + real(r8) :: coszrs(pcols) ! Cosine solar zenith angle + + ! Gathered indices of day and night columns + ! chunk_column_index = IdxDay(daylight_column_index) + integer :: Nday ! Number of daylight columns + integer :: Nnite ! Number of night columns + integer :: IdxDay(pcols) ! Indices of daylight columns + integer :: IdxNite(pcols) ! Indices of night columns + + integer :: itim_old + + real(r8), pointer :: cld(:,:) ! cloud fraction + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" + real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate + real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate + real(r8), pointer :: fsds(:) ! Surface solar down flux + real(r8), pointer :: fsns(:) ! Surface solar absorbed flux + real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top + real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux + real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top + + real(r8), pointer, dimension(:,:,:) :: su => NULL() ! shortwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: sd => NULL() ! shortwave spectral flux down + real(r8), pointer, dimension(:,:,:) :: lu => NULL() ! longwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: ld => NULL() ! longwave spectral flux down + + ! tropopause diagnostic + integer :: troplev(pcols) + real(r8) :: p_trop(pcols) + + type(rrtmg_state_t), pointer :: r_state ! contains the atm concentrations in layers needed for RRTMG + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: ice_tau (nswbands,pcols,pver) ! ice extinction optical depth + real(r8) :: ice_tau_w (nswbands,pcols,pver) ! ice single scattering albedo * tau + real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice assymetry parameter * tau * w + real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! ice forward scattered fraction * tau * w + real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth + real(r8) :: liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau + real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w + real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w + real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: cld_tau (nswbands,pcols,pver) ! cloud extinction optical depth + real(r8) :: cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau + real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau + real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau + real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth + real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau + real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow assymetry parameter * tau * w + real(r8) :: snow_tau_w_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w + real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) + + ! combined cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) + real(r8) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth + real(r8) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau + real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau + real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau + real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) + + real(r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band + + integer :: icall ! index through climate/diagnostic radiation calls + logical :: active_calls(0:N_DIAG) + + ! Aerosol radiative properties + real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth + real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau + real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau + real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + +#ifdef OSLO_AERO + ! Local variables used for calculating aerosol optics and direct and indirect forcings. + ! aodvis and absvis are AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) + ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values + real(r8) :: qdirind(pcols,pver,pcnst) ! Common tracers for indirect and direct calculations + real(r8) :: aodvis(pcols) ! AOD vis + real(r8) :: absvis(pcols) ! absorptive AOD vis + real(r8) :: clearodvis(pcols), clearabsvis(pcols), cloudfree(pcols), cloudfreemax(pcols) +#ifdef AEROCOM + real(r8) :: dod440(pcols),dod550(pcols),dod870(pcols),abs550(pcols),abs550alt(pcols) + real(r8) :: clearod440(pcols),clearod550(pcols),clearod870(pcols),clearabs550(pcols),clearabs550alt(pcols) +#endif + real(r8) :: ftem_1d(pcols) ! work-array to avoid NAN and pcols/ncol confusion + real(r8) :: Nnatk(pcols,pver,0:nmodes) ! Modal aerosol number concentration + real(r8) :: batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW + real(r8) :: rhoda(pcols,pver) ! air mass density, unit kg/m^3 + real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn + integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn + real(r8) :: rhtrunc(pcols,pver) ! relative humidity (as fraction) + real(r8) :: per_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth + real(r8) :: per_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau + real(r8) :: per_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8) :: per_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau + real(r8) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + integer :: ns ! spectral loop index + real(r8) :: volc_ext_sun(pcols,pver,nswbands) ! volcanic aerosol extinction for solar bands, CMIP6 + real(r8) :: volc_omega_sun(pcols,pver,nswbands) ! volcanic aerosol SSA for solar bands, CMIP6 + real(r8) :: volc_g_sun(pcols,pver,nswbands) ! volcanic aerosol g for solar bands, CMIP6 + real(r8) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 + real(r8) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 +#endif + + real(r8) :: fns(pcols,pverp) ! net shortwave flux + real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux + real(r8) :: fnl(pcols,pverp) ! net longwave flux + real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux + + ! for COSP + real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity + real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau + real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth + + real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables + + real(r8) :: freqclr(pcols) ! Frequency of occurrence of clear sky columns + real(r8) :: flntclr(pcols) ! Clearsky only columns (zero if cloudy) + + character(*), parameter :: name = 'radiation_tend' + + logical, parameter :: cosz_rad_call=.true. !+tht + !-------------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + +#ifdef OSLO_AERO + per_lw_abs(:,:,:)=0._r8 + per_tau(:,:,:)=0._r8 + per_tau_w(:,:,:)=0._r8 + per_tau_w_g(:,:,:)=0._r8 + per_tau_w_f(:,:,:)=0._r8 +#endif + + if (present(rd_out)) then + rd => rd_out + write_output = .false. + else + allocate(rd) + write_output=.true. + end if + + dosw = radiation_do('sw') ! do shortwave heating calc this timestep? + dolw = radiation_do('lw') ! do longwave heating calc this timestep? + + ! Cosine solar zenith angle for current time step + calday = get_curr_calday() + call get_rlat_all_p(lchnk, ncol, clat) + call get_rlon_all_p(lchnk, ncol, clon) + + call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & + delta, eccf) + do i = 1, ncol + coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, cosz_rad_call) !+tht + end do + + ! Gather night/day column indices. + Nday = 0 + Nnite = 0 + do i = 1, ncol + if ( coszrs(i) > 0.0_r8 ) then + Nday = Nday + 1 + IdxDay(Nday) = i + else + Nnite = Nnite + 1 + IdxNite(Nnite) = i + end if + end do + + ! Associate pointers to physics buffer fields + itim_old = pbuf_old_tim_idx() + if (cldfsnow_idx > 0) then + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + endif + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, qrl_idx, qrl) + + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsds_idx, fsds) + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, flns_idx, flns) + call pbuf_get_field(pbuf, flnt_idx, flnt) + + if (spectralflux) then + call pbuf_get_field(pbuf, su_idx, su) + call pbuf_get_field(pbuf, sd_idx, sd) + call pbuf_get_field(pbuf, lu_idx, lu) + call pbuf_get_field(pbuf, ld_idx, ld) + end if + + ! For CRM, make cloud equal to input observations: + if (scm_crm_mode .and. have_cld) then + do k = 1, pver + cld(:ncol,k)= cldobs(k) + end do + end if + +#ifdef OSLO_AERO + qdirind(:ncol,:,:) = state%q(:ncol,:,:) + if (has_prescribed_volcaero) then + call oslo_aero_getopts(volc_fraction_coarse_out = volc_fraction_coarse) + call pbuf_get_field(pbuf, volc_idx, rvolcmmr, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + qdirind(:ncol,:,l_so4_pr) = qdirind(:ncol,:,l_so4_pr) + (1.0_r8 - volc_fraction_coarse)*rvolcmmr(:ncol,:) + qdirind(:ncol,:,l_ss_a3) = qdirind(:ncol,:,l_ss_a3) + volc_fraction_coarse*rvolcmmr(:ncol,:) + end if +#endif + + ! Find tropopause height if needed for diagnostic output + if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then + call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) + endif + + if (dosw .or. dolw) then + + ! construct an RRTMG state object + r_state => rrtmg_state_create( state, cam_in ) + + call t_startf('cldoptics') + + if (cldfsnow_idx > 0) then + do k = 1, pver + do i = 1, ncol + cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) + end do + end do + else + cldfprime(:ncol,:) = cld(:ncol,:) + end if + + + if (dosw) then + + + if (oldcldoptics) then + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) + case ('mitchell') + call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) + case default + call endrun('iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) + case ('gammadist') + + call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) + + case default + call endrun('liqcldoptics must be either slingo or gammadist') + end select + end if + + cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) + cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) + cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) + cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) + + if (cldfsnow_idx > 0) then + ! add in snow + call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) + do i = 1, ncol + do k = 1, pver + + if (cldfprime(i,k) > 0._r8) then + + c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & + + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & + + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & + + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & + + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) + else + c_cld_tau(:,i,k) = 0._r8 + c_cld_tau_w(:,i,k) = 0._r8 + c_cld_tau_w_g(:,i,k) = 0._r8 + c_cld_tau_w_f(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) + c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) + c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) + c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) + end if + + ! Output cloud optical depth fields for the visible band + rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) + rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) + rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) + + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) + endif + + ! multiply by total cloud fraction to get gridbox value + rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) + + ! add fillvalue for night columns + do i = 1, Nnite + rd%tot_cld_vistau(IdxNite(i),:) = fillvalue + rd%tot_icld_vistau(IdxNite(i),:) = fillvalue + rd%liq_icld_vistau(IdxNite(i),:) = fillvalue + rd%ice_icld_vistau(IdxNite(i),:) = fillvalue + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(IdxNite(i),:) = fillvalue + end if + end do + + if (write_output) call radiation_output_cld(lchnk, ncol, rd) + + end if ! if (dosw) + + if (dolw) then + + if (oldcldoptics) then + call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) + case ('mitchell') + call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) + case default + call endrun('iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) + case ('gammadist') + call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) + case default + call endrun('liqcldoptics must be either slingo or gammadist') + end select + + cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) + + end if + + if (cldfsnow_idx > 0) then + + ! add in snow + call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) + + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0._r8) then + c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & + + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) + else + c_cld_lw_abs(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) + end if + + end if ! if (dolw) + + call t_stopf('cldoptics') + + ! Solar radiation computation + + if (dosw) then + +#ifdef OSLO_AERO + ! Volcanic optics for solar (SW) bands + do band=1, solar_bands + volc_ext_sun(1:ncol,1:pver,band)=0.0_r8 + volc_omega_sun(1:ncol,1:pver,band)=0.999_r8 + volc_g_sun(1:ncol,1:pver,band)=0.5_r8 + enddo + if (has_prescribed_volcaero_cmip6) then + do band=1, solar_bands + write(c3,'(i3)') band + volc_idx = pbuf_get_index('ext_sun'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_ext_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + volc_idx = pbuf_get_index('omega_sun'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_omega_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + volc_idx = pbuf_get_index('g_sun'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_g_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + enddo + endif + ! Volcanic optics for terrestrial (LW) bands (g is not used here) + do band=1, terrestrial_bands + volc_ext_earth(1:ncol,1:pver,band)=0.0_r8 + volc_omega_earth(1:ncol,1:pver,band)=0.999_r8 + enddo + if (has_prescribed_volcaero_cmip6) then + do band=1, terrestrial_bands + write(c3,'(i3)') band + volc_idx = pbuf_get_index('ext_earth'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_ext_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + + volc_idx = pbuf_get_index('omega_earth'//trim(adjustl(c3))) + call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + volc_omega_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) + enddo + endif + + ! No aerocom variables passed for now + ! dod440, dod550, dod870, abs550, abs550alt + call oslo_aero_optical_params_calc(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & + coszrs, state, state%t, cld, qdirind, Nnatk, & + per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & + volc_ext_sun, volc_omega_sun, volc_g_sun, volc_ext_earth, volc_omega_earth, & + aodvis, absvis) + +#endif + call get_variability(sfac) + + ! Get the active climate/diagnostic shortwave calculations + call rad_cnst_get_call_list(active_calls) + + ! The climate (icall==0) calculation must occur last. + do icall = N_DIAG, 0, -1 + + if (active_calls(icall)) then + + ! update the concentrations in the RRTMG state object + call rrtmg_state_update(state, pbuf, icall, r_state) + +#ifdef OSLO_AERO + !call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & + ! aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) + ! A first call with Oslo aerosols set to zero for radiative forcing diagnostics + ! follwoing the Ghan (2013) method: + + ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore + ! (just nudged), but with an extra call with 0 aerosol extiction. + ! + idrf = .true. + call rad_rrtmg_sw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + cldfprime, & + per_tau*0.0_r8, per_tau_w, per_tau_w_g, per_tau_w_f, & + eccf, coszrs, rd%solin, sfac, cam_in%asdir, & + cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & + fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & + rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & + rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & + IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & + E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & + E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) + + + ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair + ! + ! Dump shortwave radiation information to history tape buffer (diagnostics) + ! + ! Note that DRF fields are now from the per_tau=0 call (clean), no longer with per_tau from pmxsub + call outfld('QRS_DRF ',ftem ,pcols,lchnk) + ftem(:ncol,:pver) = rd%qrsc(:ncol,:pver)/cpair + call outfld('QRSC_DRF',ftem ,pcols,lchnk) + call outfld('FSNT_DRF',fsnt(:) ,pcols,lchnk) + call outfld('FSNS_DRF',fsns(:) ,pcols,lchnk) + call outfld('FSNTCDRF',rd%fsntc(:) ,pcols,lchnk) + call outfld('FSNSCDRF',rd%fsnsc(:) ,pcols,lchnk) + if (do_aerocom) then + call outfld('FSUTADRF',rd%fsutoa(:),pcols,lchnk) + call outfld('FSDS_DRF',fsds(:) ,pcols,lchnk) + ftem_1d(1:ncol) = fsds(1:ncol)-fsns(1:ncol) + call outfld('FSUS_DRF',ftem_1d,pcols,lchnk) + call outfld('FSDSCDRF',rd%fsdsc(:) ,pcols,lchnk) + end if + idrf = .false. +#else call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) - - rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) - rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) - rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) - rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) - - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & - eccf, coszrs, rd%solin, sfac, cam_in%asdir, & - cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & - fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & - rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & - rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, Nday, Nnite, & - IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & - E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & - E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) - - ! Output net fluxes at 200 mb - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) - if (hist_fld_active('FSNR')) then - do i = 1,ncol - call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) - end do - end if - - if (write_output) call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) - - end if - end do - - end if - - ! Output aerosol mmr - call rad_cnst_out(0, state, pbuf) - - ! Longwave radiation computation - - if (dolw) then - - call rad_cnst_get_call_list(active_calls) - - ! The climate (icall==0) calculation must occur last. - do icall = N_DIAG, 0, -1 - - if (active_calls(icall)) then - - ! update the conctrations in the RRTMG state object - call rrtmg_state_update( state, pbuf, icall, r_state) - - call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) - - call rad_rrtmg_lw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - aer_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & - flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & - rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & - lu, ld) - - ! Output fluxes at 200 mb - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) - if (hist_fld_active('FLNR')) then - do i = 1,ncol - call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fnl(i,:), rd%flnr(i)) - end do - end if - - flntclr(:) = 0._r8 - freqclr(:) = 0._r8 - do i = 1, ncol - if (maxval(cldfprime(i,:)) <= 0.1_r8) then - freqclr(i) = 1._r8 - flntclr(i) = rd%flntc(i) - end if - end do - - if (write_output) call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) - - end if - end do - - end if - - ! deconstruct the RRTMG state object - call rrtmg_state_destroy(r_state) - - if (docosp) then - - ! initialize and calculate emis - emis(:,:) = 0._r8 - emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(rrtmg_lw_cloudsim_band,:ncol,:)) - call outfld('EMIS', emis, pcols, lchnk) - - ! compute grid-box mean SW and LW snow optical depth for use by COSP - gb_snow_tau(:,:) = 0._r8 - gb_snow_lw(:,:) = 0._r8 - if (cldfsnow_idx > 0) then - do i = 1, ncol - do k = 1, pver - if (cldfsnow(i,k) > 0._r8) then - gb_snow_tau(i,k) = snow_tau(rrtmg_sw_cloudsim_band,i,k)*cldfsnow(i,k) - gb_snow_lw(i,k) = snow_lw_abs(rrtmg_lw_cloudsim_band,i,k)*cldfsnow(i,k) - end if - end do - end do - end if - - ! advance counter for this timestep (chunk dimension required for thread safety) - cosp_cnt(lchnk) = cosp_cnt(lchnk) + 1 - - ! if counter is the same as cosp_nradsteps, run cosp and reset counter - if (cosp_nradsteps .eq. cosp_cnt(lchnk)) then - - ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave - ! optical depths are passed. - call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & - cld_swtau_in=cld_tau(rrtmg_sw_cloudsim_band,:,:),& - snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) - cosp_cnt(lchnk) = 0 - end if - end if - - else ! if (dosw .or. dolw) then - - ! convert radiative heating rates from Q*dp to Q for energy conservation - do k =1 , pver - do i = 1, ncol - qrs(i,k) = qrs(i,k)/state%pdel(i,k) - qrl(i,k) = qrl(i,k)/state%pdel(i,k) - end do - end do - - end if ! if (dosw .or. dolw) then +#endif + + rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) + rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) + rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) + rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) + +#ifdef OSLO_AERO + call rad_rrtmg_sw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + cldfprime, per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & + eccf, coszrs, rd%solin, sfac, cam_in%asdir, & + cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & + fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & + rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & + rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & ! Note the extra idrf + IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & + E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & + E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) +#else + call rad_rrtmg_sw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + cldfprime, aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & + eccf, coszrs, rd%solin, sfac, cam_in%asdir, & + cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & + fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & + rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & + rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & + cam_out%solld, fns, fcns, Nday, Nnite, & + IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & + E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & + E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) +#endif + + ! Output net fluxes at 200 mb + + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) + if (hist_fld_active('FSNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) + end do + end if + + if (write_output) call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) + + end if + end do + + end if + +#ifdef OSLO_AERO + !Calculate cloud-free fraction assuming random overlap + !(kind of duplicated from cloud_cover_diags::cldsav) + cloudfree(1:ncol) = 1.0_r8 + cloudfreemax(1:ncol) = 1.0_r8 + !Find cloud-free fraction (note this duplicated code and may not be consistent with cldtot calculated elsewhere) + do k = 1, pver + do i=1,ncol + cloudfree(i) = cloudfree(i) * cloudfreemax(i) + cloudfreemax(i) = min(cloudfreemax(i),1.0_r8-cld(i,k)) + end do + end do + + !Calculate AOD (visible) for cloud free + do i = 1, ncol + clearodvis(i)=cloudfree(i)*aodvis(i) + clearabsvis(i)=cloudfree(i)*absvis(i) + end do + + ! clear-sky AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) + ! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values + call outfld('CAODVIS ',clearodvis,pcols,lchnk) + call outfld('CABSVIS ',clearabsvis,pcols,lchnk) + call outfld('CLDFREE ',cloudfree,pcols,lchnk) +#ifdef AEROCOM + if (do_aerocom) then + do i = 1, ncol + clearod440(i)=cloudfree(i)*dod440(i) + clearod550(i)=cloudfree(i)*dod550(i) + clearod870(i)=cloudfree(i)*dod870(i) + clearabs550(i)=cloudfree(i)*abs550(i) + clearabs550alt(i)=cloudfree(i)*abs550alt(i) + end do + call outfld('CDOD440 ',clearod440 ,pcols,lchnk) + call outfld('CDOD550 ',clearod550 ,pcols,lchnk) + call outfld('CDOD870 ',clearod870 ,pcols,lchnk) + call outfld('CABS550 ',clearabs550 ,pcols,lchnk) + call outfld('CABS550A',clearabs550alt,pcols,lchnk) + end if +#endif +#endif + + ! Output aerosol mmr + call rad_cnst_out(0, state, pbuf) + + ! Longwave radiation computation + + if (dolw) then + + call rad_cnst_get_call_list(active_calls) + + ! The climate (icall==0) calculation must occur last. + do icall = N_DIAG, 0, -1 + + if (active_calls(icall)) then + + ! update the conctrations in the RRTMG state object + call rrtmg_state_update( state, pbuf, icall, r_state) + + call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) + + ! for calculation of direct and direct radiative forcing + +#ifdef OSLO_AERO + call rad_rrtmg_lw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + per_lw_abs*0.0_r8, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & + flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & + rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & + lu, ld) + + call outfld('FLNT_DRF',flnt(:) ,pcols,lchnk) + call outfld('FLNTCDRF',rd%flntc(:) ,pcols,lchnk) + + call rad_rrtmg_lw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + per_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & + flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & + rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & + lu, ld) + + ! FLNT_ORG is just for temporary testing vs. FLNT + ftem_1d(1:ncol) = cam_out%flwds(1:ncol) - flns(1:ncol) + call outfld('FLUS ',ftem_1d ,pcols,lchnk) +#else + call rad_rrtmg_lw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + aer_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & + flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & + rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & + lu, ld) +#endif + + ! Output fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) + if (hist_fld_active('FLNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fnl(i,:), rd%flnr(i)) + end do + end if + + flntclr(:) = 0._r8 + freqclr(:) = 0._r8 + do i = 1, ncol + if (maxval(cldfprime(i,:)) <= 0.1_r8) then + freqclr(i) = 1._r8 + flntclr(i) = rd%flntc(i) + end if + end do + + if (write_output) call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) + + end if + end do + + end if + + ! deconstruct the RRTMG state object + call rrtmg_state_destroy(r_state) + + if (docosp) then + + ! initialize and calculate emis + emis(:,:) = 0._r8 + emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(rrtmg_lw_cloudsim_band,:ncol,:)) + call outfld('EMIS', emis, pcols, lchnk) + + ! compute grid-box mean SW and LW snow optical depth for use by COSP + gb_snow_tau(:,:) = 0._r8 + gb_snow_lw(:,:) = 0._r8 + if (cldfsnow_idx > 0) then + do i = 1, ncol + do k = 1, pver + if (cldfsnow(i,k) > 0._r8) then + gb_snow_tau(i,k) = snow_tau(rrtmg_sw_cloudsim_band,i,k)*cldfsnow(i,k) + gb_snow_lw(i,k) = snow_lw_abs(rrtmg_lw_cloudsim_band,i,k)*cldfsnow(i,k) + end if + end do + end do + end if + + ! advance counter for this timestep (chunk dimension required for thread safety) + cosp_cnt(lchnk) = cosp_cnt(lchnk) + 1 + + ! if counter is the same as cosp_nradsteps, run cosp and reset counter + if (cosp_nradsteps .eq. cosp_cnt(lchnk)) then + + ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave + ! optical depths are passed. + call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & + cld_swtau_in=cld_tau(rrtmg_sw_cloudsim_band,:,:),& + snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) + cosp_cnt(lchnk) = 0 + end if + end if + + else ! if (dosw .or. dolw) then + + ! convert radiative heating rates from Q*dp to Q for energy conservation + do k =1 , pver + do i = 1, ncol + qrs(i,k) = qrs(i,k)/state%pdel(i,k) + qrl(i,k) = qrl(i,k)/state%pdel(i,k) + end do + end do + + end if ! if (dosw .or. dolw) then ! output rad inputs and resulting heating rates call rad_data_write( pbuf, state, cam_in, coszrs ) - ! Compute net radiative heating tendency - call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & - fsnt, flns, flnt, cam_in%asdir, net_flx) + ! Compute net radiative heating tendency + call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & + fsnt, flns, flnt, cam_in%asdir, net_flx) - if (write_output) then - ! Compute heating rate for dtheta/dt - do k = 1, pver - do i = 1, ncol - ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa - end do - end do - call outfld('HR', ftem, pcols, lchnk) - end if + if (write_output) then + ! Compute heating rate for dtheta/dt + do k = 1, pver + do i = 1, ncol + ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa + end do + end do + call outfld('HR', ftem, pcols, lchnk) + end if - ! convert radiative heating rates to Q*dp for energy conservation - do k = 1, pver - do i = 1, ncol - qrs(i,k) = qrs(i,k)*state%pdel(i,k) - qrl(i,k) = qrl(i,k)*state%pdel(i,k) - end do - end do + ! convert radiative heating rates to Q*dp for energy conservation + do k = 1, pver + do i = 1, ncol + qrs(i,k) = qrs(i,k)*state%pdel(i,k) + qrl(i,k) = qrl(i,k)*state%pdel(i,k) + end do + end do - cam_out%netsw(:ncol) = fsns(:ncol) + cam_out%netsw(:ncol) = fsns(:ncol) - if (.not. present(rd_out)) then - deallocate(rd) - end if + if (.not. present(rd_out)) then + deallocate(rd) + end if -end subroutine radiation_tend + end subroutine radiation_tend -!=============================================================================== + !=============================================================================== -subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) + subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) - ! Dump shortwave radiation information to history buffer. + ! Dump shortwave radiation information to history buffer. - integer , intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: icall - type(rad_out_t), intent(in) :: rd - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(in) :: cam_out + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out - ! local variables - real(r8), pointer :: qrs(:,:) - real(r8), pointer :: fsnt(:) - real(r8), pointer :: fsns(:) - real(r8), pointer :: fsds(:) + ! local variables + real(r8), pointer :: qrs(:,:) + real(r8), pointer :: fsnt(:) + real(r8), pointer :: fsns(:) + real(r8), pointer :: fsds(:) - real(r8) :: ftem(pcols) - !---------------------------------------------------------------------------- + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, fsds_idx, fsds) + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, fsds_idx, fsds) - call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) + call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) - call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) - call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) - call outfld('FSNT'//diag(icall), fsnt, pcols, lchnk) - call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) - call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) - call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) + call outfld('FSNT'//diag(icall), fsnt, pcols, lchnk) + call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) + call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) + call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) - ftem(:ncol) = rd%fsntoa(:ncol) - rd%fsntoac(:ncol) - call outfld('SWCF'//diag(icall), ftem, pcols, lchnk) + ftem(:ncol) = rd%fsntoa(:ncol) - rd%fsntoac(:ncol) + call outfld('SWCF'//diag(icall), ftem, pcols, lchnk) - call outfld('FSUTOA'//diag(icall), rd%fsutoa, pcols, lchnk) + call outfld('FSUTOA'//diag(icall), rd%fsutoa, pcols, lchnk) - call outfld('FSNIRTOA'//diag(icall), rd%fsnirt, pcols, lchnk) - call outfld('FSNRTOAC'//diag(icall), rd%fsnrtc, pcols, lchnk) - call outfld('FSNRTOAS'//diag(icall), rd%fsnirtsq, pcols, lchnk) + call outfld('FSNIRTOA'//diag(icall), rd%fsnirt, pcols, lchnk) + call outfld('FSNRTOAC'//diag(icall), rd%fsnrtc, pcols, lchnk) + call outfld('FSNRTOAS'//diag(icall), rd%fsnirtsq, pcols, lchnk) - call outfld('FSN200'//diag(icall), rd%fsn200, pcols, lchnk) - call outfld('FSN200C'//diag(icall), rd%fsn200c, pcols, lchnk) + call outfld('FSN200'//diag(icall), rd%fsn200, pcols, lchnk) + call outfld('FSN200C'//diag(icall), rd%fsn200c, pcols, lchnk) - call outfld('FSNR'//diag(icall), rd%fsnr, pcols, lchnk) + call outfld('FSNR'//diag(icall), rd%fsnr, pcols, lchnk) - call outfld('SOLS'//diag(icall), cam_out%sols, pcols, lchnk) - call outfld('SOLL'//diag(icall), cam_out%soll, pcols, lchnk) - call outfld('SOLSD'//diag(icall), cam_out%solsd, pcols, lchnk) - call outfld('SOLLD'//diag(icall), cam_out%solld, pcols, lchnk) + call outfld('SOLS'//diag(icall), cam_out%sols, pcols, lchnk) + call outfld('SOLL'//diag(icall), cam_out%soll, pcols, lchnk) + call outfld('SOLSD'//diag(icall), cam_out%solsd, pcols, lchnk) + call outfld('SOLLD'//diag(icall), cam_out%solld, pcols, lchnk) - call outfld('FSNS'//diag(icall), fsns, pcols, lchnk) - call outfld('FSNSC'//diag(icall), rd%fsnsc, pcols, lchnk) + call outfld('FSNS'//diag(icall), fsns, pcols, lchnk) + call outfld('FSNSC'//diag(icall), rd%fsnsc, pcols, lchnk) - call outfld('FSDS'//diag(icall), fsds, pcols, lchnk) - call outfld('FSDSC'//diag(icall), rd%fsdsc, pcols, lchnk) + call outfld('FSDS'//diag(icall), fsds, pcols, lchnk) + call outfld('FSDSC'//diag(icall), rd%fsdsc, pcols, lchnk) -end subroutine radiation_output_sw + end subroutine radiation_output_sw -!=============================================================================== + !=============================================================================== -subroutine radiation_output_cld(lchnk, ncol, rd) + subroutine radiation_output_cld(lchnk, ncol, rd) - ! Dump shortwave cloud optics information to history buffer. + ! Dump shortwave cloud optics information to history buffer. - integer , intent(in) :: lchnk - integer, intent(in) :: ncol - type(rad_out_t), intent(in) :: rd - !---------------------------------------------------------------------------- + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + type(rad_out_t), intent(in) :: rd + !---------------------------------------------------------------------------- - call outfld('TOT_CLD_VISTAU', rd%tot_cld_vistau, pcols, lchnk) - call outfld('TOT_ICLD_VISTAU', rd%tot_icld_vistau, pcols, lchnk) - call outfld('LIQ_ICLD_VISTAU', rd%liq_icld_vistau, pcols, lchnk) - call outfld('ICE_ICLD_VISTAU', rd%ice_icld_vistau, pcols, lchnk) - if (cldfsnow_idx > 0) then - call outfld('SNOW_ICLD_VISTAU', rd%snow_icld_vistau, pcols, lchnk) - endif + call outfld('TOT_CLD_VISTAU', rd%tot_cld_vistau, pcols, lchnk) + call outfld('TOT_ICLD_VISTAU', rd%tot_icld_vistau, pcols, lchnk) + call outfld('LIQ_ICLD_VISTAU', rd%liq_icld_vistau, pcols, lchnk) + call outfld('ICE_ICLD_VISTAU', rd%ice_icld_vistau, pcols, lchnk) + if (cldfsnow_idx > 0) then + call outfld('SNOW_ICLD_VISTAU', rd%snow_icld_vistau, pcols, lchnk) + endif -end subroutine radiation_output_cld + end subroutine radiation_output_cld -!=============================================================================== + !=============================================================================== -subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) + subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) - ! Dump longwave radiation information to history buffer + ! Dump longwave radiation information to history buffer - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: icall ! icall=0 for climate diagnostics - type(rad_out_t), intent(in) :: rd - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(in) :: cam_out - real(r8), intent(in) :: freqclr(pcols) - real(r8), intent(in) :: flntclr(pcols) + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall ! icall=0 for climate diagnostics + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out + real(r8), intent(in) :: freqclr(pcols) + real(r8), intent(in) :: flntclr(pcols) - ! local variables - real(r8), pointer :: qrl(:,:) - real(r8), pointer :: flnt(:) - real(r8), pointer :: flns(:) + ! local variables + real(r8), pointer :: qrl(:,:) + real(r8), pointer :: flnt(:) + real(r8), pointer :: flns(:) - real(r8) :: ftem(pcols) - !---------------------------------------------------------------------------- + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- - call pbuf_get_field(pbuf, qrl_idx, qrl) - call pbuf_get_field(pbuf, flnt_idx, flnt) - call pbuf_get_field(pbuf, flns_idx, flns) + call pbuf_get_field(pbuf, qrl_idx, qrl) + call pbuf_get_field(pbuf, flnt_idx, flnt) + call pbuf_get_field(pbuf, flns_idx, flns) - call outfld('QRL'//diag(icall), qrl(:ncol,:)/cpair, ncol, lchnk) - call outfld('QRLC'//diag(icall), rd%qrlc(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRL'//diag(icall), qrl(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRLC'//diag(icall), rd%qrlc(:ncol,:)/cpair, ncol, lchnk) - call outfld('FLNT'//diag(icall), flnt, pcols, lchnk) - call outfld('FLNTC'//diag(icall), rd%flntc, pcols, lchnk) + call outfld('FLNT'//diag(icall), flnt, pcols, lchnk) + call outfld('FLNTC'//diag(icall), rd%flntc, pcols, lchnk) - call outfld('FREQCLR'//diag(icall), freqclr, pcols, lchnk) - call outfld('FLNTCLR'//diag(icall), flntclr, pcols, lchnk) + call outfld('FREQCLR'//diag(icall), freqclr, pcols, lchnk) + call outfld('FLNTCLR'//diag(icall), flntclr, pcols, lchnk) - call outfld('FLUT'//diag(icall), rd%flut, pcols, lchnk) - call outfld('FLUTC'//diag(icall), rd%flutc, pcols, lchnk) - - ftem(:ncol) = rd%flutc(:ncol) - rd%flut(:ncol) - call outfld('LWCF'//diag(icall), ftem, pcols, lchnk) + call outfld('FLUT'//diag(icall), rd%flut, pcols, lchnk) + call outfld('FLUTC'//diag(icall), rd%flutc, pcols, lchnk) - call outfld('FLN200'//diag(icall), rd%fln200, pcols, lchnk) - call outfld('FLN200C'//diag(icall), rd%fln200c, pcols, lchnk) + ftem(:ncol) = rd%flutc(:ncol) - rd%flut(:ncol) + call outfld('LWCF'//diag(icall), ftem, pcols, lchnk) - call outfld('FLNR'//diag(icall), rd%flnr, pcols, lchnk) + call outfld('FLN200'//diag(icall), rd%fln200, pcols, lchnk) + call outfld('FLN200C'//diag(icall), rd%fln200c, pcols, lchnk) - call outfld('FLNS'//diag(icall), flns, pcols, lchnk) - call outfld('FLNSC'//diag(icall), rd%flnsc, pcols, lchnk) + call outfld('FLNR'//diag(icall), rd%flnr, pcols, lchnk) - call outfld('FLDS'//diag(icall), cam_out%flwds, pcols, lchnk) - call outfld('FLDSC'//diag(icall), rd%fldsc, pcols, lchnk) + call outfld('FLNS'//diag(icall), flns, pcols, lchnk) + call outfld('FLNSC'//diag(icall), rd%flnsc, pcols, lchnk) -end subroutine radiation_output_lw + call outfld('FLDS'//diag(icall), cam_out%flwds, pcols, lchnk) + call outfld('FLDSC'//diag(icall), rd%fldsc, pcols, lchnk) -!=============================================================================== + end subroutine radiation_output_lw -subroutine calc_col_mean(state, mmr_pointer, mean_value) + !=============================================================================== - ! Compute the column mean mass mixing ratio. + subroutine calc_col_mean(state, mmr_pointer, mean_value) - type(physics_state), intent(in) :: state - real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) - real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr + ! Compute the column mean mass mixing ratio. - integer :: i, k, ncol - real(r8) :: ptot(pcols) - !----------------------------------------------------------------------- + type(physics_state), intent(in) :: state + real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) + real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr - ncol = state%ncol - mean_value = 0.0_r8 - ptot = 0.0_r8 + integer :: i, k, ncol + real(r8) :: ptot(pcols) + !----------------------------------------------------------------------- - do k=1,pver - do i=1,ncol - mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) - ptot(i) = ptot(i) + state%pdeldry(i,k) - end do - end do - do i=1,ncol - mean_value(i) = mean_value(i) / ptot(i) - end do + ncol = state%ncol + mean_value = 0.0_r8 + ptot = 0.0_r8 -end subroutine calc_col_mean + do k=1,pver + do i=1,ncol + mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) + ptot(i) = ptot(i) + state%pdeldry(i,k) + end do + end do + do i=1,ncol + mean_value(i) = mean_value(i) / ptot(i) + end do -!=============================================================================== + end subroutine calc_col_mean + + !=============================================================================== end module radiation diff --git a/src/physics/rrtmg/radlw.F90 b/src/physics/rrtmg/radlw.F90 index b2b56a751c..5d29c2198c 100644 --- a/src/physics/rrtmg/radlw.F90 +++ b/src/physics/rrtmg/radlw.F90 @@ -5,6 +5,7 @@ module radlw ! Purpose: Longwave radiation calculations. ! !----------------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols, pver, pverp use scamMod, only: single_column, scm_crm_mode @@ -185,6 +186,7 @@ subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & tsfc(:ncol) = r_state%tlev(:ncol,rrtmg_levs+1) taua_lw(:ncol, 1:rrtmg_levs-1, :nbndlw) = aer_lw_abs(:ncol,pverp-rrtmg_levs+1:pverp-1,:nbndlw) + if (associated(lu)) lu(1:ncol,:,:) = 0.0_r8 if (associated(ld)) ld(1:ncol,:,:) = 0.0_r8 @@ -227,12 +229,16 @@ subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & fsul(:ncol,pverp-rrtmg_levs+1:pverp)=uflxc(:ncol,rrtmg_levs:1:-1) fsdl(:ncol,pverp-rrtmg_levs+1:pverp)=dflxc(:ncol,rrtmg_levs:1:-1) +#ifndef OSLO_AERO if (single_column.and.scm_crm_mode) then +#endif call outfld('FUL ',ful,pcols,lchnk) call outfld('FDL ',fdl,pcols,lchnk) call outfld('FULC ',fsul,pcols,lchnk) call outfld('FDLC ',fsdl,pcols,lchnk) +#ifndef OSLO_AERO endif +#endif fnl(:ncol,:) = ful(:ncol,:) - fdl(:ncol,:) ! mji/ cam excluded this? diff --git a/src/physics/rrtmg/radsw.F90 b/src/physics/rrtmg/radsw.F90 index df222557dd..165fa7a931 100644 --- a/src/physics/rrtmg/radsw.F90 +++ b/src/physics/rrtmg/radsw.F90 @@ -5,6 +5,7 @@ module radsw ! Purpose: Solar radiation calculations. ! !----------------------------------------------------------------------- + use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols, pver, pverp use cam_abortutils, only: endrun @@ -22,7 +23,6 @@ module radsw implicit none private -save real(r8) :: fractional_solar_irradiance(1:nbndsw) ! fraction of solar irradiance in each band real(r8) :: solar_band_irrad(1:nbndsw) ! rrtmg-assumed solar irradiance in each sw band @@ -49,7 +49,11 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & qrs ,qrsc ,fsnt ,fsntc ,fsntoa,fsutoa, & fsntoac ,fsnirtoa ,fsnrtoac ,fsnrtoaq ,fsns , & fsnsc ,fsdsc ,fsds ,sols ,soll , & +#ifdef OSLO_AERO + solsd ,solld ,fns ,fcns ,idrf , & +#else solsd ,solld ,fns ,fcns , & +#endif Nday ,Nnite ,IdxDay ,IdxNite , & su ,sd , & E_cld_tau, E_cld_tau_w, E_cld_tau_w_g, E_cld_tau_w_f, & @@ -160,6 +164,10 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & real(r8), intent(out) :: fns(pcols,pverp) ! net flux at interfaces real(r8), intent(out) :: fcns(pcols,pverp) ! net clear-sky flux at interfaces +#ifdef OSLO_AERO + logical, intent(in) :: idrf +#endif + real(r8), pointer, dimension(:,:,:) :: su ! shortwave spectral flux up real(r8), pointer, dimension(:,:,:) :: sd ! shortwave spectral flux down @@ -304,12 +312,17 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & qrsc(1:ncol,1:pver) = 0.0_r8 fns(1:ncol,1:pverp) = 0.0_r8 fcns(1:ncol,1:pverp) = 0.0_r8 + +#ifndef OSLO_AERO if (single_column.and.scm_crm_mode) then +#endif fus(1:ncol,1:pverp) = 0.0_r8 fds(1:ncol,1:pverp) = 0.0_r8 fusc(:ncol,:pverp) = 0.0_r8 fdsc(:ncol,:pverp) = 0.0_r8 +#ifndef OSLO_AERO endif +#endif if (associated(su)) su(1:ncol,:,:) = 0.0_r8 if (associated(sd)) sd(1:ncol,:,:) = 0.0_r8 @@ -622,17 +635,28 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & end if ! these outfld calls don't work for spmd only outfield in scm mode (nonspmd) + ! Following outputs added for CRM +#ifndef OSLO_AERO if (single_column .and. scm_crm_mode) then - ! Following outputs added for CRM +#endif call ExpDayNite(fus,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fds,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call ExpDayNite(fds,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call outfld('FUS ', fus, pcols, lchnk) - call outfld('FDS ', fds, pcols, lchnk) call outfld('FUSC ', fusc, pcols, lchnk) + call outfld('FDS ', fds, pcols, lchnk) call outfld('FDSC ', fdsc, pcols, lchnk) +#ifndef OSLO_AERO + end if +#endif + +#ifdef OSLO_AERO + if (idrf) then + call outfld('FUSCDRF ', fusc, pcols, lchnk) + call outfld('FDSCDRF ', fdsc, pcols, lchnk) endif +#endif end subroutine rad_rrtmg_sw From 3493b80aaba9df0825347dd9111b15aa286ba70c Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 3 Sep 2023 17:56:55 +0200 Subject: [PATCH 45/71] refactored microp_aero --- src/physics/cam_oslo/microp_aero.F90 | 200 +++++++++------------------ 1 file changed, 62 insertions(+), 138 deletions(-) diff --git a/src/physics/cam_oslo/microp_aero.F90 b/src/physics/cam_oslo/microp_aero.F90 index 52e421f599..4076b4b29f 100644 --- a/src/physics/cam_oslo/microp_aero.F90 +++ b/src/physics/cam_oslo/microp_aero.F90 @@ -84,19 +84,12 @@ module microp_aero integer :: cldo_idx = -1 integer :: dgnumwet_idx = -1 - ! Bulk aerosols - character(len=20), allocatable :: aername(:) - real(r8), allocatable :: num_to_mass_aer(:) - integer :: naer_all ! number of aerosols affecting climate integer :: idxsul = -1 ! index in aerosol list for sulfate integer :: idxdst2 = -1 ! index in aerosol list for dust2 integer :: idxdst3 = -1 ! index in aerosol list for dust3 integer :: idxdst4 = -1 ! index in aerosol list for dust4 - ! modal aerosols - logical :: clim_modal_aero - integer :: mode_accum_idx = -1 ! index of accumulation mode integer :: mode_aitken_idx = -1 ! index of aitken mode integer :: mode_coarse_idx = -1 ! index of coarse mode @@ -172,22 +165,15 @@ subroutine microp_aero_init select case(trim(eddy_scheme)) case ('diag_TKE') - tke_idx = pbuf_get_index('tke') + tke_idx = pbuf_get_index('tke') case ('CLUBB_SGS') wp2_idx = pbuf_get_index('WP2_nadv') case default - kvh_idx = pbuf_get_index('kvh') + kvh_idx = pbuf_get_index('kvh') end select - ! clim_modal_aero determines whether modal aerosols are used in the climate calculation. - ! The modal aerosols can be either prognostic or prescribed. - call rad_cnst_get_info(0, nmodes=nmodes) - clim_modal_aero = (nmodes > 0) - ast_idx = pbuf_get_index('AST') - cldo_idx = pbuf_get_index('CLDO') - clim_modal_aero = .true. !Needed to avoid ending up in BAM routines call ndrop_init_oslo() @@ -302,10 +288,6 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) real(r8) :: dmc, ssmc, so4mc ! variables for modal scheme. integer :: dst_idx, num_idx - ! bulk aerosol variables - real(r8), allocatable :: naer2(:,:,:) ! bulk aerosol number concentration (1/m3) - real(r8), allocatable :: maerosol(:,:,:) ! bulk aerosol mass conc (kg/m3) - real(r8) :: wsub(pcols,pver) ! diagnosed sub-grid vertical velocity st. dev. (m/s) real(r8) :: wsubi(pcols,pver) ! diagnosed sub-grid vertical velocity ice (m/s) real(r8) :: nucboas @@ -357,15 +339,12 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) call physics_ptend_init(ptend_all, state%psetcols, 'microp_aero') - if (clim_modal_aero) then - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - end if + itim_old = pbuf_old_tim_idx() + call pbuf_get_field(pbuf, ast_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) ! initialize output npccn(1:ncol,1:pver) = 0._r8 - nacon(1:ncol,1:pver,:) = 0._r8 ! set default or fixed dust bins for contact freezing @@ -463,83 +442,55 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) ! Droplet Activation - if (clim_modal_aero) then - - ! for modal aerosol - - ! partition cloud fraction into liquid water part - lcldn = 0._r8 - lcldo = 0._r8 - cldliqf = 0._r8 - do k = top_lev, pver - do i = 1, ncol - qcld = state1%q(i,k,cldliq_idx) + state1%q(i,k,cldice_idx) - if (qcld > qsmall) then - lcldn(i,k) = cldn(i,k)*state1%q(i,k,cldliq_idx)/qcld - lcldo(i,k) = cldo(i,k)*state1%q(i,k,cldliq_idx)/qcld - cldliqf(i,k) = state1%q(i,k,cldliq_idx)/qcld - end if - end do + ! partition cloud fraction into liquid water part + lcldn = 0._r8 + lcldo = 0._r8 + cldliqf = 0._r8 + do k = top_lev, pver + do i = 1, ncol + qcld = state1%q(i,k,cldliq_idx) + state1%q(i,k,cldice_idx) + if (qcld > qsmall) then + lcldn(i,k) = cldn(i,k)*state1%q(i,k,cldliq_idx)/qcld + lcldo(i,k) = cldo(i,k)*state1%q(i,k,cldliq_idx)/qcld + cldliqf(i,k) = state1%q(i,k,cldliq_idx)/qcld + end if end do + end do - call outfld('LCLOUD', lcldn, pcols, lchnk) - - ! If not using preexsiting ice, then only use cloudbourne aerosol for the - ! liquid clouds. This is the same behavior as CAM5. - if (use_preexisting_ice) then - call dropmixnuc_oslo( & - state1, ptend_loc, deltatin, pbuf, wsub, & ! Input - cldn, cldo, cldliqf, & - hasAerosol, & - CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, & - cam, f_acm, f_bcm, f_aqm, f_so4_condm, & - f_soam, & - numberConcentration, volumeConcentration, & - hygroscopicity, lnsigma, & - nctend_mixnuc, & ! Output - factnum ) - else - ! Note difference in arguments lcldn, lcldo - cldliqf = 1._r8 - call dropmixnuc_oslo( & - state1, ptend_loc, deltatin, pbuf, wsub, & ! Input - lcldn, lcldo, cldliqf, & - hasAerosol, & - CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, & - cam, f_acm, f_bcm, f_aqm, f_so4_condm, & - f_soam, & - numberConcentration, volumeConcentration, & - hygroscopicity, lnsigma, & - nctend_mixnuc, & ! Output - factnum ) - end if - npccn(:ncol,:) = nctend_mixnuc(:ncol,:) - + call outfld('LCLOUD', lcldn, pcols, lchnk) + + ! If not using preexsiting ice, then only use cloudbourne aerosol for the + ! liquid clouds. This is the same behavior as CAM5. + if (use_preexisting_ice) then + call dropmixnuc_oslo( & + state1, ptend_loc, deltatin, pbuf, wsub, & ! Input + cldn, cldo, cldliqf, & + hasAerosol, & + CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, & + cam, f_acm, f_bcm, f_aqm, f_so4_condm, & + f_soam, & + numberConcentration, volumeConcentration, & + hygroscopicity, lnsigma, & + nctend_mixnuc, & ! Output + factnum ) else - - ! for bulk aerosol - - ! no tendencies returned from ndrop_bam_run, so just init ptend here - call physics_ptend_init(ptend_loc, state1%psetcols, 'none') - - do k = top_lev, pver - do i = 1, ncol - if (state1%q(i,k,cldliq_idx) >= qsmall) then - ! get droplet activation rate - call ndrop_bam_run( & - wsub(i,k), state1%t(i,k), rho(i,k), naer2(i,k,:), naer_all, & - naer_all, maerosol(i,k,:), dum2) - dum = dum2 - else - dum = 0._r8 - end if - npccn(i,k) = (dum*lcldm(i,k) - state1%q(i,k,numliq_idx))/deltatin - end do - end do - + ! Note difference in arguments lcldn, lcldo + cldliqf = 1._r8 + call dropmixnuc_oslo( & + state1, ptend_loc, deltatin, pbuf, wsub, & ! Input + lcldn, lcldo, cldliqf, & + hasAerosol, & + CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & + f_soa, & + cam, f_acm, f_bcm, f_aqm, f_so4_condm, & + f_soam, & + numberConcentration, volumeConcentration, & + hygroscopicity, lnsigma, & + nctend_mixnuc, & ! Output + factnum ) end if + npccn(:ncol,:) = nctend_mixnuc(:ncol,:) call physics_ptend_sum(ptend_loc, ptend_all, ncol) call physics_update(state1, ptend_loc, deltatin) @@ -548,52 +499,25 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) ! estimate rndst and nanco for 4 dust bins here to pass to MG microphysics do k = top_lev, pver do i = 1, ncol - if (state1%t(i,k) < 269.15_r8) then - - if (clim_modal_aero) then - !fxm: I think model uses bins, not modes.. But to get it - !approximately correct, use mode radius in first version - nacon(i,k,2) = numberConcentration(i,k,MODE_IDX_DST_A2) - nacon(i,k,3) = numberConcentration(i,k,MODE_IDX_DST_A3) - rndst(i,k,2) = lifeCycleNumberMedianRadius(MODE_IDX_DST_A2) - rndst(i,k,3) = lifeCycleNumberMedianRadius(MODE_IDX_DST_A3) - nacon(i,k,1) = 0.0_r8 !Set to zero to make sure - nacon(i,k,4) = 0.0_r8 !Set to zero to make sure - else - - !For Bulk Aerosols: set equal to aerosol number for dust for bins 2-4 (bin 1=0) - - if (idxdst2 > 0) then - nacon(i,k,2) = naer2(i,k,idxdst2) - end if - if (idxdst3 > 0) then - nacon(i,k,3) = naer2(i,k,idxdst3) - end if - if (idxdst4 > 0) then - nacon(i,k,4) = naer2(i,k,idxdst4) - end if - end if - + !fxm: I think model uses bins, not modes.. But to get it + !approximately correct, use mode radius in first version + nacon(i,k,2) = numberConcentration(i,k,MODE_IDX_DST_A2) + nacon(i,k,3) = numberConcentration(i,k,MODE_IDX_DST_A3) + rndst(i,k,2) = lifeCycleNumberMedianRadius(MODE_IDX_DST_A2) + rndst(i,k,3) = lifeCycleNumberMedianRadius(MODE_IDX_DST_A3) + nacon(i,k,1) = 0.0_r8 !Set to zero to make sure + nacon(i,k,4) = 0.0_r8 !Set to zero to make sure end if end do end do - !bulk aerosol ccn concentration (modal does it in ndrop, from dropmixnuc) - if (.not. clim_modal_aero) then - ! ccn concentration as diagnostic - call ndrop_bam_ccn(lchnk, ncol, maerosol, naer2) - - deallocate(naer2) - deallocate(maerosol) - end if - ! heterogeneous freezing if (use_hetfrz_classnuc) then - call hetfrz_classnuc_oslo_calc(state1, deltatin, factnum, pbuf & - ,numberConcentration, volumeConcentration & - ,f_acm, f_bcm, f_aqm, f_so4_condm, f_soam & - ,hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) + call hetfrz_classnuc_oslo_calc(state1, deltatin, factnum, pbuf, & + numberConcentration, volumeConcentration, & + f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & + hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) end if end subroutine microp_aero_run From c2b783cfd9a8ce0bfc4c4d4f5503df3352c79f8a Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 3 Sep 2023 18:15:03 +0200 Subject: [PATCH 46/71] refactored microp_aero --- src/physics/cam_oslo/microp_aero.F90 | 259 ++++++++++----------------- 1 file changed, 98 insertions(+), 161 deletions(-) diff --git a/src/physics/cam_oslo/microp_aero.F90 b/src/physics/cam_oslo/microp_aero.F90 index 4076b4b29f..5d3e44da13 100644 --- a/src/physics/cam_oslo/microp_aero.F90 +++ b/src/physics/cam_oslo/microp_aero.F90 @@ -1,24 +1,13 @@ module microp_aero !--------------------------------------------------------------------------------- - ! Purpose: - ! CAM driver layer for aerosol activation processes. - ! - ! ***N.B.*** This module is currently hardcoded to recognize only the aerosols/modes that - ! affect the climate calculation. This is implemented by using list - ! index 0 in all the calls to rad_constituent interfaces. - ! + ! Oslo-aero driver layer for aerosol activation processes. ! Author: Andrew Gettelman - ! Based on code from: Hugh Morrison, Xiaohong Liu and Steve Ghan - ! May 2010 + ! Based on code from: Hugh Morrison, Xiaohong Liu and Steve Ghan! May 2010 ! Description in: Morrison and Gettelman, 2008. J. Climate (MG2008) - ! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) - ! for questions contact Andrew Gettelman (andrew@ucar.edu) + ! Gettelman et al., 2010 J. Geophys. Res. - Atmospheres (G2010) ! Modifications: A. Gettelman Nov 2010 - changed to support separation of - ! microphysics and macrophysics and concentrate aerosol information here - ! B. Eaton, Sep 2014 - Refactored to move CAM interface code into the CAM - ! interface modules and preserve just the driver layer functionality here. - ! + ! microphysics and macrophysics and concentrate aerosol information here !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 @@ -36,7 +25,6 @@ module microp_aero use cam_history, only: addfld, add_default, outfld use cam_logfile, only: iulog ! - use oslo_aero_utils, only: CalculateNumberConcentration use oslo_aero_ndrop, only: ndrop_init_oslo, dropmixnuc_oslo use oslo_aero_conc, only: oslo_aero_conc_calc use oslo_aero_hetfrz, only: hetfrz_classnuc_oslo_register, hetfrz_classnuc_oslo_init, hetfrz_classnuc_oslo_readnl @@ -57,15 +45,13 @@ module microp_aero character(len=16) :: eddy_scheme - ! contact freezing due to dust - ! dust number mean radius (m), Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 + ! contact freezing due to dust, dust number mean radius (m), + ! Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 real(r8), parameter :: rn_dst1 = 0.258e-6_r8 real(r8), parameter :: rn_dst2 = 0.717e-6_r8 real(r8), parameter :: rn_dst3 = 1.576e-6_r8 real(r8), parameter :: rn_dst4 = 3.026e-6_r8 - real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor - ! smallest mixing ratio considered in microphysics real(r8), parameter :: qsmall = 1.e-18_r8 @@ -73,56 +59,79 @@ module microp_aero real(r8), parameter :: mincld = 0.0001_r8 ! indices in state%q and pbuf structures - integer :: cldliq_idx = -1 - integer :: cldice_idx = -1 - integer :: numliq_idx = -1 - integer :: numice_idx = -1 - integer :: kvh_idx = -1 - integer :: tke_idx = -1 - integer :: wp2_idx = -1 - integer :: ast_idx = -1 - integer :: cldo_idx = -1 + integer :: cldliq_idx = -1 + integer :: cldice_idx = -1 + integer :: numliq_idx = -1 + integer :: numice_idx = -1 + integer :: kvh_idx = -1 + integer :: tke_idx = -1 + integer :: wp2_idx = -1 + integer :: ast_idx = -1 + integer :: cldo_idx = -1 integer :: dgnumwet_idx = -1 - integer :: naer_all ! number of aerosols affecting climate - integer :: idxsul = -1 ! index in aerosol list for sulfate - integer :: idxdst2 = -1 ! index in aerosol list for dust2 - integer :: idxdst3 = -1 ! index in aerosol list for dust3 - integer :: idxdst4 = -1 ! index in aerosol list for dust4 - - integer :: mode_accum_idx = -1 ! index of accumulation mode - integer :: mode_aitken_idx = -1 ! index of aitken mode - integer :: mode_coarse_idx = -1 ! index of coarse mode - integer :: mode_coarse_dst_idx = -1 ! index of coarse dust mode - integer :: mode_coarse_slt_idx = -1 ! index of coarse sea salt mode - integer :: coarse_dust_idx = -1 ! index of dust in coarse mode - integer :: coarse_nacl_idx = -1 ! index of nacl in coarse mode - integer :: coarse_so4_idx = -1 ! index of sulfate in coarse mode + ! prescribed aerosol bulk sulfur scale factor + real(r8) :: bulk_scale integer :: npccn_idx, rndst_idx, nacon_idx - logical :: separate_dust = .false. - - !========================================================================================= +!========================================================================================= contains - !========================================================================================= +!========================================================================================= + + subroutine microp_aero_readnl(nlfile) + + use namelist_utils, only: find_group_name + use cam_abortutils, only: endrun + use mpishorthand + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + ! Namelist variables + real(r8) :: microp_aero_bulk_scale = 2._r8 ! prescribed aerosol bulk sulfur scale factor + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'microp_aero_readnl' + + namelist /microp_aero_nl/ microp_aero_bulk_scale + !----------------------------------------------------------------------------- + + if (masterproc) then + open(newunit=unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'microp_aero_nl', status=ierr) + if (ierr == 0) then + read(unitn, microp_aero_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + end if +#ifdef SPMD + call mpibcast(microp_aero_bulk_scale, 1, mpir8, 0, mpicom) +#endif + + ! set local variables + bulk_scale = microp_aero_bulk_scale + + call nucleate_ice_oslo_readnl(nlfile) + call hetfrz_classnuc_oslo_readnl(nlfile) + + end subroutine microp_aero_readnl + + !========================================================================================= subroutine microp_aero_register !----------------------------------------------------------------------- - ! - ! Purpose: ! Register pbuf fields for aerosols needed by microphysics - ! ! Author: Cheryl Craig October 2012 - ! !----------------------------------------------------------------------- - use ppgrid, only: pcols - use physics_buffer, only: pbuf_add_field, dtype_r8 - call pbuf_add_field('NPCCN', 'physpkg',dtype_r8,(/pcols,pver/), npccn_idx) + use physics_buffer, only: pbuf_add_field, dtype_r8 - call pbuf_add_field('RNDST', 'physpkg',dtype_r8,(/pcols,pver,4/), rndst_idx) - call pbuf_add_field('NACON', 'physpkg',dtype_r8,(/pcols,pver,4/), nacon_idx) + call pbuf_add_field('NPCCN', 'physpkg',dtype_r8,(/pcols,pver/) , npccn_idx) + call pbuf_add_field('RNDST', 'physpkg',dtype_r8,(/pcols,pver,4/), rndst_idx) + call pbuf_add_field('NACON', 'physpkg',dtype_r8,(/pcols,pver,4/), nacon_idx) call nucleate_ice_oslo_register() call hetfrz_classnuc_oslo_register() @@ -134,12 +143,8 @@ end subroutine microp_aero_register subroutine microp_aero_init !----------------------------------------------------------------------- - ! - ! Purpose: ! Initialize constants for aerosols needed by microphysics - ! ! Author: Andrew Gettelman May 2010 - ! !----------------------------------------------------------------------- ! local variables @@ -171,12 +176,9 @@ subroutine microp_aero_init case default kvh_idx = pbuf_get_index('kvh') end select - ast_idx = pbuf_get_index('AST') cldo_idx = pbuf_get_index('CLDO') - call ndrop_init_oslo() - call addfld('LCLOUD', (/ 'lev' /), 'A', ' ', 'Liquid cloud fraction used in stratus activation') call addfld('WSUB', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity' ) call addfld('WSUBI', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity for ice' ) @@ -184,55 +186,12 @@ subroutine microp_aero_init call add_default ('WSUB ', 1, ' ') end if + call ndrop_init_oslo() call nucleate_ice_oslo_init(mincld, bulk_scale) call hetfrz_classnuc_oslo_init(mincld) end subroutine microp_aero_init - !========================================================================================= - - subroutine microp_aero_readnl(nlfile) - - use namelist_utils, only: find_group_name - use cam_abortutils, only: endrun - use mpishorthand - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Namelist variables - real(r8) :: microp_aero_bulk_scale = 2._r8 ! prescribed aerosol bulk sulfur scale factor - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'microp_aero_readnl' - - namelist /microp_aero_nl/ microp_aero_bulk_scale - !----------------------------------------------------------------------------- - - if (masterproc) then - open(newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'microp_aero_nl', status=ierr) - if (ierr == 0) then - read(unitn, microp_aero_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - end if -#ifdef SPMD - ! Broadcast namelist variable - call mpibcast(microp_aero_bulk_scale, 1, mpir8, 0, mpicom) -#endif - - ! set local variables - bulk_scale = microp_aero_bulk_scale - - call nucleate_ice_oslo_readnl(nlfile) - call hetfrz_classnuc_oslo_readnl(nlfile) - - end subroutine microp_aero_readnl - !========================================================================================= subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) @@ -244,62 +203,43 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) ! local workspace ! all units mks unless otherwise stated - integer :: i, k, m integer :: itim_old integer :: nmodes - - type(physics_state) :: state1 ! Local copy of state variable + type(physics_state) :: state1 ! Local copy of state variable type(physics_ptend) :: ptend_loc - real(r8), pointer :: ast(:,:) - - real(r8), pointer :: npccn(:,:) ! number of CCN (liquid activated) - - real(r8), pointer :: rndst(:,:,:) ! radius of 4 dust bins for contact freezing - real(r8), pointer :: nacon(:,:,:) ! number in 4 dust bins for contact freezing - - real(r8), pointer :: num_coarse(:,:) ! number m.r. of coarse mode - real(r8), pointer :: coarse_dust(:,:) ! mass m.r. of coarse dust - real(r8), pointer :: coarse_nacl(:,:) ! mass m.r. of coarse nacl - real(r8), pointer :: coarse_so4(:,:) ! mass m.r. of coarse sulfate - - real(r8), pointer :: kvh(:,:) ! vertical eddy diff coef (m2 s-1) - real(r8), pointer :: tke(:,:) ! TKE from the UW PBL scheme (m2 s-2) - real(r8), pointer :: wp2(:,:) ! CLUBB vertical velocity variance - - real(r8), pointer :: cldn(:,:) ! cloud fraction - real(r8), pointer :: cldo(:,:) ! old cloud fraction - - real(r8), pointer :: dgnumwet(:,:,:) ! aerosol mode diameter - - real(r8), pointer :: aer_mmr(:,:) ! aerosol mass mixing ratio - - real(r8) :: rho(pcols,pver) ! air density (kg m-3) - - real(r8) :: lcldm(pcols,pver) ! liq cloud fraction - - real(r8) :: lcldn(pcols,pver) ! fractional coverage of new liquid cloud - real(r8) :: lcldo(pcols,pver) ! fractional coverage of old liquid cloud - real(r8) :: cldliqf(pcols,pver) ! fractional of total cloud that is liquid - real(r8) :: qcld ! total cloud water + real(r8), pointer :: npccn(:,:) ! number of CCN (liquid activated) + real(r8), pointer :: rndst(:,:,:) ! radius of 4 dust bins for contact freezing + real(r8), pointer :: nacon(:,:,:) ! number in 4 dust bins for contact freezing + real(r8), pointer :: num_coarse(:,:) ! number m.r. of coarse mode + real(r8), pointer :: coarse_dust(:,:) ! mass m.r. of coarse dust + real(r8), pointer :: coarse_nacl(:,:) ! mass m.r. of coarse nacl + real(r8), pointer :: coarse_so4(:,:) ! mass m.r. of coarse sulfate + real(r8), pointer :: kvh(:,:) ! vertical eddy diff coef (m2 s-1) + real(r8), pointer :: tke(:,:) ! TKE from the UW PBL scheme (m2 s-2) + real(r8), pointer :: wp2(:,:) ! CLUBB vertical velocity variance + real(r8), pointer :: cldn(:,:) ! cloud fraction + real(r8), pointer :: cldo(:,:) ! old cloud fraction + real(r8), pointer :: dgnumwet(:,:,:) ! aerosol mode diameter + real(r8), pointer :: aer_mmr(:,:) ! aerosol mass mixing ratio + real(r8) :: rho(pcols,pver) ! air density (kg m-3) + real(r8) :: lcldm(pcols,pver) ! liq cloud fraction + real(r8) :: lcldn(pcols,pver) ! fractional coverage of new liquid cloud + real(r8) :: lcldo(pcols,pver) ! fractional coverage of old liquid cloud + real(r8) :: cldliqf(pcols,pver) ! fractional of total cloud that is liquid + real(r8) :: qcld ! total cloud water real(r8) :: nctend_mixnuc(pcols,pver) - real(r8) :: dum, dum2 ! temporary dummy variable - real(r8) :: dmc, ssmc, so4mc ! variables for modal scheme. + real(r8) :: dum, dum2 ! temporary dummy variable + real(r8) :: dmc, ssmc, so4mc ! variables for modal scheme. integer :: dst_idx, num_idx - - real(r8) :: wsub(pcols,pver) ! diagnosed sub-grid vertical velocity st. dev. (m/s) - real(r8) :: wsubi(pcols,pver) ! diagnosed sub-grid vertical velocity ice (m/s) + real(r8) :: wsub(pcols,pver) ! diagnosed sub-grid vertical velocity st. dev. (m/s) + real(r8) :: wsubi(pcols,pver) ! diagnosed sub-grid vertical velocity ice (m/s) real(r8) :: nucboas real(r8) :: wght integer :: lchnk, ncol - real(r8) :: factnum(pcols,pver,0:nmodes_oslo) ! activation fraction for aerosol number - type qqcw_type - real(r8), pointer :: fldcw(:,:) - end type qqcw_type - type(qqcw_type) :: qqcw(pcnst) + real(r8) :: factnum(pcols,pver,0:nmodes_oslo) ! activation fraction for aerosol number real(r8) :: qaercwpt(pcols,pver,pcnst) - integer :: kk logical :: hasAerosol(pcols, pver, nmodes_oslo) real(r8) :: f_acm(pcols,pver, nmodes_oslo) real(r8) :: f_bcm(pcols,pver, nmodes_oslo) @@ -309,7 +249,7 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) real(r8) :: numberConcentration(pcols,pver,0:nmodes_oslo) ![#/m3] number concentraiton real(r8) :: volumeConcentration(pcols,pver,nmodes_oslo) ![m3/m3] volume concentration real(r8) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity - real(r8) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma + real(r8) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma real(r8) :: CProcessModes(pcols,pver) real(r8) :: cam(pcols,pver,nmodes_oslo) real(r8) :: f_c(pcols, pver) @@ -319,11 +259,6 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) real(r8) :: f_soa(pcols,pver) real(r8) :: volumeCore(pcols,pver,nmodes_oslo) real(r8) :: volumeCoat(pcols,pver,nmodes_oslo) - real(r8) :: sigmag_amode(3) - real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) - real(r8) :: fn_bc(pcols,pver), fn_dst1(pcols,pver), fn_dst3(pcols,pver) - real(r8) :: hetraer_bc(pcols,pver), hetraer_dst1(pcols,pver), hetraer_dst3(pcols,pver) - real(r8) :: dstcoat_bc(pcols,pver), dstcoat_dst1(pcols,pver), dstcoat_dst3(pcols,pver) !------------------------------------------------------------------------------- call physics_state_copy(state,state1) @@ -366,7 +301,6 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) end do factnum(1:ncol,1:pver,0:nmodes_oslo) = 0._r8 - cam(:,:,:) = 0._r8 ! More refined computation of sub-grid vertical velocity @@ -411,7 +345,6 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) if (.not. use_preexisting_ice) then wsubi(i,k) = min(wsubi(i,k), 0.2_r8) endif - wsub(i,k) = max(0.20_r8, wsub(i,k)) end do @@ -427,7 +360,9 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & numberConcentration, volumeConcentration, hygroscopicity, lnsigma, hasAerosol, volumeCore, volumeCoat) - !ICE Nucleation + ! ----------------- + ! ICE Nucleation + ! ----------------- call nucleate_ice_oslo_calc(state1, wsubi, pbuf, deltatin, ptend_loc, numberConcentration) call physics_ptend_sum(ptend_loc, ptend_all, ncol) @@ -440,7 +375,9 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) end do end do + ! ----------------- ! Droplet Activation + ! ----------------- ! partition cloud fraction into liquid water part lcldn = 0._r8 From 8be7741e83b6a658a3caf38d201b6effead7dc23 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 3 Sep 2023 18:46:45 +0200 Subject: [PATCH 47/71] moved microp_aero to chemistry/oslo_aero and renamed it --- src/NorESM/physpkg.F90 | 28 +++++++++++++++++-- .../oslo_aero/oslo_aero_microp.F90} | 24 ++++++++-------- src/control/runtime_opts.F90 | 8 ++++++ 3 files changed, 46 insertions(+), 14 deletions(-) rename src/{physics/cam_oslo/microp_aero.F90 => chemistry/oslo_aero/oslo_aero_microp.F90} (97%) diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index 0cce4c67e1..1500d8f263 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -120,7 +120,11 @@ subroutine phys_register use cloud_fraction, only: cldfrc_register use rk_stratiform, only: rk_stratiform_register use microp_driver, only: microp_driver_register +#ifdef OSLO_AERO + use oslo_aero_microp, only: oslo_aero_microp_register +#else use microp_aero, only: microp_aero_register +#endif use macrop_driver, only: macrop_driver_register use clubb_intr, only: clubb_register_cam use conv_water, only: conv_water_register @@ -221,14 +225,17 @@ subroutine phys_register call rk_stratiform_register() elseif( microp_scheme == 'MG' ) then if (.not. do_clubb_sgs) call macrop_driver_register() +#ifdef OSLO_AERO + call oslo_aero_microp_register() +#else call microp_aero_register() +#endif call microp_driver_register() end if ! Register CLUBB_SGS here if (do_clubb_sgs) call clubb_register_cam() - call pbuf_add_field('PREC_STR', 'physpkg',dtype_r8,(/pcols/),prec_str_idx) call pbuf_add_field('SNOW_STR', 'physpkg',dtype_r8,(/pcols/),snow_str_idx) call pbuf_add_field('PREC_PCW', 'physpkg',dtype_r8,(/pcols/),prec_pcw_idx) @@ -727,7 +734,11 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) use rk_stratiform, only: rk_stratiform_init use wv_saturation, only: wv_sat_init use microp_driver, only: microp_driver_init +#ifdef OSLO_AERO + use oslo_aero_microp, only: oslo_aero_microp_init +#else use microp_aero, only: microp_aero_init +#endif use macrop_driver, only: macrop_driver_init use conv_water, only: conv_water_init use spcam_drivers, only: spcam_init @@ -885,7 +896,11 @@ subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) call rk_stratiform_init() elseif( microp_scheme == 'MG' ) then if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) +#ifdef OSLO_AERO + call oslo_aero_microp_init() +#else call microp_aero_init() +#endif call microp_driver_init(pbuf2d) call conv_water_init elseif( microp_scheme == 'SPCAM_m2005') then @@ -1702,7 +1717,11 @@ subroutine tphysbc (ztodt, state, & use dadadj_cam, only: dadadj_tend use rk_stratiform, only: rk_stratiform_tend use microp_driver, only: microp_driver_tend +#ifdef OSLO_AERO + use oslo_aero_microp,only: oslo_aero_microp_run +#else use microp_aero, only: microp_aero_run +#endif use macrop_driver, only: macrop_driver_tend use physics_types, only: physics_state, physics_tend, physics_ptend, & physics_update, physics_ptend_init, physics_ptend_sum, & @@ -2231,10 +2250,15 @@ subroutine tphysbc (ztodt, state, & call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) end if +#ifdef OSLO_AERO + call t_startf('oslo_aero_microp_run') + call oslo_aero_microp_run(state, ptend_aero, cld_macmic_ztodt, pbuf) + call t_stopf('oslo_aero_microp_run') +#else call t_startf('microp_aero_run') call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) call t_stopf('microp_aero_run') - +#endif call t_startf('microp_tend') if (use_subcol_microp) then diff --git a/src/physics/cam_oslo/microp_aero.F90 b/src/chemistry/oslo_aero/oslo_aero_microp.F90 similarity index 97% rename from src/physics/cam_oslo/microp_aero.F90 rename to src/chemistry/oslo_aero/oslo_aero_microp.F90 index 5d3e44da13..5bfcc6ad18 100644 --- a/src/physics/cam_oslo/microp_aero.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_microp.F90 @@ -1,4 +1,4 @@ -module microp_aero +module oslo_aero_microp !--------------------------------------------------------------------------------- ! Oslo-aero driver layer for aerosol activation processes. @@ -39,7 +39,7 @@ module microp_aero implicit none private - public :: microp_aero_init, microp_aero_run, microp_aero_readnl, microp_aero_register + public :: oslo_aero_microp_init, oslo_aero_microp_run, oslo_aero_microp_readnl, oslo_aero_microp_register ! Private module data @@ -79,7 +79,7 @@ module microp_aero contains !========================================================================================= - subroutine microp_aero_readnl(nlfile) + subroutine oslo_aero_microp_readnl(nlfile) use namelist_utils, only: find_group_name use cam_abortutils, only: endrun @@ -118,10 +118,10 @@ subroutine microp_aero_readnl(nlfile) call nucleate_ice_oslo_readnl(nlfile) call hetfrz_classnuc_oslo_readnl(nlfile) - end subroutine microp_aero_readnl + end subroutine oslo_aero_microp_readnl !========================================================================================= - subroutine microp_aero_register + subroutine oslo_aero_microp_register !----------------------------------------------------------------------- ! Register pbuf fields for aerosols needed by microphysics ! Author: Cheryl Craig October 2012 @@ -136,11 +136,11 @@ subroutine microp_aero_register call nucleate_ice_oslo_register() call hetfrz_classnuc_oslo_register() - end subroutine microp_aero_register + end subroutine oslo_aero_microp_register !========================================================================================= - subroutine microp_aero_init + subroutine oslo_aero_microp_init !----------------------------------------------------------------------- ! Initialize constants for aerosols needed by microphysics @@ -152,7 +152,7 @@ subroutine microp_aero_init integer :: m, n, nmodes, nspec character(len=32) :: str32 - character(len=*), parameter :: routine = 'microp_aero_init' + character(len=*), parameter :: routine = 'oslo_aero_microp_init' logical :: history_amwg !----------------------------------------------------------------------- @@ -190,10 +190,10 @@ subroutine microp_aero_init call nucleate_ice_oslo_init(mincld, bulk_scale) call hetfrz_classnuc_oslo_init(mincld) - end subroutine microp_aero_init + end subroutine oslo_aero_microp_init !========================================================================================= - subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) + subroutine oslo_aero_microp_run (state, ptend_all, deltatin, pbuf) ! arguments type(physics_state), intent(in) :: state @@ -457,6 +457,6 @@ subroutine microp_aero_run (state, ptend_all, deltatin, pbuf) hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) end if - end subroutine microp_aero_run + end subroutine oslo_aero_microp_run -end module microp_aero +end module oslo_aero_microp diff --git a/src/control/runtime_opts.F90 b/src/control/runtime_opts.F90 index daffce8c4f..d82280a6e8 100644 --- a/src/control/runtime_opts.F90 +++ b/src/control/runtime_opts.F90 @@ -48,7 +48,11 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) use dadadj_cam, only: dadadj_readnl use macrop_driver, only: macrop_driver_readnl use microp_driver, only: microp_driver_readnl +#ifdef OSLO_AERO + use oslo_aero_microp, only: oslo_aero_microp_readnl +#else use microp_aero, only: microp_aero_readnl +#endif use subcol, only: subcol_readnl use cloud_fraction, only: cldfrc_readnl use cldfrc2m, only: cldfrc2m_readnl @@ -139,7 +143,11 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) call dadadj_readnl(nlfilename) call macrop_driver_readnl(nlfilename) call microp_driver_readnl(nlfilename) +#ifdef OSLO_AERO + call oslo_aero_microp_readnl(nlfilename) +#else call microp_aero_readnl(nlfilename) +#endif call clubb_readnl(nlfilename) call subcol_readnl(nlfilename) call cldfrc_readnl(nlfilename) From 260b26371cb69a5ba29affedbe62fb25af94c321 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 3 Sep 2023 20:00:42 +0200 Subject: [PATCH 48/71] more refactoring of cam_oslo routines --- src/chemistry/mozart/mo_gas_phase_chemdr.F90 | 72 +- src/physics/cam/zm_microphysics.F90 | 3 +- src/physics/cam_oslo/mo_extfrc.F90 | 416 --- src/physics/cam_oslo/mo_gas_phase_chemdr.F90 | 1241 --------- src/physics/cam_oslo/zm_microphysics.F90 | 2445 ------------------ 5 files changed, 72 insertions(+), 4105 deletions(-) delete mode 100644 src/physics/cam_oslo/mo_extfrc.F90 delete mode 100644 src/physics/cam_oslo/mo_gas_phase_chemdr.F90 delete mode 100644 src/physics/cam_oslo/zm_microphysics.F90 diff --git a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 index de6464ff5f..a638b28d35 100644 --- a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 +++ b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 @@ -6,7 +6,7 @@ module mo_gas_phase_chemdr use cam_history, only : fieldname_len use chem_mods, only : phtcnt, rxntot, gas_pcnst use chem_mods, only : rxt_tag_cnt, rxt_tag_lst, rxt_tag_map, extcnt, num_rnts -#ifdef OSLO_AERO +#ifdef OSLO_AERO use oslo_aero_dust, only : dust_names, ndust => dust_nbin #else use dust_model, only : dust_names, ndust => dust_nbin @@ -30,6 +30,10 @@ module mo_gas_phase_chemdr integer :: het1_ndx integer :: ndx_cldfr, ndx_cmfdqr, ndx_nevapr, ndx_cldtop, ndx_prain integer :: ndx_h2so4 +#ifdef OSLO_AERO + logical :: inv_o3, inv_oh, inv_no3, inv_ho2 + integer :: id_o3, id_oh, id_no3, id_ho2 +#endif ! ! CCMI ! @@ -57,7 +61,11 @@ module mo_gas_phase_chemdr subroutine gas_phase_chemdr_inti() +#ifdef OSLO_AERO + use mo_chem_utls, only : get_spc_ndx, get_extfrc_ndx, get_rxt_ndx, get_inv_ndx +#else use mo_chem_utls, only : get_spc_ndx, get_extfrc_ndx, get_rxt_ndx +#endif use cam_history, only : addfld,add_default,horiz_only use mo_chm_diags, only : chm_diags_inti use constituents, only : cnst_get_ind @@ -78,6 +86,25 @@ subroutine gas_phase_chemdr_inti() call phys_getopts( convproc_do_aer_out = convproc_do_aer, history_cesm_forcing_out=history_cesm_forcing ) +#if defined(OSLO_AERO) + inv_o3 = get_inv_ndx('O3') > 0 + inv_oh = get_inv_ndx('OH') > 0 + inv_no3 = get_inv_ndx('NO3') > 0 + inv_ho2 = get_inv_ndx('HO2') > 0 + if (inv_o3) then + id_o3 = get_inv_ndx('O3') + endif + if (inv_oh) then + id_oh = get_inv_ndx('OH') + endif + if (inv_no3) then + id_no3 = get_inv_ndx('NO3') + endif + if (inv_ho2) then + id_ho2 = get_inv_ndx('HO2') + endif +#endif + ndx_h2so4 = get_spc_ndx('H2SO4') ! ! CCMI @@ -204,6 +231,23 @@ subroutine gas_phase_chemdr_inti() call addfld( 'HCL_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase hcl' ) call addfld( 'HCL_STS', (/ 'lev' /), 'I', 'mol/mol', 'STS condensed HCL' ) +#ifdef OSLO_AERO + ! Adding extra fields for oxi-output (before and after diurnal variations.) + call addfld ('OH_bef ', (/ 'lev' /), 'A','unit', 'OH invariants before adding diurnal variations' ) + call addfld ('HO2_bef ', (/ 'lev' /), 'A','unit', 'HO2 invariants before adding diurnal variations' ) + call addfld ('NO3_bef ', (/ 'lev' /), 'A','unit', 'NO3 invariants before adding diurnal variations' ) + call addfld ('OH_aft ', (/ 'lev' /), 'A','unit', 'OH invariants after adding diurnal variations' ) + call addfld ('HO2_aft ', (/ 'lev' /), 'A','unit', 'HO2 invariants after adding diurnal variations' ) + call addfld ('NO3_aft ', (/ 'lev' /), 'A','unit', 'NO3 invariants after adding diurnal variations' ) + + call add_default ('OH_bef ', 1, ' ') + call add_default ('HO2_bef ', 1, ' ') + call add_default ('NO3_bef ', 1, ' ') + call add_default ('OH_aft ', 1, ' ') + call add_default ('HO2_aft ', 1, ' ') + call add_default ('NO3_aft ', 1, ' ') +#endif + if (het1_ndx>0) then call addfld( 'het1_total', (/ 'lev' /), 'I', '/s', 'total N2O5 + H2O het rate constant' ) endif @@ -299,6 +343,9 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & use mo_chm_diags, only : chm_diags, het_diags use perf_mod, only : t_startf, t_stopf use gas_wetdep_opts, only : gas_wetdep_method +#if (defined OSLO_AERO) + use oslo_aero_diurnal_var, only : set_diurnal_invariants +#endif use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx use infnan, only : nan, assignment(=) use rate_diags, only : rate_diags_calc @@ -626,6 +673,21 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & !----------------------------------------------------------------------- call setinv( invariants, tfld, h2ovmr, vmr, pmid, ncol, lchnk, pbuf ) +#if defined (OSLO_AERO) + !----------------------------------------------------------------------- + ! ... Set the "day/night cycle for prescribed oxidants" + !----------------------------------------------------------------------- + call outfld('OH_bef', invariants(:,:,id_oh), ncol, lchnk) + call outfld('HO2_bef', invariants(:,:,id_ho2), ncol, lchnk) + call outfld('NO3_bef', invariants(:,:,id_no3), ncol, lchnk) + + if (inv_oh.or.inv_ho2.or.inv_no3) & !++IH: added inv_no3 + call set_diurnal_invariants(invariants,delt,ncol,lchnk,inv_oh,inv_ho2,id_oh,id_ho2,inv_no3,id_no3) !++IH: added inv_no3 and id_no3 + + call outfld('OH_aft', invariants(:,:,id_oh), ncol, lchnk) + call outfld('HO2_aft', invariants(:,:,id_ho2), ncol, lchnk) + call outfld('NO3_aft', invariants(:,:,id_no3), ncol, lchnk) +#endif !----------------------------------------------------------------------- ! ... stratosphere aerosol surface area !----------------------------------------------------------------------- @@ -1122,11 +1184,17 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & endif end do +#ifdef OSLO_AERO + call chm_diags( lchnk, ncol, vmr(:ncol,:,:), mmr_new(:ncol,:,:), & + reaction_rates(:ncol,:,:), invariants(:ncol,:,:), depvel(:ncol,:), sflx(:ncol,:), & + mmr_tend(:ncol,:,:), pdel(:ncol,:), pmid(:ncol,:), troplev(:ncol), wetdepflx_diag(:ncol,:), & + nhx_nitrogen_flx(:ncol), noy_nitrogen_flx(:ncol), pbuf ) +#else call chm_diags( lchnk, ncol, vmr(:ncol,:,:), mmr_new(:ncol,:,:), & reaction_rates(:ncol,:,:), invariants(:ncol,:,:), depvel(:ncol,:), sflx(:ncol,:), & mmr_tend(:ncol,:,:), pdel(:ncol,:), pmid(:ncol,:), troplev(:ncol), wetdepflx_diag(:ncol,:), & nhx_nitrogen_flx(:ncol), noy_nitrogen_flx(:ncol) ) - +#endif call rate_diags_calc( reaction_rates(:,:,:), vmr(:,:,:), invariants(:,:,indexm), ncol, lchnk ) ! ! jfl diff --git a/src/physics/cam/zm_microphysics.F90 b/src/physics/cam/zm_microphysics.F90 index 29607725bc..8c6eb9c864 100644 --- a/src/physics/cam/zm_microphysics.F90 +++ b/src/physics/cam/zm_microphysics.F90 @@ -1465,12 +1465,13 @@ subroutine zm_mphy(su, qu, mu, du, eu, cmel, cmei, zf, pm, te, end if +#ifndef OSLO_AERO call activate_modal( & wu(i,k), wmix, wdiab, wmin, wmax, & t(i,k), rho(i,k), naermod, aero%nmodes, vaerosol, & hygro, fn, fm, & fluxn, fluxm, flux_fullact, in_cloud_in=in_cloud, smax_f=smax_f) - +#endif do m = 1, aero%nmodes nlsrc = nlsrc + fn(m)*naermod(m) ! number nucleated end do diff --git a/src/physics/cam_oslo/mo_extfrc.F90 b/src/physics/cam_oslo/mo_extfrc.F90 deleted file mode 100644 index 85efe5e92e..0000000000 --- a/src/physics/cam_oslo/mo_extfrc.F90 +++ /dev/null @@ -1,416 +0,0 @@ -module mo_extfrc - !--------------------------------------------------------------- - ! ... insitu forcing module - !--------------------------------------------------------------- - - use shr_kind_mod, only : r8 => shr_kind_r8 - use ppgrid, only : pver, pverp - use chem_mods, only : gas_pcnst, extcnt, extfrc_lst, frc_from_dataset, adv_mass - use spmd_utils, only : masterproc - use cam_abortutils,only : endrun - use cam_history, only : addfld, outfld, add_default, horiz_only - use cam_history_support,only : max_fieldname_len - use cam_logfile, only : iulog - use tracer_data, only : trfld,trfile - use mo_constants, only : avogadro - - implicit none - - type :: forcing - integer :: frc_ndx - real(r8) :: scalefactor - character(len=265):: filename - character(len=16) :: species - integer :: nsectors - character(len=32),pointer :: sectors(:) - type(trfld), pointer :: fields(:) - type(trfile) :: file - end type forcing - - private - public :: extfrc_inti - public :: extfrc_set - public :: extfrc_timestep_init - - save - - integer, parameter :: time_span = 1 - - character(len=256) :: filename - - type(forcing), allocatable :: forcings(:) - integer :: n_frc_files = 0 - -contains - - subroutine extfrc_inti( extfrc_specifier, extfrc_type_in, extfrc_cycle_yr, extfrc_fixed_ymd, extfrc_fixed_tod) - - !----------------------------------------------------------------------- - ! ... initialize the surface forcings - !----------------------------------------------------------------------- - use cam_pio_utils, only : cam_pio_openfile, cam_pio_closefile - use pio, only : pio_inquire, pio_inq_varndims - use pio, only : pio_inq_varname, pio_nowrite, file_desc_t - use pio, only : pio_get_att, PIO_NOERR, PIO_GLOBAL - use pio, only : pio_seterrorhandling, PIO_BCAST_ERROR,PIO_INTERNAL_ERROR - use mo_chem_utls, only : get_extfrc_ndx - use chem_mods, only : frc_from_dataset - use tracer_data, only : trcdata_init - use phys_control, only : phys_getopts - use string_utils, only : GLC - use m_MergeSorts, only : IndexSort - - implicit none - - !----------------------------------------------------------------------- - ! ... dummy arguments - !----------------------------------------------------------------------- - character(len=*), dimension(:), intent(in) :: extfrc_specifier - character(len=*), intent(in) :: extfrc_type_in - integer , intent(in) :: extfrc_cycle_yr - integer , intent(in) :: extfrc_fixed_ymd - integer , intent(in) :: extfrc_fixed_tod - - !----------------------------------------------------------------------- - ! ... local variables - !----------------------------------------------------------------------- - integer :: astat - integer :: j, l, m, n, i,mm ! Indices - character(len=16) :: spc_name - character(len=256) :: frc_fnames(gas_pcnst) - real(r8) :: frc_scalefactor(gas_pcnst) - character(len=16) :: frc_species(gas_pcnst) - integer :: frc_indexes(gas_pcnst) - integer :: indx(gas_pcnst) - - integer :: vid, ndims, nvars, isec, ierr - type(file_desc_t) :: ncid - character(len=32) :: varname - - character(len=1), parameter :: filelist = '' - character(len=1), parameter :: datapath = '' - logical , parameter :: rmv_file = .false. - logical :: history_aerosol - logical :: history_chemistry - logical :: history_cesm_forcing - - character(len=32) :: extfrc_type = ' ' - character(len=80) :: file_interp_type = ' ' - character(len=256) :: tmp_string = ' ' - character(len=32) :: xchr = ' ' - real(r8) :: xdbl - - !----------------------------------------------------------------------- - - call phys_getopts( & - history_aerosol_out = history_aerosol, & - history_chemistry_out = history_chemistry, & - history_cesm_forcing_out = history_cesm_forcing ) - - !----------------------------------------------------------------------- - ! ... species has insitu forcing ? - !----------------------------------------------------------------------- - - !write(iulog,*) 'Species with insitu forcings' - mm = 0 - indx(:) = 0 - - count_emis: do n=1,gas_pcnst - - if ( len_trim(extfrc_specifier(n) ) == 0 ) then - exit count_emis - endif - - i = scan(extfrc_specifier(n),'->') - spc_name = trim(adjustl(extfrc_specifier(n)(:i-1))) - - ! need to parse out scalefactor ... - tmp_string = adjustl(extfrc_specifier(n)(i+2:)) - j = scan( tmp_string, '*' ) - if (j>0) then - xchr = tmp_string(1:j-1) ! get the multipler (left of the '*') - read( xchr, * ) xdbl ! convert the string to a real - tmp_string = adjustl(tmp_string(j+1:)) ! get the filepath name (right of the '*') - else - xdbl = 1._r8 - endif - filename = trim(tmp_string) - - m = get_extfrc_ndx( spc_name ) - - if ( m < 1 ) then - call endrun('extfrc_inti: '//trim(spc_name)// ' does not have an external source') - endif - - if ( .not. frc_from_dataset(m) ) then - call endrun('extfrc_inti: '//trim(spc_name)//' cannot have external forcing from additional dataset') - endif - - mm = mm+1 - frc_species(mm) = spc_name - frc_fnames(mm) = filename - frc_indexes(mm) = m - frc_scalefactor(mm) = xdbl - - indx(n)=n - - enddo count_emis - - n_frc_files = mm - - if( n_frc_files < 1 ) then - if (masterproc) write(iulog,*) 'There are no species with insitu forcings' - return - end if - - if (masterproc) write(iulog,*) ' ' - - !----------------------------------------------------------------------- - ! ... allocate forcings type array - !----------------------------------------------------------------------- - allocate( forcings(n_frc_files), stat=astat ) - if( astat/= 0 ) then - write(iulog,*) 'extfrc_inti: failed to allocate forcings array; error = ',astat - call endrun('extfrc_inti: failed to allocate forcings array') - end if - - !----------------------------------------------------------------------- - ! Sort the input files so that the emissions sources are summed in the - ! same order regardless of the order of the input files in the namelist - !----------------------------------------------------------------------- - if (n_frc_files > 0) then - call IndexSort(n_frc_files, indx, frc_fnames) - end if - - !----------------------------------------------------------------------- - ! ... setup the forcing type array - !----------------------------------------------------------------------- - do m=1,n_frc_files - forcings(m)%frc_ndx = frc_indexes(indx(m)) - forcings(m)%species = frc_species(indx(m)) - forcings(m)%filename = frc_fnames(indx(m)) - forcings(m)%scalefactor = frc_scalefactor(indx(m)) - enddo - - do n= 1,extcnt - if (frc_from_dataset(n)) then - spc_name = extfrc_lst(n) - call addfld( trim(spc_name)//'_XFRC', (/ 'lev' /), 'A', 'molec/cm3/s', & - 'external forcing for '//trim(spc_name) ) - call addfld( trim(spc_name)//'_CLXF', horiz_only, 'A', 'molec/cm2/s', & - 'vertically integrated external forcing for '//trim(spc_name) ) - call addfld( trim(spc_name)//'_CMXF', horiz_only, 'A', 'kg/m2/s', & - 'vertically integrated external forcing for '//trim(spc_name) ) - if ( history_aerosol .or. history_chemistry ) then - call add_default( trim(spc_name)//'_CLXF', 1, ' ' ) - call add_default( trim(spc_name)//'_CMXF', 1, ' ' ) - endif - if ( history_cesm_forcing .and. spc_name == 'NO2' ) then - call add_default( trim(spc_name)//'_CLXF', 1, ' ' ) - call add_default( trim(spc_name)//'_CMXF', 1, ' ' ) - endif - endif - enddo - - if (masterproc) then - !----------------------------------------------------------------------- - ! ... diagnostics - !----------------------------------------------------------------------- - write(iulog,*) ' ' - write(iulog,*) 'extfrc_inti: diagnostics' - write(iulog,*) ' ' - write(iulog,*) 'extfrc timing specs' - write(iulog,*) 'type = ',extfrc_type - if( extfrc_type == 'FIXED' ) then - write(iulog,*) ' fixed date = ', extfrc_fixed_ymd - write(iulog,*) ' fixed time = ', extfrc_fixed_tod - else if( extfrc_type == 'CYCLICAL' ) then - write(iulog,*) ' cycle year = ',extfrc_cycle_yr - end if - write(iulog,*) ' ' - write(iulog,*) 'there are ',n_frc_files,' species with external forcing files' - do m = 1,n_frc_files - write(iulog,*) ' ' - write(iulog,*) 'forcing type ',m - write(iulog,*) 'species = ',trim(forcings(m)%species) - write(iulog,*) 'frc ndx = ',forcings(m)%frc_ndx - write(iulog,*) 'filename= ',trim(forcings(m)%filename) - end do - write(iulog,*) ' ' - endif - - !----------------------------------------------------------------------- - ! read emis files to determine number of sectors - !----------------------------------------------------------------------- - frcing_loop: do m = 1, n_frc_files - - forcings(m)%nsectors = 0 - - call cam_pio_openfile ( ncid, trim(forcings(m)%filename), PIO_NOWRITE) - ierr = pio_inquire (ncid, nVariables=nvars) - - do vid = 1,nvars - - ierr = pio_inq_varndims (ncid, vid, ndims) - - if( ndims < 4 ) then - cycle - elseif( ndims > 4 ) then - ierr = pio_inq_varname (ncid, vid, varname) - write(iulog,*) 'extfrc_inti: Skipping variable ', trim(varname),', ndims = ',ndims, & - ' , species=',trim(forcings(m)%species) - cycle - end if - - forcings(m)%nsectors = forcings(m)%nsectors+1 - - enddo - - allocate( forcings(m)%sectors(forcings(m)%nsectors), stat=astat ) - if( astat/= 0 ) then - write(iulog,*) 'extfrc_inti: failed to allocate forcings(m)%sectors array; error = ',astat - call endrun - end if - - isec = 1 - do vid = 1,nvars - - ierr = pio_inq_varndims (ncid, vid, ndims) - if( ndims == 4 ) then - ierr = pio_inq_varname(ncid, vid, forcings(m)%sectors(isec)) - isec = isec+1 - endif - - enddo - - ! Global attribute 'input_method' overrides the ext_frc_type namelist setting on - ! a file-by-file basis. If the ext_frc file does not contain the 'input_method' - ! attribute then the ext_frc_type namelist setting is used. - call pio_seterrorhandling(ncid, PIO_BCAST_ERROR) - ierr = pio_get_att(ncid, PIO_GLOBAL, 'input_method', file_interp_type) - call pio_seterrorhandling(ncid, PIO_INTERNAL_ERROR) - if ( ierr == PIO_NOERR) then - l = GLC(file_interp_type) - extfrc_type(1:l) = file_interp_type(1:l) - extfrc_type(l+1:) = ' ' - else - extfrc_type = trim(extfrc_type_in) - endif - - call cam_pio_closefile (ncid) - - allocate(forcings(m)%file%in_pbuf(size(forcings(m)%sectors))) - forcings(m)%file%in_pbuf(:) = .false. - call trcdata_init( forcings(m)%sectors, & - forcings(m)%filename, filelist, datapath, & - forcings(m)%fields, & - forcings(m)%file, & - rmv_file, extfrc_cycle_yr, extfrc_fixed_ymd, extfrc_fixed_tod, trim(extfrc_type) ) - - enddo frcing_loop - - - end subroutine extfrc_inti - - subroutine extfrc_timestep_init( pbuf2d, state ) - !----------------------------------------------------------------------- - ! ... check serial case for time span - !----------------------------------------------------------------------- - - use physics_types,only : physics_state - use ppgrid, only : begchunk, endchunk - use tracer_data, only : advance_trcdata - use physics_buffer, only : physics_buffer_desc - - implicit none - - type(physics_state), intent(in):: state(begchunk:endchunk) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - !----------------------------------------------------------------------- - ! ... local variables - !----------------------------------------------------------------------- - integer :: m - - do m = 1,n_frc_files - call advance_trcdata( forcings(m)%fields, forcings(m)%file, state, pbuf2d ) - end do - - end subroutine extfrc_timestep_init - - subroutine extfrc_set( lchnk, zint, frcing, ncol ) - - !-------------------------------------------------------- - ! ... form the external forcing - !-------------------------------------------------------- - use mo_chem_utls, only : get_spc_ndx - - implicit none - - !-------------------------------------------------------- - ! ... dummy arguments - !-------------------------------------------------------- - integer, intent(in) :: ncol ! columns in chunk - integer, intent(in) :: lchnk ! chunk index - real(r8), intent(in) :: zint(ncol, pverp) ! interface geopot above surface (km) - real(r8), intent(inout) :: frcing(ncol,pver,extcnt) ! insitu forcings (molec/cm^3/s) - - !-------------------------------------------------------- - ! ... local variables - !-------------------------------------------------------- - integer :: m, n - character(len=max_fieldname_len) :: xfcname - real(r8) :: frcing_col(1:ncol), frcing_col_kg(1:ncol) - integer :: k, isec - real(r8),parameter :: km_to_cm = 1.e5_r8 - real(r8),parameter :: cm2_to_m2 = 1.e4_r8 - real(r8),parameter :: kg_to_g = 1.e-3_r8 - real(r8) :: molec_to_kg - integer :: spc_ndx - - if( n_frc_files < 1 .or. extcnt < 1 ) then - return - end if - - frcing(:,:,:) = 0._r8 - - !-------------------------------------------------------- - ! ... set non-zero forcings - !-------------------------------------------------------- - file_loop : do m = 1,n_frc_files - - n = forcings(m)%frc_ndx - - do isec = 1,forcings(m)%nsectors - frcing(:ncol,:,n) = frcing(:ncol,:,n) + forcings(m)%scalefactor*forcings(m)%fields(isec)%data(:ncol,:,lchnk) - enddo - - enddo file_loop - - frc_loop : do n = 1,extcnt - if (frc_from_dataset(n)) then - - xfcname = trim(extfrc_lst(n))//'_XFRC' - call outfld( xfcname, frcing(:ncol,:,n), ncol, lchnk ) - - spc_ndx = get_spc_ndx( extfrc_lst(n) ) - molec_to_kg = adv_mass( spc_ndx ) / avogadro *cm2_to_m2 * kg_to_g - - frcing_col(:ncol) = 0._r8 - frcing_col_kg(:ncol) = 0._r8 - do k = 1,pver - frcing_col(:ncol) = frcing_col(:ncol) + frcing(:ncol,k,n)*(zint(:ncol,k)-zint(:ncol,k+1))*km_to_cm - frcing_col_kg(:ncol) = frcing_col_kg(:ncol) + frcing(:ncol,k,n)*(zint(:ncol,k)-zint(:ncol,k+1))*km_to_cm*molec_to_kg - enddo - - xfcname = trim(extfrc_lst(n))//'_CLXF' - call outfld( xfcname, frcing_col(:ncol), ncol, lchnk ) - xfcname = trim(extfrc_lst(n))//'_CMXF' - call outfld( xfcname, frcing_col_kg(:ncol), ncol, lchnk ) - endif - end do frc_loop - - end subroutine extfrc_set - - -end module mo_extfrc diff --git a/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 b/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 deleted file mode 100644 index a8601643e7..0000000000 --- a/src/physics/cam_oslo/mo_gas_phase_chemdr.F90 +++ /dev/null @@ -1,1241 +0,0 @@ -module mo_gas_phase_chemdr - - use shr_kind_mod, only : r8 => shr_kind_r8 - use shr_const_mod, only : pi => shr_const_pi - use constituents, only : pcnst - use cam_history, only : fieldname_len - use chem_mods, only : phtcnt, rxntot, gas_pcnst - use chem_mods, only : rxt_tag_cnt, rxt_tag_lst, rxt_tag_map, extcnt, num_rnts -#ifdef OSLO_AERO - use oslo_aero_dust, only : dust_names, ndust => dust_nbin -#else - use dust_model, only : dust_names, ndust => dust_nbin -#endif - use ppgrid, only : pcols, pver - use phys_control, only : phys_getopts - use carma_flags_mod, only : carma_hetchem_feedback - use chem_prod_loss_diags, only: chem_prod_loss_diags_init, chem_prod_loss_diags_out - - implicit none - save - - private - public :: gas_phase_chemdr, gas_phase_chemdr_inti - public :: map2chm - - integer :: map2chm(pcnst) = 0 ! index map to/from chemistry/constituents list - - integer :: synoz_ndx, so4_ndx, h2o_ndx, o2_ndx, o_ndx, hno3_ndx, hcl_ndx, dst_ndx, cldice_ndx, snow_ndx - integer :: o3_ndx, o3s_ndx - integer :: het1_ndx - integer :: ndx_cldfr, ndx_cmfdqr, ndx_nevapr, ndx_cldtop, ndx_prain - integer :: ndx_h2so4 -#ifdef OSLO_AERO - logical :: inv_o3, inv_oh, inv_no3, inv_ho2 - integer :: id_o3, id_oh, id_no3, id_ho2 -#endif -! -! CCMI -! - integer :: st80_25_ndx - integer :: st80_25_tau_ndx - integer :: aoa_nh_ndx - integer :: aoa_nh_ext_ndx - integer :: nh_5_ndx - integer :: nh_50_ndx - integer :: nh_50w_ndx - integer :: sad_pbf_ndx - integer :: cb1_ndx,cb2_ndx,oc1_ndx,oc2_ndx,dst1_ndx,dst2_ndx,sslt1_ndx,sslt2_ndx - integer :: soa_ndx,soai_ndx,soam_ndx,soat_ndx,soab_ndx,soax_ndx - - character(len=fieldname_len),dimension(rxt_tag_cnt) :: tag_names - character(len=fieldname_len),dimension(extcnt) :: extfrc_name - - logical :: pm25_srf_diag - logical :: pm25_srf_diag_soa - - logical :: convproc_do_aer - integer :: ele_temp_ndx, ion_temp_ndx - -contains - - subroutine gas_phase_chemdr_inti() - - use mo_chem_utls, only : get_spc_ndx, get_extfrc_ndx, get_rxt_ndx, get_inv_ndx - use cam_history, only : addfld,add_default,horiz_only - use mo_chm_diags, only : chm_diags_inti - use constituents, only : cnst_get_ind - use physics_buffer, only : pbuf_get_index - use rate_diags, only : rate_diags_init - use cam_abortutils, only : endrun - - implicit none - - character(len=3) :: string - integer :: n, m, err, ii - logical :: history_cesm_forcing - character(len=16) :: unitstr - !----------------------------------------------------------------------- - logical :: history_scwaccm_forcing - - call phys_getopts( history_scwaccm_forcing_out = history_scwaccm_forcing ) - - call phys_getopts( convproc_do_aer_out = convproc_do_aer, history_cesm_forcing_out=history_cesm_forcing ) - -#if defined(OSLO_AERO) - inv_o3 = get_inv_ndx('O3') > 0 - inv_oh = get_inv_ndx('OH') > 0 - inv_no3 = get_inv_ndx('NO3') > 0 - inv_ho2 = get_inv_ndx('HO2') > 0 - if (inv_o3) then - id_o3 = get_inv_ndx('O3') - endif - if (inv_oh) then - id_oh = get_inv_ndx('OH') - endif - if (inv_no3) then - id_no3 = get_inv_ndx('NO3') - endif - if (inv_ho2) then - id_ho2 = get_inv_ndx('HO2') - endif -#endif - - ndx_h2so4 = get_spc_ndx('H2SO4') -! -! CCMI -! - st80_25_ndx = get_spc_ndx ('ST80_25') - st80_25_tau_ndx = get_rxt_ndx ('ST80_25_tau') - aoa_nh_ndx = get_spc_ndx ('AOA_NH') - aoa_nh_ext_ndx = get_extfrc_ndx('AOA_NH') - nh_5_ndx = get_spc_ndx('NH_5') - nh_50_ndx = get_spc_ndx('NH_50') - nh_50w_ndx = get_spc_ndx('NH_50W') -! - cb1_ndx = get_spc_ndx('CB1') - cb2_ndx = get_spc_ndx('CB2') - oc1_ndx = get_spc_ndx('OC1') - oc2_ndx = get_spc_ndx('OC2') - dst1_ndx = get_spc_ndx('DST01') - dst2_ndx = get_spc_ndx('DST02') - sslt1_ndx = get_spc_ndx('SSLT01') - sslt2_ndx = get_spc_ndx('SSLT02') - soa_ndx = get_spc_ndx('SOA') - soam_ndx = get_spc_ndx('SOAM') - soai_ndx = get_spc_ndx('SOAI') - soat_ndx = get_spc_ndx('SOAT') - soab_ndx = get_spc_ndx('SOAB') - soax_ndx = get_spc_ndx('SOAX') - - pm25_srf_diag = cb1_ndx>0 .and. cb2_ndx>0 .and. oc1_ndx>0 .and. oc2_ndx>0 & - .and. dst1_ndx>0 .and. dst2_ndx>0 .and. sslt1_ndx>0 .and. sslt2_ndx>0 & - .and. soa_ndx>0 - - pm25_srf_diag_soa = cb1_ndx>0 .and. cb2_ndx>0 .and. oc1_ndx>0 .and. oc2_ndx>0 & - .and. dst1_ndx>0 .and. dst2_ndx>0 .and. sslt1_ndx>0 .and. sslt2_ndx>0 & - .and. soam_ndx>0 .and. soai_ndx>0 .and. soat_ndx>0 .and. soab_ndx>0 .and. soax_ndx>0 - - if ( pm25_srf_diag .or. pm25_srf_diag_soa) then - call addfld('PM25_SRF',horiz_only,'I','kg/kg','bottom layer PM2.5 mixing ratio' ) - endif - call addfld('U_SRF',horiz_only,'I','m/s','bottom layer wind velocity' ) - call addfld('V_SRF',horiz_only,'I','m/s','bottom layer wind velocity' ) - call addfld('Q_SRF',horiz_only,'I','kg/kg','bottom layer specific humidity' ) -! - het1_ndx= get_rxt_ndx('het1') - o3_ndx = get_spc_ndx('O3') - o3s_ndx = get_spc_ndx('O3S') - o_ndx = get_spc_ndx('O') - o2_ndx = get_spc_ndx('O2') - so4_ndx = get_spc_ndx('SO4') - h2o_ndx = get_spc_ndx('H2O') - hno3_ndx = get_spc_ndx('HNO3') - hcl_ndx = get_spc_ndx('HCL') - dst_ndx = get_spc_ndx( dust_names(1) ) - synoz_ndx = get_extfrc_ndx( 'SYNOZ' ) - call cnst_get_ind( 'CLDICE', cldice_ndx ) - call cnst_get_ind( 'SNOWQM', snow_ndx, abort=.false. ) - - - do m = 1,extcnt - WRITE(UNIT=string, FMT='(I2.2)') m - extfrc_name(m) = 'extfrc_'// trim(string) - call addfld( extfrc_name(m), (/ 'lev' /), 'I', ' ', 'ext frcing' ) - end do - - do n = 1,rxt_tag_cnt - tag_names(n) = trim(rxt_tag_lst(n)) - if (n<=phtcnt) then - call addfld( tag_names(n), (/ 'lev' /), 'I', '/s', 'photolysis rate constant' ) - else - ii = n-phtcnt - select case(num_rnts(ii)) - case(1) - unitstr='/s' - case(2) - unitstr='cm3/molecules/s' - case(3) - unitstr='cm6/molecules2/s' - case default - call endrun('gas_phase_chemdr_inti: invalid value in num_rnts used to set units in reaction rate constant') - end select - call addfld( tag_names(n), (/ 'lev' /), 'I', unitstr, 'reaction rate constant' ) - endif - if (history_scwaccm_forcing) then - select case (trim(tag_names(n))) - case ('jh2o_a', 'jh2o_b', 'jh2o_c' ) - call add_default( tag_names(n), 1, ' ') - end select - endif - enddo - - call addfld( 'DTCBS', horiz_only, 'I', ' ','photolysis diagnostic black carbon OD' ) - call addfld( 'DTOCS', horiz_only, 'I', ' ','photolysis diagnostic organic carbon OD' ) - call addfld( 'DTSO4', horiz_only, 'I', ' ','photolysis diagnostic SO4 OD' ) - call addfld( 'DTSOA', horiz_only, 'I', ' ','photolysis diagnostic SOA OD' ) - call addfld( 'DTANT', horiz_only, 'I', ' ','photolysis diagnostic NH4SO4 OD' ) - call addfld( 'DTSAL', horiz_only, 'I', ' ','photolysis diagnostic salt OD' ) - call addfld( 'DTDUST', horiz_only, 'I', ' ','photolysis diagnostic dust OD' ) - call addfld( 'DTTOTAL', horiz_only, 'I', ' ','photolysis diagnostic total aerosol OD' ) - call addfld( 'FRACDAY', horiz_only, 'I', ' ','photolysis diagnostic fraction of day' ) - - call addfld( 'QDSAD', (/ 'lev' /), 'I', '/s', 'water vapor sad delta' ) - call addfld( 'SAD_STRAT', (/ 'lev' /), 'I', 'cm2/cm3', 'stratospheric aerosol SAD' ) - call addfld( 'SAD_SULFC', (/ 'lev' /), 'I', 'cm2/cm3', 'chemical sulfate aerosol SAD' ) - call addfld( 'SAD_SAGE', (/ 'lev' /), 'I', 'cm2/cm3', 'SAGE sulfate aerosol SAD' ) - call addfld( 'SAD_LNAT', (/ 'lev' /), 'I', 'cm2/cm3', 'large-mode NAT aerosol SAD' ) - call addfld( 'SAD_ICE', (/ 'lev' /), 'I', 'cm2/cm3', 'water-ice aerosol SAD' ) - call addfld( 'RAD_SULFC', (/ 'lev' /), 'I', 'cm', 'chemical sad sulfate' ) - call addfld( 'RAD_LNAT', (/ 'lev' /), 'I', 'cm', 'large nat radius' ) - call addfld( 'RAD_ICE', (/ 'lev' /), 'I', 'cm', 'sad ice' ) - call addfld( 'SAD_TROP', (/ 'lev' /), 'I', 'cm2/cm3', 'tropospheric aerosol SAD' ) - call addfld( 'SAD_AERO', (/ 'lev' /), 'I', 'cm2/cm3', 'aerosol surface area density' ) - if (history_cesm_forcing) then - call add_default ('SAD_AERO',8,' ') - endif - call addfld( 'REFF_AERO', (/ 'lev' /), 'I', 'cm', 'aerosol effective radius' ) - call addfld( 'SULF_TROP', (/ 'lev' /), 'I', 'mol/mol', 'tropospheric aerosol SAD' ) - call addfld( 'QDSETT', (/ 'lev' /), 'I', '/s', 'water vapor settling delta' ) - call addfld( 'QDCHEM', (/ 'lev' /), 'I', '/s', 'water vapor chemistry delta') - call addfld( 'HNO3_TOTAL', (/ 'lev' /), 'I', 'mol/mol', 'total HNO3' ) - call addfld( 'HNO3_STS', (/ 'lev' /), 'I', 'mol/mol', 'STS condensed HNO3' ) - call addfld( 'HNO3_NAT', (/ 'lev' /), 'I', 'mol/mol', 'NAT condensed HNO3' ) - call addfld( 'HNO3_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase hno3' ) - call addfld( 'H2O_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase h2o' ) - call addfld( 'HCL_TOTAL', (/ 'lev' /), 'I', 'mol/mol', 'total hcl' ) - call addfld( 'HCL_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase hcl' ) - call addfld( 'HCL_STS', (/ 'lev' /), 'I', 'mol/mol', 'STS condensed HCL' ) - - !++IH: Adding extra fields for oxi-output (before and after diurnal variations.) - call addfld ('OH_bef ', (/ 'lev' /), 'A','unit', 'OH invariants before adding diurnal variations' ) - call addfld ('HO2_bef ', (/ 'lev' /), 'A','unit', 'HO2 invariants before adding diurnal variations' ) - call addfld ('NO3_bef ', (/ 'lev' /), 'A','unit', 'NO3 invariants before adding diurnal variations' ) - call addfld ('OH_aft ', (/ 'lev' /), 'A','unit', 'OH invariants after adding diurnal variations' ) - call addfld ('HO2_aft ', (/ 'lev' /), 'A','unit', 'HO2 invariants after adding diurnal variations' ) - call addfld ('NO3_aft ', (/ 'lev' /), 'A','unit', 'NO3 invariants after adding diurnal variations' ) - - call add_default ('OH_bef ', 1, ' ') - call add_default ('HO2_bef ', 1, ' ') - call add_default ('NO3_bef ', 1, ' ') - call add_default ('OH_aft ', 1, ' ') - call add_default ('HO2_aft ', 1, ' ') - call add_default ('NO3_aft ', 1, ' ') - !--IH - - if (het1_ndx>0) then - call addfld( 'het1_total', (/ 'lev' /), 'I', '/s', 'total N2O5 + H2O het rate constant' ) - endif - call addfld( 'SZA', horiz_only, 'I', 'degrees', 'solar zenith angle' ) - - call chm_diags_inti() - call rate_diags_init() - -!----------------------------------------------------------------------- -! get pbuf indicies -!----------------------------------------------------------------------- - ndx_cldfr = pbuf_get_index('CLD') - ndx_cmfdqr = pbuf_get_index('RPRDTOT') - ndx_nevapr = pbuf_get_index('NEVAPR') - ndx_prain = pbuf_get_index('PRAIN') - ndx_cldtop = pbuf_get_index('CLDTOP') - - sad_pbf_ndx= pbuf_get_index('VOLC_SAD',errcode=err) ! prescribed strat aerosols (volcanic) - if (.not.sad_pbf_ndx>0) sad_pbf_ndx = pbuf_get_index('SADSULF',errcode=err) ! CARMA's version of strat aerosols - - ele_temp_ndx = pbuf_get_index('TElec',errcode=err)! electron temperature index - ion_temp_ndx = pbuf_get_index('TIon',errcode=err) ! ion temperature index - - ! diagnostics for stratospheric heterogeneous reactions - call addfld( 'GAMMA_HET1', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) - call addfld( 'GAMMA_HET2', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) - call addfld( 'GAMMA_HET3', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) - call addfld( 'GAMMA_HET4', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) - call addfld( 'GAMMA_HET5', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) - call addfld( 'GAMMA_HET6', (/ 'lev' /), 'I', '1', 'Reaction Probability' ) - call addfld( 'WTPER', (/ 'lev' /), 'I', '%', 'H2SO4 Weight Percent' ) - - call chem_prod_loss_diags_init - - end subroutine gas_phase_chemdr_inti - - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- - subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & - phis, zm, zi, calday, & - tfld, pmid, pdel, pint, & - cldw, troplev, troplevchem, & - ncldwtr, ufld, vfld, & - delt, ps, xactive_prates, & - fsds, ts, asdir, ocnfrac, icefrac, & - precc, precl, snowhland, ghg_chem, latmapback, & - drydepflx, wetdepflx, cflx, fire_sflx, fire_ztop, nhx_nitrogen_flx, noy_nitrogen_flx, qtend, pbuf) - - !----------------------------------------------------------------------- - ! ... Chem_solver advances the volumetric mixing ratio - ! forward one time step via a combination of explicit, - ! ebi, hov, fully implicit, and/or rodas algorithms. - !----------------------------------------------------------------------- - - use chem_mods, only : nabscol, nfs, indexm, clscnt4 - use physconst, only : rga - use mo_photo, only : set_ub_col, setcol, table_photo, xactive_photo - use mo_exp_sol, only : exp_sol - use mo_imp_sol, only : imp_sol - use mo_setrxt, only : setrxt - use mo_adjrxt, only : adjrxt - use mo_phtadj, only : phtadj - use llnl_O1D_to_2OH_adj,only : O1D_to_2OH_adj - use mo_usrrxt, only : usrrxt - use mo_setinv, only : setinv - use mo_negtrc, only : negtrc - use mo_sulf, only : sulf_interp - use mo_setext, only : setext - use fire_emissions, only : fire_emissions_vrt - use mo_sethet, only : sethet - use mo_drydep, only : drydep, set_soilw - use seq_drydep_mod, only : DD_XLND, DD_XATM, DD_TABL, drydep_method - use mo_fstrat, only : set_fstrat_vals, set_fstrat_h2o - use noy_ubc, only : noy_ubc_set - use mo_flbc, only : flbc_set - use phys_grid, only : get_rlat_all_p, get_rlon_all_p, get_lat_all_p, get_lon_all_p - use mo_mean_mass, only : set_mean_mass - use cam_history, only : outfld - use wv_saturation, only : qsat - use constituents, only : cnst_mw - use mo_drydep, only : has_drydep - use time_manager, only : get_ref_date - use mo_ghg_chem, only : ghg_chem_set_rates, ghg_chem_set_flbc - use mo_sad, only : sad_strat_calc - use charge_neutrality, only : charge_balance - use mo_strato_rates, only : ratecon_sfstrat - use mo_aero_settling, only : strat_aer_settling - use shr_orb_mod, only : shr_orb_decl - use cam_control_mod, only : lambm0, eccen, mvelpp, obliqr - use mo_strato_rates, only : has_strato_chem - use short_lived_species,only: set_short_lived_species,get_short_lived_species - use mo_chm_diags, only : chm_diags, het_diags - use perf_mod, only : t_startf, t_stopf - use gas_wetdep_opts, only : gas_wetdep_method -#if (defined OSLO_AERO) - use oslo_aero_diurnal_var, only : set_diurnal_invariants -#endif - use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx - use infnan, only : nan, assignment(=) - use rate_diags, only : rate_diags_calc - use mo_mass_xforms, only : mmr2vmr, vmr2mmr, h2o_to_vmr, mmr2vmri - use orbit, only : zenith -! -! LINOZ -! - use lin_strat_chem, only : do_lin_strat_chem, lin_strat_chem_solve - use linoz_data, only : has_linoz_data -! -! for aqueous chemistry and aerosol growth -! - use aero_model, only : aero_model_gasaerexch - - use aero_model, only : aero_model_strat_surfarea - - implicit none - - !----------------------------------------------------------------------- - ! ... Dummy arguments - !----------------------------------------------------------------------- - integer, intent(in) :: lchnk ! chunk index - integer, intent(in) :: ncol ! number columns in chunk - integer, intent(in) :: imozart ! gas phase start index in q - real(r8), intent(in) :: delt ! timestep (s) - real(r8), intent(in) :: calday ! day of year - real(r8), intent(in) :: ps(pcols) ! surface pressure - real(r8), intent(in) :: phis(pcols) ! surface geopotential - real(r8),target,intent(in) :: tfld(pcols,pver) ! midpoint temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressures (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! pressure delta about midpoints (Pa) - real(r8), intent(in) :: ufld(pcols,pver) ! zonal velocity (m/s) - real(r8), intent(in) :: vfld(pcols,pver) ! meridional velocity (m/s) - real(r8), intent(in) :: cldw(pcols,pver) ! cloud water (kg/kg) - real(r8), intent(in) :: ncldwtr(pcols,pver) ! droplet number concentration (#/kg) - real(r8), intent(in) :: zm(pcols,pver) ! midpoint geopotential height above the surface (m) - real(r8), intent(in) :: zi(pcols,pver+1) ! interface geopotential height above the surface (m) - real(r8), intent(in) :: pint(pcols,pver+1) ! interface pressures (Pa) - real(r8), intent(in) :: q(pcols,pver,pcnst) ! species concentrations (kg/kg) - real(r8),pointer, intent(in) :: fire_sflx(:,:) ! fire emssions surface flux (kg/m^2/s) - real(r8),pointer, intent(in) :: fire_ztop(:) ! top of vertical distribution of fire emssions (m) - logical, intent(in) :: xactive_prates - real(r8), intent(in) :: fsds(pcols) ! longwave down at sfc - real(r8), intent(in) :: icefrac(pcols) ! sea-ice areal fraction - real(r8), intent(in) :: ocnfrac(pcols) ! ocean areal fraction - real(r8), intent(in) :: asdir(pcols) ! albedo: shortwave, direct - real(r8), intent(in) :: ts(pcols) ! sfc temp (merged w/ocean if coupled) - real(r8), intent(in) :: precc(pcols) ! - real(r8), intent(in) :: precl(pcols) ! - real(r8), intent(in) :: snowhland(pcols) ! - logical, intent(in) :: ghg_chem - integer, intent(in) :: latmapback(pcols) - integer, intent(in) :: troplev(pcols) ! trop/strat separation vertical index - integer, intent(in) :: troplevchem(pcols) ! trop/strat chemistry separation vertical index - real(r8), intent(inout) :: qtend(pcols,pver,pcnst) ! species tendencies (kg/kg/s) - real(r8), intent(inout) :: cflx(pcols,pcnst) ! constituent surface flux (kg/m^2/s) - real(r8), intent(out) :: drydepflx(pcols,pcnst) ! dry deposition flux (kg/m^2/s) - real(r8), intent(in) :: wetdepflx(pcols,pcnst) ! wet deposition flux (kg/m^2/s) - real(r8), intent(out) :: nhx_nitrogen_flx(pcols) - real(r8), intent(out) :: noy_nitrogen_flx(pcols) - - type(physics_buffer_desc), pointer :: pbuf(:) - - !----------------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------------- - real(r8), parameter :: m2km = 1.e-3_r8 - real(r8), parameter :: Pa2mb = 1.e-2_r8 - - real(r8), pointer :: prain(:,:) - real(r8), pointer :: nevapr(:,:) - real(r8), pointer :: cmfdqr(:,:) - real(r8), pointer :: cldfr(:,:) - real(r8), pointer :: cldtop(:) - - integer :: i, k, m, n - integer :: tim_ndx - real(r8) :: delt_inverse - real(r8) :: esfact - integer :: latndx(pcols) ! chunk lat indicies - integer :: lonndx(pcols) ! chunk lon indicies - real(r8) :: invariants(ncol,pver,nfs) - real(r8) :: col_dens(ncol,pver,max(1,nabscol)) ! column densities (molecules/cm^2) - real(r8) :: col_delta(ncol,0:pver,max(1,nabscol)) ! layer column densities (molecules/cm^2) - real(r8) :: extfrc(ncol,pver,max(1,extcnt)) - real(r8) :: vmr(ncol,pver,gas_pcnst) ! xported species (vmr) - real(r8) :: reaction_rates(ncol,pver,max(1,rxntot)) ! reaction rates - real(r8) :: depvel(ncol,gas_pcnst) ! dry deposition velocity (cm/s) - real(r8) :: het_rates(ncol,pver,max(1,gas_pcnst)) ! washout rate (1/s) - real(r8), dimension(ncol,pver) :: & - h2ovmr, & ! water vapor volume mixing ratio - mbar, & ! mean wet atmospheric mass ( amu ) - zmid, & ! midpoint geopotential in km - zmidr, & ! midpoint geopotential in km realitive to surf - sulfate, & ! trop sulfate aerosols - pmb ! pressure at midpoints ( hPa ) - real(r8), dimension(ncol,pver) :: & - cwat, & ! cloud water mass mixing ratio (kg/kg) - wrk - real(r8), dimension(ncol,pver+1) :: & - zintr ! interface geopotential in km realitive to surf - real(r8), dimension(ncol,pver+1) :: & - zint ! interface geopotential in km - real(r8), dimension(ncol) :: & - zen_angle, & ! solar zenith angles - zsurf, & ! surface height (m) - rlats, rlons ! chunk latitudes and longitudes (radians) - real(r8) :: sza(ncol) ! solar zenith angles (degrees) - real(r8), parameter :: rad2deg = 180._r8/pi ! radians to degrees conversion factor - real(r8) :: relhum(ncol,pver) ! relative humidity - real(r8) :: satv(ncol,pver) ! wrk array for relative humidity - real(r8) :: satq(ncol,pver) ! wrk array for relative humidity - - integer :: j - integer :: ltrop_sol(pcols) ! tropopause vertical index used in chem solvers - real(r8), pointer :: strato_sad(:,:) ! stratospheric sad (1/cm) - - real(r8) :: sad_trop(pcols,pver) ! total tropospheric sad (cm^2/cm^3) - real(r8) :: reff(pcols,pver) ! aerosol effective radius (cm) - real(r8) :: reff_strat(pcols,pver) ! stratospheric aerosol effective radius (cm) - - real(r8) :: tvs(pcols) - integer :: ncdate,yr,mon,day,sec - real(r8) :: wind_speed(pcols) ! surface wind speed (m/s) - logical, parameter :: dyn_soilw = .false. - logical :: table_soilw - real(r8) :: soilw(pcols) - real(r8) :: prect(pcols) - real(r8) :: sflx(pcols,gas_pcnst) - real(r8) :: wetdepflx_diag(pcols,gas_pcnst) - real(r8) :: dust_vmr(ncol,pver,ndust) - real(r8) :: dt_diag(pcols,8) ! od diagnostics - real(r8) :: fracday(pcols) ! fraction of day - real(r8) :: o2mmr(ncol,pver) ! o2 concentration (kg/kg) - real(r8) :: ommr(ncol,pver) ! o concentration (kg/kg) - real(r8) :: mmr(pcols,pver,gas_pcnst) ! chem working concentrations (kg/kg) - real(r8) :: mmr_new(pcols,pver,gas_pcnst) ! chem working concentrations (kg/kg) - real(r8) :: hno3_gas(ncol,pver) ! hno3 gas phase concentration (mol/mol) - real(r8) :: hno3_cond(ncol,pver,2) ! hno3 condensed phase concentration (mol/mol) - real(r8) :: hcl_gas(ncol,pver) ! hcl gas phase concentration (mol/mol) - real(r8) :: hcl_cond(ncol,pver) ! hcl condensed phase concentration (mol/mol) - real(r8) :: h2o_gas(ncol,pver) ! h2o gas phase concentration (mol/mol) - real(r8) :: h2o_cond(ncol,pver) ! h2o condensed phase concentration (mol/mol) - real(r8) :: cldice(pcols,pver) ! cloud water "ice" (kg/kg) - real(r8) :: radius_strat(ncol,pver,3) ! radius of sulfate, nat, & ice ( cm ) - real(r8) :: sad_strat(ncol,pver,3) ! surf area density of sulfate, nat, & ice ( cm^2/cm^3 ) - real(r8) :: mmr_tend(pcols,pver,gas_pcnst) ! chemistry species tendencies (kg/kg/s) - real(r8) :: qh2o(pcols,pver) ! specific humidity (kg/kg) - real(r8) :: delta - - ! for aerosol formation.... - real(r8) :: del_h2so4_gasprod(ncol,pver) - real(r8) :: vmr0(ncol,pver,gas_pcnst) - -! -! CCMI -! - real(r8) :: xlat - real(r8) :: pm25(ncol) - - real(r8) :: dlats(ncol) - - real(r8), dimension(ncol,pver) :: & ! aerosol reaction diagnostics - gprob_n2o5, & - gprob_cnt_hcl, & - gprob_cnt_h2o, & - gprob_bnt_h2o, & - gprob_hocl_hcl, & - gprob_hobr_hcl, & - wtper - - real(r8), pointer :: ele_temp_fld(:,:) ! electron temperature pointer - real(r8), pointer :: ion_temp_fld(:,:) ! ion temperature pointer - real(r8) :: prod_out(ncol,pver,max(1,clscnt4)) - real(r8) :: loss_out(ncol,pver,max(1,clscnt4)) - - if ( ele_temp_ndx>0 .and. ion_temp_ndx>0 ) then - call pbuf_get_field(pbuf, ele_temp_ndx, ele_temp_fld) - call pbuf_get_field(pbuf, ion_temp_ndx, ion_temp_fld) - else - ele_temp_fld => tfld - ion_temp_fld => tfld - endif - - ! initialize to NaN to hopefully catch user defined rxts that go unset - reaction_rates(:,:,:) = nan - - delt_inverse = 1._r8 / delt - !----------------------------------------------------------------------- - ! ... Get chunck latitudes and longitudes - !----------------------------------------------------------------------- - call get_lat_all_p( lchnk, ncol, latndx ) - call get_lon_all_p( lchnk, ncol, lonndx ) - call get_rlat_all_p( lchnk, ncol, rlats ) - call get_rlon_all_p( lchnk, ncol, rlons ) - tim_ndx = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ndx_prain, prain, start=(/1,1/), kount=(/ncol,pver/)) - call pbuf_get_field(pbuf, ndx_cldfr, cldfr, start=(/1,1,tim_ndx/), kount=(/ncol,pver,1/) ) - call pbuf_get_field(pbuf, ndx_cmfdqr, cmfdqr, start=(/1,1/), kount=(/ncol,pver/)) - call pbuf_get_field(pbuf, ndx_nevapr, nevapr, start=(/1,1/), kount=(/ncol,pver/)) - call pbuf_get_field(pbuf, ndx_cldtop, cldtop ) - - reff_strat(:,:) = 0._r8 - - dlats(:) = rlats(:)*rad2deg ! convert to degrees - - !----------------------------------------------------------------------- - ! ... Calculate cosine of zenith angle - ! then cast back to angle (radians) - !----------------------------------------------------------------------- - call zenith( calday, rlats, rlons, zen_angle, ncol , delt) !+tht delt - zen_angle(:) = acos( zen_angle(:) ) - - sza(:) = zen_angle(:) * rad2deg - call outfld( 'SZA', sza, ncol, lchnk ) - - !----------------------------------------------------------------------- - ! ... Xform geopotential height from m to km - ! and pressure from Pa to mb - !----------------------------------------------------------------------- - zsurf(:ncol) = rga * phis(:ncol) - do k = 1,pver - zintr(:ncol,k) = m2km * zi(:ncol,k) - zmidr(:ncol,k) = m2km * zm(:ncol,k) - zmid(:ncol,k) = m2km * (zm(:ncol,k) + zsurf(:ncol)) - zint(:ncol,k) = m2km * (zi(:ncol,k) + zsurf(:ncol)) - pmb(:ncol,k) = Pa2mb * pmid(:ncol,k) - end do - zint(:ncol,pver+1) = m2km * (zi(:ncol,pver+1) + zsurf(:ncol)) - zintr(:ncol,pver+1)= m2km * zi(:ncol,pver+1) - - !----------------------------------------------------------------------- - ! ... map incoming concentrations to working array - !----------------------------------------------------------------------- - do m = 1,pcnst - n = map2chm(m) - if( n > 0 ) then - mmr(:ncol,:,n) = q(:ncol,:,m) - end if - end do - - call get_short_lived_species( mmr, lchnk, ncol, pbuf ) - - !----------------------------------------------------------------------- - ! ... Set atmosphere mean mass - !----------------------------------------------------------------------- - call set_mean_mass( ncol, mmr, mbar ) - - !----------------------------------------------------------------------- - ! ... Xform from mmr to vmr - !----------------------------------------------------------------------- - call mmr2vmr( mmr(:ncol,:,:), vmr(:ncol,:,:), mbar(:ncol,:), ncol ) - -! -! CCMI -! -! reset STE tracer to specific vmr of 200 ppbv -! - if ( st80_25_ndx > 0 ) then - where ( pmid(:ncol,:) < 80.e+2_r8 ) - vmr(:ncol,:,st80_25_ndx) = 200.e-9_r8 - end where - end if -! -! reset AOA_NH, NH_5, NH_50, NH_50W surface mixing ratios between 30N and 50N -! - if ( aoa_nh_ndx>0 ) then - do j=1,ncol - xlat = dlats(j) - if ( xlat >= 30._r8 .and. xlat <= 50._r8 ) then - vmr(j,pver,aoa_nh_ndx) = 0._r8 - end if - end do - end if - if ( nh_5_ndx>0 ) then - do j=1,ncol - xlat = dlats(j) - if ( xlat >= 30._r8 .and. xlat <= 50._r8 ) then - vmr(j,pver,nh_5_ndx) = 100.e-9_r8 - end if - end do - end if - if ( nh_50_ndx>0 ) then - do j=1,ncol - xlat = dlats(j) - if ( xlat >= 30._r8 .and. xlat <= 50._r8 ) then - vmr(j,pver,nh_50_ndx) = 100.e-9_r8 - end if - end do - end if - if ( nh_50w_ndx>0 ) then - do j=1,ncol - xlat = dlats(j) - if ( xlat >= 30._r8 .and. xlat <= 50._r8 ) then - vmr(j,pver,nh_50w_ndx) = 100.e-9_r8 - end if - end do - end if - - if (h2o_ndx>0) then - !----------------------------------------------------------------------- - ! ... store water vapor in wrk variable - !----------------------------------------------------------------------- - qh2o(:ncol,:) = mmr(:ncol,:,h2o_ndx) - h2ovmr(:ncol,:) = vmr(:ncol,:,h2o_ndx) - else - qh2o(:ncol,:) = q(:ncol,:,1) - !----------------------------------------------------------------------- - ! ... Xform water vapor from mmr to vmr and set upper bndy values - !----------------------------------------------------------------------- - call h2o_to_vmr( q(:ncol,:,1), h2ovmr(:ncol,:), mbar(:ncol,:), ncol ) - - call set_fstrat_h2o( h2ovmr, pmid, troplev, calday, ncol, lchnk ) - - endif - - !----------------------------------------------------------------------- - ! ... force ion/electron balance - !----------------------------------------------------------------------- - call charge_balance( ncol, vmr ) - - !----------------------------------------------------------------------- - ! ... Set the "invariants" - !----------------------------------------------------------------------- - call setinv( invariants, tfld, h2ovmr, vmr, pmid, ncol, lchnk, pbuf ) - - !----------------------------------------------------------------------- -#if defined (OSLO_AERO) - ! ... Set the "day/night cycle for prescribed oxidants" - !----------------------------------------------------------------------- - - !++IH - call outfld('OH_bef', invariants(:,:,id_oh), ncol, lchnk) - call outfld('HO2_bef', invariants(:,:,id_ho2), ncol, lchnk) - call outfld('NO3_bef', invariants(:,:,id_no3), ncol, lchnk) - !--IH - - if (inv_oh.or.inv_ho2.or.inv_no3) & !++IH: added inv_no3 - call set_diurnal_invariants(invariants,delt,ncol,lchnk,inv_oh,inv_ho2,id_oh,id_ho2,inv_no3,id_no3) !++IH: added inv_no3 and id_no3 - - !++IH - call outfld('OH_aft', invariants(:,:,id_oh), ncol, lchnk) - call outfld('HO2_aft', invariants(:,:,id_ho2), ncol, lchnk) - call outfld('NO3_aft', invariants(:,:,id_no3), ncol, lchnk) - !--IH - -#endif - ! ... stratosphere aerosol surface area - !----------------------------------------------------------------------- - if (sad_pbf_ndx>0) then - call pbuf_get_field(pbuf, sad_pbf_ndx, strato_sad) - else - allocate(strato_sad(pcols,pver)) - strato_sad(:,:) = 0._r8 - - ! Prognostic modal stratospheric sulfate: compute dry strato_sad - call aero_model_strat_surfarea( ncol, mmr, pmid, tfld, troplevchem, pbuf, strato_sad, reff_strat ) - - endif - - stratochem: if ( has_strato_chem ) then - !----------------------------------------------------------------------- - ! ... initialize condensed and gas phases; all hno3 to gas - !----------------------------------------------------------------------- - hcl_cond(:,:) = 0.0_r8 - hcl_gas (:,:) = 0.0_r8 - do k = 1,pver - hno3_gas(:,k) = vmr(:,k,hno3_ndx) - h2o_gas(:,k) = h2ovmr(:,k) - hcl_gas(:,k) = vmr(:,k,hcl_ndx) - wrk(:,k) = h2ovmr(:,k) - if (snow_ndx>0) then - cldice(:ncol,k) = q(:ncol,k,cldice_ndx) + q(:ncol,k,snow_ndx) - else - cldice(:ncol,k) = q(:ncol,k,cldice_ndx) - endif - end do - do m = 1,2 - do k = 1,pver - hno3_cond(:,k,m) = 0._r8 - end do - end do - - call mmr2vmri( cldice(:ncol,:), h2o_cond(:ncol,:), mbar(:ncol,:), cnst_mw(cldice_ndx), ncol ) - - !----------------------------------------------------------------------- - ! ... call SAD routine - !----------------------------------------------------------------------- - call sad_strat_calc( lchnk, invariants(:ncol,:,indexm), pmb, tfld, hno3_gas, & - hno3_cond, h2o_gas, h2o_cond, hcl_gas, hcl_cond, strato_sad(:ncol,:), radius_strat, & - sad_strat, ncol, pbuf ) - -! NOTE: output of total HNO3 is before vmr is set to gas-phase. - call outfld( 'HNO3_TOTAL', vmr(:ncol,:,hno3_ndx), ncol ,lchnk ) - - - do k = 1,pver - vmr(:,k,hno3_ndx) = hno3_gas(:,k) - h2ovmr(:,k) = h2o_gas(:,k) - vmr(:,k,h2o_ndx) = h2o_gas(:,k) - wrk(:,k) = (h2ovmr(:,k) - wrk(:,k))*delt_inverse - end do - - call outfld( 'QDSAD', wrk(:,:), ncol, lchnk ) -! - call outfld( 'SAD_STRAT', strato_sad(:ncol,:), ncol, lchnk ) - call outfld( 'SAD_SULFC', sad_strat(:,:,1), ncol, lchnk ) - call outfld( 'SAD_LNAT', sad_strat(:,:,2), ncol, lchnk ) - call outfld( 'SAD_ICE', sad_strat(:,:,3), ncol, lchnk ) -! - call outfld( 'RAD_SULFC', radius_strat(:,:,1), ncol, lchnk ) - call outfld( 'RAD_LNAT', radius_strat(:,:,2), ncol, lchnk ) - call outfld( 'RAD_ICE', radius_strat(:,:,3), ncol, lchnk ) -! - call outfld( 'HNO3_GAS', vmr(:ncol,:,hno3_ndx), ncol, lchnk ) - call outfld( 'HNO3_STS', hno3_cond(:,:,1), ncol, lchnk ) - call outfld( 'HNO3_NAT', hno3_cond(:,:,2), ncol, lchnk ) -! - call outfld( 'HCL_TOTAL', vmr(:ncol,:,hcl_ndx), ncol, lchnk ) - call outfld( 'HCL_GAS', hcl_gas (:,:), ncol ,lchnk ) - call outfld( 'HCL_STS', hcl_cond(:,:), ncol ,lchnk ) - - !----------------------------------------------------------------------- - ! ... call aerosol reaction rates - !----------------------------------------------------------------------- - call ratecon_sfstrat( ncol, invariants(:,:,indexm), pmid, tfld, & - radius_strat(:,:,1), sad_strat(:,:,1), sad_strat(:,:,2), & - sad_strat(:,:,3), h2ovmr, vmr, reaction_rates, & - gprob_n2o5, gprob_cnt_hcl, gprob_cnt_h2o, gprob_bnt_h2o, & - gprob_hocl_hcl, gprob_hobr_hcl, wtper ) - - call outfld( 'GAMMA_HET1', gprob_n2o5 (:ncol,:), ncol, lchnk ) - call outfld( 'GAMMA_HET2', gprob_cnt_h2o (:ncol,:), ncol, lchnk ) - call outfld( 'GAMMA_HET3', gprob_bnt_h2o (:ncol,:), ncol, lchnk ) - call outfld( 'GAMMA_HET4', gprob_cnt_hcl (:ncol,:), ncol, lchnk ) - call outfld( 'GAMMA_HET5', gprob_hocl_hcl(:ncol,:), ncol, lchnk ) - call outfld( 'GAMMA_HET6', gprob_hobr_hcl(:ncol,:), ncol, lchnk ) - call outfld( 'WTPER', wtper (:ncol,:), ncol, lchnk ) - - endif stratochem - -! NOTE: For gas-phase solver only. -! ratecon_sfstrat needs total hcl. - if (hcl_ndx>0) then - vmr(:,:,hcl_ndx) = hcl_gas(:,:) - endif - - !----------------------------------------------------------------------- - ! ... Set the column densities at the upper boundary - !----------------------------------------------------------------------- - call set_ub_col( col_delta, vmr, invariants, pint(:,1), pdel, ncol, lchnk) - - !----------------------------------------------------------------------- - ! ... Set rates for "tabular" and user specified reactions - !----------------------------------------------------------------------- - call setrxt( reaction_rates, tfld, invariants(1,1,indexm), ncol ) - - sulfate(:,:) = 0._r8 - if ( .not. carma_hetchem_feedback ) then - if( so4_ndx < 1 ) then ! get offline so4 field if not prognostic - call sulf_interp( ncol, lchnk, sulfate ) - else - sulfate(:,:) = vmr(:,:,so4_ndx) - endif - endif - - !----------------------------------------------------------------- - ! ... zero out sulfate above tropopause - !----------------------------------------------------------------- - do k = 1, pver - do i = 1, ncol - if (k < troplevchem(i)) then - sulfate(i,k) = 0.0_r8 - end if - end do - end do - - call outfld( 'SULF_TROP', sulfate(:ncol,:), ncol, lchnk ) - - !----------------------------------------------------------------- - ! ... compute the relative humidity - !----------------------------------------------------------------- - call qsat(tfld(:ncol,:), pmid(:ncol,:), satv, satq) - - do k = 1,pver - relhum(:,k) = .622_r8 * h2ovmr(:,k) / satq(:,k) - relhum(:,k) = max( 0._r8,min( 1._r8,relhum(:,k) ) ) - end do - - cwat(:ncol,:pver) = cldw(:ncol,:pver) - - call usrrxt( reaction_rates, tfld, ion_temp_fld, ele_temp_fld, invariants, h2ovmr, & - pmid, invariants(:,:,indexm), sulfate, mmr, relhum, strato_sad, & - troplevchem, dlats, ncol, sad_trop, reff, cwat, mbar, pbuf ) - - call outfld( 'SAD_TROP', sad_trop(:ncol,:), ncol, lchnk ) - - ! Add trop/strat components of SAD for output - sad_trop(:ncol,:)=sad_trop(:ncol,:)+strato_sad(:ncol,:) - call outfld( 'SAD_AERO', sad_trop(:ncol,:), ncol, lchnk ) - - ! Add trop/strat components of effective radius for output - reff(:ncol,:)=reff(:ncol,:)+reff_strat(:ncol,:) - call outfld( 'REFF_AERO', reff(:ncol,:), ncol, lchnk ) - - if (het1_ndx>0) then - call outfld( 'het1_total', reaction_rates(:,:,het1_ndx), ncol, lchnk ) - endif - - if (ghg_chem) then - call ghg_chem_set_rates( reaction_rates, latmapback, zen_angle, ncol, lchnk ) - endif - - do i = phtcnt+1,rxt_tag_cnt - call outfld( tag_names(i), reaction_rates(:ncol,:,rxt_tag_map(i)), ncol, lchnk ) - enddo - - call adjrxt( reaction_rates, invariants, invariants(1,1,indexm), ncol,pver ) - - !----------------------------------------------------------------------- - ! ... Compute the photolysis rates at time = t(n+1) - !----------------------------------------------------------------------- - !----------------------------------------------------------------------- - ! ... Set the column densities - !----------------------------------------------------------------------- - call setcol( col_delta, col_dens, vmr, pdel, ncol ) - - !----------------------------------------------------------------------- - ! ... Calculate the photodissociation rates - !----------------------------------------------------------------------- - - esfact = 1._r8 - call shr_orb_decl( calday, eccen, mvelpp, lambm0, obliqr , & - delta, esfact ) - - - if ( xactive_prates ) then - if ( dst_ndx > 0 ) then - dust_vmr(:ncol,:,1:ndust) = vmr(:ncol,:,dst_ndx:dst_ndx+ndust-1) - else - dust_vmr(:ncol,:,:) = 0._r8 - endif - - !----------------------------------------------------------------- - ! ... compute the photolysis rates - !----------------------------------------------------------------- - call xactive_photo( reaction_rates, vmr, tfld, cwat, cldfr, & - pmid, zmidr, col_dens, zen_angle, asdir, & - invariants(1,1,indexm), ps, ts, & - esfact, relhum, dust_vmr, dt_diag, fracday, ncol, lchnk ) - - call outfld('DTCBS', dt_diag(:ncol,1), ncol, lchnk ) - call outfld('DTOCS', dt_diag(:ncol,2), ncol, lchnk ) - call outfld('DTSO4', dt_diag(:ncol,3), ncol, lchnk ) - call outfld('DTANT', dt_diag(:ncol,4), ncol, lchnk ) - call outfld('DTSAL', dt_diag(:ncol,5), ncol, lchnk ) - call outfld('DTDUST', dt_diag(:ncol,6), ncol, lchnk ) - call outfld('DTSOA', dt_diag(:ncol,7), ncol, lchnk ) - call outfld('DTTOTAL', dt_diag(:ncol,8), ncol, lchnk ) - call outfld('FRACDAY', fracday(:ncol), ncol, lchnk ) - - else - !----------------------------------------------------------------- - ! ... lookup the photolysis rates from table - !----------------------------------------------------------------- - call table_photo( reaction_rates, pmid, pdel, tfld, zmid, zint, & - col_dens, zen_angle, asdir, cwat, cldfr, & - esfact, vmr, invariants, ncol, lchnk, pbuf ) - endif - - do i = 1,phtcnt - call outfld( tag_names(i), reaction_rates(:ncol,:,rxt_tag_map(i)), ncol, lchnk ) - enddo - - !----------------------------------------------------------------------- - ! ... Adjust the photodissociation rates - !----------------------------------------------------------------------- - call O1D_to_2OH_adj( reaction_rates, invariants, invariants(:,:,indexm), ncol, tfld ) - call phtadj( reaction_rates, invariants, invariants(:,:,indexm), ncol,pver ) - - !----------------------------------------------------------------------- - ! ... Compute the extraneous frcing at time = t(n+1) - !----------------------------------------------------------------------- - if ( o2_ndx > 0 .and. o_ndx > 0 ) then - do k = 1,pver - o2mmr(:ncol,k) = mmr(:ncol,k,o2_ndx) - ommr(:ncol,k) = mmr(:ncol,k,o_ndx) - end do - endif - call setext( extfrc, zint, zintr, cldtop, & - zmid, lchnk, tfld, o2mmr, ommr, & - pmid, mbar, rlats, calday, ncol, rlons, pbuf ) - ! include forcings from fire emissions ... - call fire_emissions_vrt( ncol, lchnk, zint, fire_sflx, fire_ztop, extfrc ) - - do m = 1,extcnt - if( m /= synoz_ndx .and. m /= aoa_nh_ext_ndx ) then - do k = 1,pver - extfrc(:ncol,k,m) = extfrc(:ncol,k,m) / invariants(:ncol,k,indexm) - end do - endif - call outfld( extfrc_name(m), extfrc(:ncol,:,m), ncol, lchnk ) - end do - - !----------------------------------------------------------------------- - ! ... Form the washout rates - !----------------------------------------------------------------------- - if ( gas_wetdep_method=='MOZ' ) then - call sethet( het_rates, pmid, zmid, phis, tfld, & - cmfdqr, prain, nevapr, delt, invariants(:,:,indexm), & - vmr, ncol, lchnk ) - if (.not. convproc_do_aer) then - call het_diags( het_rates(:ncol,:,:), mmr(:ncol,:,:), pdel(:ncol,:), lchnk, ncol ) - endif - else - het_rates = 0._r8 - end if -! -! CCMI -! -! set loss to below the tropopause only -! - if ( st80_25_tau_ndx > 0 ) then - do i = 1,ncol - reaction_rates(i,1:troplev(i),st80_25_tau_ndx) = 0._r8 - enddo - end if - - if ( has_linoz_data ) then - ltrop_sol(:ncol) = troplev(:ncol) - else - ltrop_sol(:ncol) = 0 ! apply solver to all levels - endif - - ! save h2so4 before gas phase chem (for later new particle nucleation) - if (ndx_h2so4 > 0) then - del_h2so4_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - else - del_h2so4_gasprod(:,:) = 0.0_r8 - endif - - vmr0(:ncol,:,:) = vmr(:ncol,:,:) ! mixing ratios before chemistry changes - - !======================================================================= - ! ... Call the class solution algorithms - !======================================================================= - !----------------------------------------------------------------------- - ! ... Solve for "Explicit" species - !----------------------------------------------------------------------- - call exp_sol( vmr, reaction_rates, het_rates, extfrc, delt, invariants(1,1,indexm), ncol, lchnk, ltrop_sol ) - - !----------------------------------------------------------------------- - ! ... Solve for "Implicit" species - !----------------------------------------------------------------------- - if ( has_strato_chem ) wrk(:,:) = vmr(:,:,h2o_ndx) - call t_startf('imp_sol') - ! - call imp_sol( vmr, reaction_rates, het_rates, extfrc, delt, & - ncol,pver, lchnk, prod_out, loss_out ) - - call t_stopf('imp_sol') - - call chem_prod_loss_diags_out( ncol, lchnk, vmr, reaction_rates, prod_out, loss_out, invariants(:ncol,:,indexm) ) - if( h2o_ndx>0) call outfld( 'H2O_GAS', vmr(1,1,h2o_ndx), ncol ,lchnk ) - - ! reset O3S to O3 in the stratosphere ... - if ( o3_ndx > 0 .and. o3s_ndx > 0 ) then - do i = 1,ncol - vmr(i,1:troplev(i),o3s_ndx) = vmr(i,1:troplev(i),o3_ndx) - end do - end if - - if (convproc_do_aer) then - call vmr2mmr( vmr(:ncol,:,:), mmr_new(:ncol,:,:), mbar(:ncol,:), ncol ) - ! mmr_new = average of mmr values before and after imp_sol - mmr_new(:ncol,:,:) = 0.5_r8*( mmr(:ncol,:,:) + mmr_new(:ncol,:,:) ) - call het_diags( het_rates(:ncol,:,:), mmr_new(:ncol,:,:), pdel(:ncol,:), lchnk, ncol ) - endif - - ! save h2so4 change by gas phase chem (for later new particle nucleation) - if (ndx_h2so4 > 0) then - del_h2so4_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - del_h2so4_gasprod(1:ncol,:) - endif - -! -! Aerosol processes ... -! - - call aero_model_gasaerexch( imozart-1, ncol, lchnk, troplevchem, delt, reaction_rates, & - tfld, pmid, pdel, mbar, relhum, & - zm, qh2o, cwat, cldfr, ncldwtr, & - invariants(:,:,indexm), invariants, del_h2so4_gasprod, & - vmr0, vmr, pbuf ) - - if ( has_strato_chem ) then - - wrk(:ncol,:) = (vmr(:ncol,:,h2o_ndx) - wrk(:ncol,:))*delt_inverse - call outfld( 'QDCHEM', wrk(:ncol,:), ncol, lchnk ) - call outfld( 'HNO3_GAS', vmr(:ncol,:,hno3_ndx), ncol ,lchnk ) - - !----------------------------------------------------------------------- - ! ... aerosol settling - ! first settle hno3(2) using radius ice - ! secnd settle hno3(3) using radius large nat - !----------------------------------------------------------------------- - wrk(:,:) = vmr(:,:,h2o_ndx) -#ifdef ALT_SETTL - where( h2o_cond(:,:) > 0._r8 ) - settl_rad(:,:) = radius_strat(:,:,3) - elsewhere - settl_rad(:,:) = 0._r8 - endwhere - call strat_aer_settling( invariants(1,1,indexm), pmid, delt, zmid, tfld, & - hno3_cond(1,1,2), settl_rad, ncol, lchnk, 1 ) - - where( h2o_cond(:,:) == 0._r8 ) - settl_rad(:,:) = radius_strat(:,:,2) - elsewhere - settl_rad(:,:) = 0._r8 - endwhere - call strat_aer_settling( invariants(1,1,indexm), pmid, delt, zmid, tfld, & - hno3_cond(1,1,2), settl_rad, ncol, lchnk, 2 ) -#else - call strat_aer_settling( invariants(1,1,indexm), pmid, delt, zmid, tfld, & - hno3_cond(1,1,2), radius_strat(1,1,2), ncol, lchnk, 2 ) -#endif - - !----------------------------------------------------------------------- - ! ... reform total hno3 and hcl = gas + all condensed - !----------------------------------------------------------------------- -! NOTE: vmr for hcl and hno3 is gas-phase at this point. -! hno3_cond(:,k,1) = STS; hno3_cond(:,k,2) = NAT - - do k = 1,pver - vmr(:,k,hno3_ndx) = vmr(:,k,hno3_ndx) + hno3_cond(:,k,1) & - + hno3_cond(:,k,2) - vmr(:,k,hcl_ndx) = vmr(:,k,hcl_ndx) + hcl_cond(:,k) - - end do - - wrk(:,:) = (vmr(:,:,h2o_ndx) - wrk(:,:))*delt_inverse - call outfld( 'QDSETT', wrk(:,:), ncol, lchnk ) - - endif - -! -! LINOZ -! - if ( do_lin_strat_chem ) then - call lin_strat_chem_solve( ncol, lchnk, vmr(:,:,o3_ndx), col_dens(:,:,1), tfld, zen_angle, pmid, delt, rlats, troplev ) - end if - - !----------------------------------------------------------------------- - ! ... Check for negative values and reset to zero - !----------------------------------------------------------------------- - call negtrc( 'After chemistry ', vmr, ncol ) - - !----------------------------------------------------------------------- - ! ... Set upper boundary mmr values - !----------------------------------------------------------------------- - call set_fstrat_vals( vmr, pmid, pint, troplev, calday, ncol,lchnk ) - - !----------------------------------------------------------------------- - ! ... Set fixed lower boundary mmr values - !----------------------------------------------------------------------- - call flbc_set( vmr, ncol, lchnk, map2chm ) - - !----------------------------------------------------------------------- - ! set NOy UBC - !----------------------------------------------------------------------- - call noy_ubc_set( lchnk, ncol, vmr ) - - if ( ghg_chem ) then - call ghg_chem_set_flbc( vmr, ncol ) - endif - - !----------------------------------------------------------------------- - ! force ion/electron balance -- ext forcings likely do not conserve charge - !----------------------------------------------------------------------- - call charge_balance( ncol, vmr ) - - !----------------------------------------------------------------------- - ! ... Xform from vmr to mmr - !----------------------------------------------------------------------- - call vmr2mmr( vmr(:ncol,:,:), mmr_tend(:ncol,:,:), mbar(:ncol,:), ncol ) - - call set_short_lived_species( mmr_tend, lchnk, ncol, pbuf ) - - !----------------------------------------------------------------------- - ! ... Form the tendencies - !----------------------------------------------------------------------- - do m = 1,gas_pcnst - mmr_new(:ncol,:,m) = mmr_tend(:ncol,:,m) - mmr_tend(:ncol,:,m) = (mmr_tend(:ncol,:,m) - mmr(:ncol,:,m))*delt_inverse - enddo - - do m = 1,pcnst - n = map2chm(m) - if( n > 0 ) then - qtend(:ncol,:,m) = qtend(:ncol,:,m) + mmr_tend(:ncol,:,n) - end if - end do - - tvs(:ncol) = tfld(:ncol,pver) * (1._r8 + qh2o(:ncol,pver)) - - sflx(:,:) = 0._r8 - call get_ref_date(yr, mon, day, sec) - ncdate = yr*10000 + mon*100 + day - wind_speed(:ncol) = sqrt( ufld(:ncol,pver)*ufld(:ncol,pver) + vfld(:ncol,pver)*vfld(:ncol,pver) ) - prect(:ncol) = precc(:ncol) + precl(:ncol) - - if ( drydep_method == DD_XLND ) then - soilw = -99 - call drydep( ocnfrac, icefrac, ncdate, ts, ps, & - wind_speed, qh2o(:,pver), tfld(:,pver), pmid(:,pver), prect, & - snowhland, fsds, depvel, sflx, mmr, & - tvs, soilw, relhum(:,pver:pver), ncol, lonndx, latndx, lchnk ) - else if ( drydep_method == DD_XATM ) then - table_soilw = has_drydep( 'H2' ) .or. has_drydep( 'CO' ) - if( .not. dyn_soilw .and. table_soilw ) then - call set_soilw( soilw, lchnk, calday ) - end if - call drydep( ncdate, ts, ps, & - wind_speed, qh2o(:,pver), tfld(:,pver), pmid(:,pver), prect, & - snowhland, fsds, depvel, sflx, mmr, & - tvs, soilw, relhum(:,pver:pver), ncol, lonndx, latndx, lchnk ) - else if ( drydep_method == DD_TABL ) then - call drydep( calday, ts, zen_angle, & - depvel, sflx, mmr, pmid(:,pver), & - tvs, ncol, icefrac, ocnfrac, lchnk ) - endif - - drydepflx(:,:) = 0._r8 - do m = 1,pcnst - n = map2chm( m ) - if ( n > 0 ) then - cflx(:ncol,m) = cflx(:ncol,m) - sflx(:ncol,n) - drydepflx(:ncol,m) = sflx(:ncol,n) - wetdepflx_diag(:ncol,n) = wetdepflx(:ncol,m) - endif - end do - - call chm_diags( lchnk, ncol, vmr(:ncol,:,:), mmr_new(:ncol,:,:), & - reaction_rates(:ncol,:,:), invariants(:ncol,:,:), depvel(:ncol,:), sflx(:ncol,:), & - mmr_tend(:ncol,:,:), pdel(:ncol,:), pmid(:ncol,:), troplev(:ncol), wetdepflx_diag(:ncol,:), & - nhx_nitrogen_flx(:ncol), noy_nitrogen_flx(:ncol), pbuf ) - - call rate_diags_calc( reaction_rates(:,:,:), vmr(:,:,:), invariants(:,:,indexm), ncol, lchnk ) -! -! jfl -! -! surface vmr -! - if ( pm25_srf_diag ) then - pm25(:ncol) = mmr_new(:ncol,pver,cb1_ndx) & - + mmr_new(:ncol,pver,cb2_ndx) & - + mmr_new(:ncol,pver,oc1_ndx) & - + mmr_new(:ncol,pver,oc2_ndx) & - + mmr_new(:ncol,pver,dst1_ndx) & - + mmr_new(:ncol,pver,dst2_ndx) & - + mmr_new(:ncol,pver,sslt1_ndx) & - + mmr_new(:ncol,pver,sslt2_ndx) & - + mmr_new(:ncol,pver,soa_ndx) & - + mmr_new(:ncol,pver,so4_ndx) - call outfld('PM25_SRF',pm25(:ncol) , ncol, lchnk ) - endif - if ( pm25_srf_diag_soa ) then - pm25(:ncol) = mmr_new(:ncol,pver,cb1_ndx) & - + mmr_new(:ncol,pver,cb2_ndx) & - + mmr_new(:ncol,pver,oc1_ndx) & - + mmr_new(:ncol,pver,oc2_ndx) & - + mmr_new(:ncol,pver,dst1_ndx) & - + mmr_new(:ncol,pver,dst2_ndx) & - + mmr_new(:ncol,pver,sslt1_ndx) & - + mmr_new(:ncol,pver,sslt2_ndx) & - + mmr_new(:ncol,pver,soam_ndx) & - + mmr_new(:ncol,pver,soai_ndx) & - + mmr_new(:ncol,pver,soat_ndx) & - + mmr_new(:ncol,pver,soab_ndx) & - + mmr_new(:ncol,pver,soax_ndx) & - + mmr_new(:ncol,pver,so4_ndx) - call outfld('PM25_SRF',pm25(:ncol) , ncol, lchnk ) - endif -! -! - call outfld('Q_SRF',qh2o(:ncol,pver) , ncol, lchnk ) - call outfld('U_SRF',ufld(:ncol,pver) , ncol, lchnk ) - call outfld('V_SRF',vfld(:ncol,pver) , ncol, lchnk ) - -! - if (.not.sad_pbf_ndx>0) then - deallocate(strato_sad) - endif - - end subroutine gas_phase_chemdr - -end module mo_gas_phase_chemdr diff --git a/src/physics/cam_oslo/zm_microphysics.F90 b/src/physics/cam_oslo/zm_microphysics.F90 deleted file mode 100644 index e95caafe7d..0000000000 --- a/src/physics/cam_oslo/zm_microphysics.F90 +++ /dev/null @@ -1,2445 +0,0 @@ -module zm_microphysics - -!--------------------------------------------------------------------------------- -! Purpose: -! CAM Interface for cumulus microphysics -! -! Author: Xialiang Song and Guang Jun Zhang, June 2010 -!--------------------------------------------------------------------------------- - -use shr_kind_mod, only: r8=>shr_kind_r8 -use spmd_utils, only: masterproc -use ppgrid, only: pcols, pver, pverp -use physconst, only: gravit, rair, tmelt, cpair, rh2o, r_universal, mwh2o, rhoh2o -use physconst, only: latvap, latice -!use activate_drop_mam, only: actdrop_mam_calc -use ndrop, only: activate_modal -use ndrop_bam, only: ndrop_bam_run -use nucleate_ice, only: nucleati -use shr_spfn_mod, only: erf => shr_spfn_erf -use shr_spfn_mod, only: gamma => shr_spfn_gamma -use wv_saturation, only: svp_water, svp_ice -use cam_logfile, only: iulog -use cam_abortutils, only: endrun -use micro_mg_utils, only:ice_autoconversion, snow_self_aggregation, accrete_cloud_water_snow, & - secondary_ice_production, accrete_rain_snow, heterogeneous_rain_freezing, & - accrete_cloud_water_rain, self_collection_rain, accrete_cloud_ice_snow - -implicit none -private -save - -public :: & - zm_mphyi, & - zm_mphy, & - zm_conv_t,& - zm_aero_t - -! Private module data - -! constants remaped -real(r8) :: g ! gravity -real(r8) :: mw ! molecular weight of water -real(r8) :: r ! Dry air Gas constant -real(r8) :: rv ! water vapor gas contstant -real(r8) :: rr ! universal gas constant -real(r8) :: cpp ! specific heat of dry air -real(r8) :: rhow ! density of liquid water -real(r8) :: xlf ! latent heat of freezing - -!from 'microconstants' -real(r8) :: rhosn ! bulk density snow -real(r8) :: rhoi ! bulk density ice - -real(r8) :: ac,bc,as,bs,ai,bi,ar,br !fall speed parameters -real(r8) :: ci,di !ice mass-diameter relation parameters -real(r8) :: cs,ds !snow mass-diameter relation parameters -real(r8) :: cr,dr !drop mass-diameter relation parameters -real(r8) :: Eii !collection efficiency aggregation of ice -real(r8) :: Ecc !collection efficiency -real(r8) :: Ecr !collection efficiency cloud droplets/rain -real(r8) :: DCS !autoconversion size threshold -real(r8) :: bimm,aimm !immersion freezing -real(r8) :: rhosu !typical 850mn air density -real(r8) :: mi0 ! new crystal mass -real(r8) :: rin ! radius of contact nuclei -real(r8) :: pi ! pi - -! contact freezing due to dust -! dust number mean radius (m), Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 -real(r8), parameter :: rn_dst1 = 0.258e-6_r8 -real(r8), parameter :: rn_dst2 = 0.717e-6_r8 -real(r8), parameter :: rn_dst3 = 1.576e-6_r8 -real(r8), parameter :: rn_dst4 = 3.026e-6_r8 - -! smallest mixing ratio considered in microphysics -real(r8), parameter :: qsmall = 1.e-18_r8 - - -type, public :: ptr2d - real(r8), pointer :: val(:,:) -end type ptr2d - -! Aerosols -type :: zm_aero_t - - ! Aerosol treatment - character(len=5) :: scheme ! either 'bulk' or 'modal' - - ! Bulk aerosols - integer :: nbulk = 0 ! number of bulk aerosols affecting climate - integer :: idxsul = -1 ! index in aerosol list for sulfate - integer :: idxdst1 = -1 ! index in aerosol list for dust1 - integer :: idxdst2 = -1 ! index in aerosol list for dust2 - integer :: idxdst3 = -1 ! index in aerosol list for dust3 - integer :: idxdst4 = -1 ! index in aerosol list for dust4 - integer :: idxbcphi = -1 ! index in aerosol list for Soot (BCPHI) - - real(r8), allocatable :: num_to_mass_aer(:) ! conversion of mmr to number conc for bulk aerosols - type(ptr2d), allocatable :: mmr_bulk(:) ! array of pointers to bulk aerosol mmr - real(r8), allocatable :: mmrg_bulk(:,:,:) ! gathered bulk aerosol mmr - - ! Modal aerosols - integer :: nmodes = 0 ! number of modes - integer, allocatable :: nspec(:) ! number of species in each mode - type(ptr2d), allocatable :: num_a(:) ! number mixing ratio of modes (interstitial phase) - type(ptr2d), allocatable :: mmr_a(:,:) ! species mmr in each mode (interstitial phase) - real(r8), allocatable :: numg_a(:,:,:) ! gathered number mixing ratio of modes (interstitial phase) - real(r8), allocatable :: mmrg_a(:,:,:,:) ! gathered species mmr in each mode (interstitial phase) - real(r8), allocatable :: voltonumblo(:) ! volume to number conversion (lower bound) for each mode - real(r8), allocatable :: voltonumbhi(:) ! volume to number conversion (upper bound) for each mode - real(r8), allocatable :: specdens(:,:) ! density of modal species - real(r8), allocatable :: spechygro(:,:) ! hygroscopicity of modal species - - integer :: mode_accum_idx = -1 ! index of accumulation mode - integer :: mode_aitken_idx = -1 ! index of aitken mode - integer :: mode_coarse_idx = -1 ! index of coarse mode - integer :: coarse_dust_idx = -1 ! index of dust in coarse mode - integer :: coarse_nacl_idx = -1 ! index of nacl in coarse mode - - type(ptr2d), allocatable :: dgnum(:) ! mode dry radius - real(r8), allocatable :: dgnumg(:,:,:) ! gathered mode dry radius - - real(r8) :: sigmag_aitken - -end type zm_aero_t - -type :: zm_conv_t - - real(r8), allocatable :: qi(:,:) ! wg grid slice of cloud ice. - real(r8), allocatable :: qliq(:,:) ! convective cloud liquid water. - real(r8), allocatable :: qice(:,:) ! convective cloud ice. - real(r8), allocatable :: wu(:,:) ! vertical velocity - real(r8), allocatable :: sprd(:,:) ! rate of production of snow at that layer - real(r8), allocatable :: qrain(:,:) ! convective rain water. - real(r8), allocatable :: qsnow(:,:) ! convective snow. - real(r8), allocatable :: qnl(:,:) ! convective cloud liquid water num concen. - real(r8), allocatable :: qni(:,:) ! convective cloud ice num concen. - real(r8), allocatable :: qnr(:,:) ! convective rain water num concen. - real(r8), allocatable :: qns(:,:) ! convective snow num concen. - real(r8), allocatable :: frz(:,:) ! heating rate due to freezing - real(r8), allocatable :: autolm(:,:) !mass tendency due to autoconversion of droplets to rain - real(r8), allocatable :: accrlm(:,:) !mass tendency due to accretion of droplets by rain - real(r8), allocatable :: bergnm(:,:) !mass tendency due to Bergeron process - real(r8), allocatable :: fhtimm(:,:) !mass tendency due to immersion freezing - real(r8), allocatable :: fhtctm(:,:) !mass tendency due to contact freezing - real(r8), allocatable :: fhmlm (:,:) !mass tendency due to homogeneous freezing - real(r8), allocatable :: hmpim (:,:) !mass tendency due to HM process - real(r8), allocatable :: accslm(:,:) !mass tendency due to accretion of droplets by snow - real(r8), allocatable :: dlfm (:,:) !mass tendency due to detrainment of droplet - real(r8), allocatable :: autoln(:,:) !num tendency due to autoconversion of droplets to rain - real(r8), allocatable :: accrln(:,:) !num tendency due to accretion of droplets by rain - real(r8), allocatable :: bergnn(:,:) !num tendency due to Bergeron process - real(r8), allocatable :: fhtimn(:,:) !num tendency due to immersion freezing - real(r8), allocatable :: fhtctn(:,:) !num tendency due to contact freezing - real(r8), allocatable :: fhmln (:,:) !num tendency due to homogeneous freezing - real(r8), allocatable :: accsln(:,:) !num tendency due to accretion of droplets by snow - real(r8), allocatable :: activn(:,:) !num tendency due to droplets activation - real(r8), allocatable :: dlfn (:,:) !num tendency due to detrainment of droplet - real(r8), allocatable :: autoim(:,:) !mass tendency due to autoconversion of cloud ice to snow - real(r8), allocatable :: accsim(:,:) !mass tendency due to accretion of cloud ice by snow - real(r8), allocatable :: difm (:,:) !mass tendency due to detrainment of cloud ice - real(r8), allocatable :: nuclin(:,:) !num tendency due to ice nucleation - real(r8), allocatable :: autoin(:,:) !num tendency due to autoconversion of cloud ice to snow - real(r8), allocatable :: accsin(:,:) !num tendency due to accretion of cloud ice by snow - real(r8), allocatable :: hmpin (:,:) !num tendency due to HM process - real(r8), allocatable :: difn (:,:) !num tendency due to detrainment of cloud ice - real(r8), allocatable :: cmel (:,:) !mass tendency due to condensation - real(r8), allocatable :: cmei (:,:) !mass tendency due to deposition - real(r8), allocatable :: trspcm(:,:) !LWC tendency due to convective transport - real(r8), allocatable :: trspcn(:,:) !droplet num tendency due to convective transport - real(r8), allocatable :: trspim(:,:) !IWC tendency due to convective transport - real(r8), allocatable :: trspin(:,:) !ice crystal num tendency due to convective transport - real(r8), allocatable :: dcape(:) ! CAPE change due to freezing heating - real(r8), allocatable :: lambdadpcu(:,:)! slope of cloud liquid size distr - real(r8), allocatable :: mudpcu(:,:) ! width parameter of droplet size distr - real(r8), allocatable :: di(:,:) - real(r8), allocatable :: dnl(:,:) - real(r8), allocatable :: dni(:,:) - real(r8), allocatable :: qide(:,:) ! cloud ice mixing ratio for detrainment (kg/kg) - real(r8), allocatable :: qncde(:,:) ! cloud water number concentration for detrainment (1/kg) - real(r8), allocatable :: qnide(:,:) ! cloud ice number concentration for detrainment (1/kg) - - -end type zm_conv_t - -real(r8), parameter :: dcon = 25.e-6_r8 -real(r8), parameter :: mucon = 5.3_r8 -real(r8), parameter :: lambdadpcu = (mucon + 1._r8)/dcon - -!=============================================================================== -contains -!=============================================================================== - -subroutine zm_mphyi - -!----------------------------------------------------------------------- -! -! Purpose: -! initialize constants for the cumulus microphysics -! called from zm_conv_init() in zm_conv_intr.F90 -! -! Author: Xialiang Song, June 2010 -! -!----------------------------------------------------------------------- - -!NOTE: -! latent heats should probably be fixed with temperature -! for energy conservation with the rest of the model -! (this looks like a +/- 3 or 4% effect, but will mess up energy balance) - - xlf = latice ! latent heat freezing - -! from microconstants - -! parameters below from Reisner et al. (1998) -! density parameters (kg/m3) - - rhosn = 100._r8 ! bulk density snow - rhoi = 500._r8 ! bulk density ice - rhow = 1000._r8 ! bulk density liquid - -! fall speed parameters, V = aD^b -! V is in m/s - -! droplets - ac = 3.e7_r8 - bc = 2._r8 - -! snow - as = 11.72_r8 - bs = 0.41_r8 - -! cloud ice - ai = 700._r8 - bi = 1._r8 - -! rain - ar = 841.99667_r8 - br = 0.8_r8 - -! particle mass-diameter relationship -! currently we assume spherical particles for cloud ice/snow -! m = cD^d - - pi= 3.14159265358979323846_r8 - -! cloud ice mass-diameter relationship - - ci = rhoi*pi/6._r8 - di = 3._r8 - -! snow mass-diameter relationship - - cs = rhosn*pi/6._r8 - ds = 3._r8 - -! drop mass-diameter relationship - - cr = rhow*pi/6._r8 - dr = 3._r8 - -! collection efficiency, aggregation of cloud ice and snow - - Eii = 0.1_r8 - -! collection efficiency, accretion of cloud water by rain - - Ecr = 1.0_r8 - -! autoconversion size threshold for cloud ice to snow (m) - - Dcs = 150.e-6_r8 -! immersion freezing parameters, bigg 1953 - - bimm = 100._r8 - aimm = 0.66_r8 - -! typical air density at 850 mb - - rhosu = 85000._r8/(rair * tmelt) - -! mass of new crystal due to aerosol freezing and growth (kg) - - mi0 = 4._r8/3._r8*pi*rhoi*(10.e-6_r8)*(10.e-6_r8)*(10.e-6_r8) - -! radius of contact nuclei aerosol (m) - - rin = 0.1e-6_r8 - -end subroutine zm_mphyi - -!=============================================================================== - -subroutine zm_mphy(su, qu, mu, du, eu, cmel, cmei, zf, pm, te, qe, & - eps0, jb, jt, jlcl, msg, il2g, grav, cp, rd, aero, gamhat, & - qc, qi, nc, ni, qcde, qide, ncde, nide, rprd, sprd, frz, & - wu, qr, qni, nr, ns, autolm, accrlm, bergnm, fhtimm, fhtctm, & - fhmlm, hmpim, accslm, dlfm, autoln, accrln, bergnn, fhtimn, fhtctn, & - fhmln, accsln, activn, dlfn, autoim, accsim, difm, nuclin, autoin, & - accsin, hmpin, difn, trspcm, trspcn, trspim, trspin, lamc, pgam ) - - -! Purpose: -! microphysic parameterization for Zhang-McFarlane convection scheme -! called from cldprp() in zm_conv.F90 -! -! Author: Xialiang Song, June 2010 - - use time_manager, only: get_step_size - -! variable declarations - - implicit none - -! input variables - real(r8), intent(in) :: su(pcols,pver) ! normalized dry stat energy of updraft - real(r8), intent(in) :: qu(pcols,pver) ! spec hum of updraft - real(r8), intent(in) :: mu(pcols,pver) ! updraft mass flux - real(r8), intent(in) :: du(pcols,pver) ! detrainement rate of updraft - real(r8), intent(in) :: eu(pcols,pver) ! entrainment rate of updraft - real(r8), intent(in) :: cmel(pcols,pver) ! condensation rate of updraft - real(r8), intent(in) :: cmei(pcols,pver) ! condensation rate of updraft - real(r8), intent(in) :: zf(pcols,pverp) ! height of interfaces - real(r8), intent(in) :: pm(pcols,pver) ! pressure of env - real(r8), intent(in) :: te(pcols,pver) ! temp of env - real(r8), intent(in) :: qe(pcols,pver) ! spec. humidity of env - real(r8), intent(in) :: eps0(pcols) - real(r8), intent(in) :: gamhat(pcols,pver) ! gamma=L/cp(dq*/dT) at interface - - integer, intent(in) :: jb(pcols) ! updraft base level - integer, intent(in) :: jt(pcols) ! updraft plume top - integer, intent(in) :: jlcl(pcols) ! updraft lifting cond level - integer, intent(in) :: msg ! missing moisture vals - integer, intent(in) :: il2g ! number of columns in gathered arrays - - type(zm_aero_t), intent(in) :: aero ! aerosol object - - real(r8) grav ! gravity - real(r8) cp ! heat capacity of dry air - real(r8) rd ! gas constant for dry air - -! output variables - real(r8), intent(out) :: qc(pcols,pver) ! cloud water mixing ratio (kg/kg) - real(r8), intent(out) :: qi(pcols,pver) ! cloud ice mixing ratio (kg/kg) - real(r8), intent(out) :: nc(pcols,pver) ! cloud water number conc (1/kg) - real(r8), intent(out) :: ni(pcols,pver) ! cloud ice number conc (1/kg) - real(r8), intent(out) :: qcde(pcols,pver) ! cloud water mixing ratio for detrainment(kg/kg) - real(r8), intent(out) :: qide(pcols,pver) ! cloud ice mixing ratio for detrainment (kg/kg) - real(r8), intent(out) :: ncde(pcols,pver) ! cloud water number conc for detrainment (1/kg) - real(r8), intent(out) :: nide(pcols,pver) ! cloud ice number conc for detrainment (1/kg) - real(r8), intent(out) :: wu(pcols,pver) - real(r8), intent(out) :: qni(pcols,pver) ! snow mixing ratio - real(r8), intent(out) :: qr(pcols,pver) ! rain mixing ratio - real(r8), intent(out) :: ns(pcols,pver) ! snow number conc - real(r8), intent(out) :: nr(pcols,pver) ! rain number conc - real(r8), intent(out) :: rprd(pcols,pver) ! rate of production of precip at that layer - real(r8), intent(out) :: sprd(pcols,pver) ! rate of production of snow at that layer - real(r8), intent(out) :: frz(pcols,pver) ! rate of freezing - - - real(r8), intent(inout) :: lamc(pcols,pver) ! slope of cloud liquid size distr - real(r8), intent(inout) :: pgam(pcols,pver) ! spectral width parameter of droplet size distr - -! tendency for output - real(r8),intent(out) :: autolm(pcols,pver) !mass tendency due to autoconversion of droplets to rain - real(r8),intent(out) :: accrlm(pcols,pver) !mass tendency due to accretion of droplets by rain - real(r8),intent(out) :: bergnm(pcols,pver) !mass tendency due to Bergeron process - real(r8),intent(out) :: fhtimm(pcols,pver) !mass tendency due to immersion freezing - real(r8),intent(out) :: fhtctm(pcols,pver) !mass tendency due to contact freezing - real(r8),intent(out) :: fhmlm (pcols,pver) !mass tendency due to homogeneous freezing - real(r8),intent(out) :: hmpim (pcols,pver) !mass tendency due to HM process - real(r8),intent(out) :: accslm(pcols,pver) !mass tendency due to accretion of droplets by snow - real(r8),intent(out) :: dlfm (pcols,pver) !mass tendency due to detrainment of droplet - real(r8),intent(out) :: trspcm(pcols,pver) !mass tendency of droplets due to convective transport - - real(r8),intent(out) :: autoln(pcols,pver) !num tendency due to autoconversion of droplets to rain - real(r8),intent(out) :: accrln(pcols,pver) !num tendency due to accretion of droplets by rain - real(r8),intent(out) :: bergnn(pcols,pver) !num tendency due to Bergeron process - real(r8),intent(out) :: fhtimn(pcols,pver) !num tendency due to immersion freezing - real(r8),intent(out) :: fhtctn(pcols,pver) !num tendency due to contact freezing - real(r8),intent(out) :: fhmln (pcols,pver) !num tendency due to homogeneous freezing - real(r8),intent(out) :: accsln(pcols,pver) !num tendency due to accretion of droplets by snow - real(r8),intent(out) :: activn(pcols,pver) !num tendency due to droplets activation - real(r8),intent(out) :: dlfn (pcols,pver) !num tendency due to detrainment of droplet - real(r8),intent(out) :: trspcn(pcols,pver) !num tendency of droplets due to convective transport - - real(r8),intent(out) :: autoim(pcols,pver) !mass tendency due to autoconversion of cloud ice to snow - real(r8),intent(out) :: accsim(pcols,pver) !mass tendency due to accretion of cloud ice by snow - real(r8),intent(out) :: difm (pcols,pver) !mass tendency due to detrainment of cloud ice - real(r8),intent(out) :: trspim(pcols,pver) !mass tendency of ice crystal due to convective transport - - real(r8),intent(out) :: nuclin(pcols,pver) !num tendency due to ice nucleation - real(r8),intent(out) :: autoin(pcols,pver) !num tendency due to autoconversion of cloud ice to snow - real(r8),intent(out) :: accsin(pcols,pver) !num tendency due to accretion of cloud ice by snow - real(r8),intent(out) :: hmpin (pcols,pver) !num tendency due to HM process - real(r8),intent(out) :: difn (pcols,pver) !num tendency due to detrainment of cloud ice - real(r8),intent(out) :: trspin(pcols,pver) !num tendency of ice crystal due to convective transport - -!................................................................................ -! local workspace -! all units mks unless otherwise stated - real(r8) :: deltat ! time step (s) - real(r8) :: omsm ! number near unity for round-off issues - real(r8) :: dum ! temporary dummy variable - real(r8) :: dum1 ! temporary dummy variable - real(r8) :: dum2 ! temporary dummy variable - - real(r8) :: q(pcols,pver) ! water vapor mixing ratio (kg/kg) - real(r8) :: t(pcols,pver) ! temperature (K) - real(r8) :: rho(pcols,pver) ! air density (kg m-3) - real(r8) :: dz(pcols,pver) ! height difference across model vertical level - - real(r8) :: qcic(pcols,pver) ! in-cloud cloud liquid mixing ratio - real(r8) :: qiic(pcols,pver) ! in-cloud cloud ice mixing ratio - real(r8) :: qniic(pcols,pver) ! in-precip snow mixing ratio - real(r8) :: qric(pcols,pver) ! in-precip rain mixing ratio - real(r8) :: ncic(pcols,pver) ! in-cloud droplet number conc - real(r8) :: niic(pcols,pver) ! in-cloud cloud ice number conc - real(r8) :: nsic(pcols,pver) ! in-precip snow number conc - real(r8) :: nric(pcols,pver) ! in-precip rain number conc - - real(r8) :: lami(pver) ! slope of cloud ice size distr - real(r8) :: n0i(pver) ! intercept of cloud ice size distr - real(r8) :: n0c(pver) ! intercept of cloud liquid size distr - real(r8) :: lams(pver) ! slope of snow size distr - real(r8) :: n0s(pver) ! intercept of snow size distr - real(r8) :: lamr(pver) ! slope of rain size distr - real(r8) :: n0r(pver) ! intercept of rain size distr - real(r8) :: cdist1(pver) ! size distr parameter to calculate droplet freezing - real(r8) :: lammax ! maximum allowed slope of size distr - real(r8) :: lammin ! minimum allowed slope of size distr - - real(r8) :: mnuccc(pver) ! mixing ratio tendency due to freezing of cloud water - real(r8) :: nnuccc(pver) ! number conc tendency due to freezing of cloud water - real(r8) :: mnucct(pver) ! mixing ratio tendency due to contact freezing of cloud water - real(r8) :: nnucct(pver) ! number conc tendency due to contact freezing of cloud water - real(r8) :: msacwi(pver) ! mixing ratio tendency due to HM ice multiplication - real(r8) :: nsacwi(pver) ! number conc tendency due to HM ice multiplication - real(r8) :: prf(pver) ! mixing ratio tendency due to fallout of rain - real(r8) :: psf(pver) ! mixing ratio tendency due to fallout of snow - real(r8) :: pnrf(pver) ! number conc tendency due to fallout of rain - real(r8) :: pnsf(pver) ! number conc tendency due to fallout of snow - real(r8) :: prc(pver) ! mixing ratio tendency due to autoconversion of cloud droplets - real(r8) :: nprc(pver) ! number conc tendency due to autoconversion of cloud droplets - real(r8) :: nprc1(pver) ! qr tendency due to autoconversion of cloud droplets - real(r8) :: nsagg(pver) ! ns tendency due to self-aggregation of snow - real(r8) :: dc0 ! mean size droplet size distr - real(r8) :: ds0 ! mean size snow size distr (area weighted) - real(r8) :: eci ! collection efficiency for riming of snow by droplets - real(r8) :: dv(pcols,pver) ! diffusivity of water vapor in air - real(r8) :: mua(pcols,pver) ! viscocity of air - real(r8) :: psacws(pver) ! mixing rat tendency due to collection of droplets by snow - real(r8) :: npsacws(pver) ! number conc tendency due to collection of droplets by snow - real(r8) :: pracs(pver) ! mixing rat tendency due to collection of rain by snow - real(r8) :: npracs(pver) ! number conc tendency due to collection of rain by snow - real(r8) :: mnuccr(pver) ! mixing rat tendency due to freezing of rain - real(r8) :: nnuccr(pver) ! number conc tendency due to freezing of rain - real(r8) :: pra(pver) ! mixing rat tendnency due to accretion of droplets by rain - real(r8) :: npra(pver) ! nc tendnency due to accretion of droplets by rain - real(r8) :: nragg(pver) ! nr tendency due to self-collection of rain - real(r8) :: prci(pver) ! mixing rat tendency due to autoconversion of cloud ice to snow - real(r8) :: nprci(pver) ! number conc tendency due to autoconversion of cloud ice to snow - real(r8) :: prai(pver) ! mixing rat tendency due to accretion of cloud ice by snow - real(r8) :: nprai(pver) ! number conc tendency due to accretion of cloud ice by snow - real(r8) :: prb(pver) ! rain mixing rat tendency due to Bergeron process - real(r8) :: nprb(pver) ! number conc tendency due to Bergeron process - real(r8) :: fhmrm (pcols,pver) !mass tendency due to homogeneous freezing of rain - -! fall speed - real(r8) :: arn(pcols,pver) ! air density corrected rain fallspeed parameter - real(r8) :: asn(pcols,pver) ! air density corrected snow fallspeed parameter - real(r8) :: acn(pcols,pver) ! air density corrected cloud droplet fallspeed parameter - real(r8) :: ain(pcols,pver) ! air density corrected cloud ice fallspeed parameter - real(r8) :: uns(pver) ! number-weighted snow fallspeed - real(r8) :: ums(pver) ! mass-weighted snow fallspeed - real(r8) :: unr(pver) ! number-weighted rain fallspeed - real(r8) :: umr(pver) ! mass-weighted rain fallspeed - -! conservation check - real(r8) :: qce ! dummy qc for conservation check - real(r8) :: qie ! dummy qi for conservation check - real(r8) :: nce ! dummy nc for conservation check - real(r8) :: nie ! dummy ni for conservation check - real(r8) :: qre ! dummy qr for conservation check - real(r8) :: nre ! dummy nr for conservation check - real(r8) :: qnie ! dummy qni for conservation check - real(r8) :: nse ! dummy ns for conservation check - real(r8) :: ratio ! parameter for conservation check - -! sum of source/sink terms for cloud hydrometeor - real(r8) :: qctend(pcols,pver) ! microphysical tendency qc (1/s) - real(r8) :: qitend(pcols,pver) ! microphysical tendency qi (1/s) - real(r8) :: nctend(pcols,pver) ! microphysical tendency nc (1/(kg*s)) - real(r8) :: nitend(pcols,pver) ! microphysical tendency ni (1/(kg*s)) - real(r8) :: qnitend(pcols,pver) ! snow mixing ratio source/sink term - real(r8) :: nstend(pcols,pver) ! snow number concentration source/sink term - real(r8) :: qrtend(pcols,pver) ! rain mixing ratio source/sink term - real(r8) :: nrtend(pcols,pver) ! rain number concentration source/sink term - -! terms for Bergeron process - real(r8) :: bergtsf !bergeron timescale to remove all liquid - real(r8) :: plevap ! cloud liquid water evaporation rate - -! variables for droplet activation by modal aerosols - real(r8) :: wmix, wmin, wmax, wdiab - real(r8) :: vol, nlsrc - real(r8), allocatable :: vaerosol(:), hygro(:), naermod(:) - real(r8), allocatable :: fn(:) ! number fraction of aerosols activated - real(r8), allocatable :: fm(:) ! mass fraction of aerosols activated - real(r8), allocatable :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8), allocatable :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) - real(r8) :: dmc - real(r8) :: ssmc - real(r8) :: dgnum_aitken - -! bulk aerosol variables - real(r8), allocatable :: naer2(:,:,:) ! new aerosol number concentration (/m3) - real(r8), allocatable :: naer2h(:,:,:) ! new aerosol number concentration (/m3) - real(r8), allocatable :: maerosol(:) ! aerosol mass conc (kg/m3) - real(r8) :: so4_num - real(r8) :: soot_num - real(r8) :: dst1_num - real(r8) :: dst2_num - real(r8) :: dst3_num - real(r8) :: dst4_num - real(r8) :: dst_num - -! droplet activation - logical :: in_cloud ! true when above cloud base layer (k > jb) - real(r8) :: smax_f ! droplet and rain size distr factor used in the - ! in-cloud smax calculation - real(r8) :: dum2l(pcols,pver) ! number conc of CCN (1/kg) - real(r8) :: npccn(pver) ! droplet activation rate - real(r8) :: ncmax - real(r8) :: mtimec ! factor to account for droplet activation timescale - -! ice nucleation - real(r8) :: dum2i(pcols,pver) ! number conc of ice nuclei available (1/kg) - real(r8) :: qs(pcols,pver) ! liquid-ice weighted sat mixing rat (kg/kg) - real(r8) :: es(pcols,pver) ! sat vapor press (pa) over water - real(r8) :: relhum(pcols,pver) ! relative humidity - real(r8) :: esi(pcols,pver) ! sat vapor press (pa) over ice - real(r8) :: nnuccd(pver) ! ice nucleation rate from deposition/cond.-freezing - real(r8) :: mnuccd(pver) ! mass tendency from ice nucleation - real(r8) :: mtime ! factor to account for ice nucleation timescale - -! output for ice nucleation - real(r8) :: nimey(pcols,pver) !number conc of ice nuclei due to meyers deposition (1/m3) - real(r8) :: nihf(pcols,pver) !number conc of ice nuclei due to heterogenous freezing (1/m3) - real(r8) :: nidep(pcols,pver) !number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3) - real(r8) :: niimm(pcols,pver) !number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3) - - real(r8) :: wpice, weff, fhom ! unused dummies - -! loop array variables - integer i,k, n, l - integer ii,kk, m - -! loop variables for iteration solution - integer iter,it,ltrue(pcols) - -! used in contact freezing via dust particles - real(r8) tcnt, viscosity, mfp - real(r8) slip1, slip2, slip3, slip4 - real(r8) dfaer1, dfaer2, dfaer3, dfaer4 - real(r8) nacon1,nacon2,nacon3,nacon4 - -! used in immersion freezing via soot - real(r8) ttend(pver) - real(r8) naimm - real(r8) :: ntaer(pcols,pver) - real(r8) :: ntaerh(pcols,pver) - -! used in homogeneous freezing - real(r8) :: fholm (pcols,pver) !mass tendency due to homogeneous freezing - real(r8) :: fholn (pcols,pver) !number conc tendency due to homogeneous freezing - -! used in secondary ice production - real(r8) ni_secp - -! used in vertical velocity calculation - real(r8) th(pcols,pver) - real(r8) qh(pcols,pver) - real(r8) zkine(pcols,pver) - real(r8) zbuo(pcols,pver) - real(r8) zfacbuo, cwdrag, cwifrac, retv, zbuoc - real(r8) zbc, zbe, zdkbuo, zdken - real(r8) arcf(pcols,pver) - real(r8) p(pcols,pver) - real(r8) ph(pcols,pver) - -! used in vertical integreation - logical qcimp(pver) ! true to solve qc with implicit formula - logical ncimp(pver) ! true to solve nc with implicit formula - logical qiimp(pver) ! true to solve qi with implicit formula - logical niimp(pver) ! true to solve ni with implicit formula - -! tendency due to adjustment - real(r8) :: ncadj(pcols,pver) !droplet num tendency due to adjustment - real(r8) :: niadj(pcols,pver) !ice crystal num tendency due to adjustment - real(r8) :: ncorg, niorg, total - - real(r8) :: rhoh(pcols,pver) ! air density (kg m-3) at interface - real(r8) :: rhom(pcols,pver) ! air density (kg m-3) at mid-level - real(r8) :: tu(pcols,pver) ! temperature in updraft (K) - - integer kqi(pcols),kqc(pcols) - logical lcbase(pcols), libase(pcols) - - real(r8) :: nai_bcphi, nai_dst1, nai_dst2, nai_dst3, nai_dst4 - - real(r8) flxrm, mvtrm, flxrn, mvtrn, flxsm, mvtsm, flxsn, mvtsn - integer nlr, nls - - real(r8) rmean, beta6, beta66, r6, r6c - real(r8) temp1, temp2, temp3, temp4 ! variable to store output which is not required by this routine - -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc -! initialization -!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - if (aero%scheme == 'modal') then - - allocate(vaerosol(aero%nmodes), hygro(aero%nmodes), naermod(aero%nmodes), & - fn(aero%nmodes), fm(aero%nmodes), fluxn(aero%nmodes), fluxm(aero%nmodes)) - - else if (aero%scheme == 'bulk') then - - allocate( & - naer2(pcols,pver,aero%nbulk), & - naer2h(pcols,pver,aero%nbulk), & - maerosol(aero%nbulk)) - - end if - - deltat= get_step_size() !for FV dynamical core - - ! parameters for scheme - omsm=0.99999_r8 - zfacbuo = 0.5_r8/(1._r8+0.5_r8) - cwdrag = 1.875_r8*0.506_r8 - cwifrac = 0.5_r8 - retv = 0.608_r8 - bergtsf = 1800._r8 - - ! initialize multi-level fields - do i=1,il2g - do k=1,pver - q(i,k) = qu(i,k) - tu(i,k)= su(i,k) - grav/cp*zf(i,k) - t(i,k) = su(i,k) - grav/cp*zf(i,k) - p(i,k) = 100._r8*pm(i,k) - wu(i,k) = 0._r8 - zkine(i,k)= 0._r8 - arcf(i,k) = 0._r8 - zbuo(i,k) = 0._r8 - nc(i,k) = 0._r8 - ni(i,k) = 0._r8 - qc(i,k) = 0._r8 - qi(i,k) = 0._r8 - ncde(i,k) = 0._r8 - nide(i,k) = 0._r8 - qcde(i,k) = 0._r8 - qide(i,k) = 0._r8 - rprd(i,k) = 0._r8 - sprd(i,k) = 0._r8 - frz(i,k) = 0._r8 - qcic(i,k) = 0._r8 - qiic(i,k) = 0._r8 - ncic(i,k) = 0._r8 - niic(i,k) = 0._r8 - qr(i,k) = 0._r8 - qni(i,k) = 0._r8 - nr(i,k) = 0._r8 - ns(i,k) = 0._r8 - qric(i,k) = 0._r8 - qniic(i,k) = 0._r8 - nric(i,k) = 0._r8 - nsic(i,k) = 0._r8 - nimey(i,k) = 0._r8 - nihf(i,k) = 0._r8 - nidep(i,k) = 0._r8 - niimm(i,k) = 0._r8 - fhmrm(i,k) = 0._r8 - - autolm(i,k) = 0._r8 - accrlm(i,k) = 0._r8 - bergnm(i,k) = 0._r8 - fhtimm(i,k) = 0._r8 - fhtctm(i,k) = 0._r8 - fhmlm (i,k) = 0._r8 - fholm (i,k) = 0._r8 - hmpim (i,k) = 0._r8 - accslm(i,k) = 0._r8 - dlfm (i,k) = 0._r8 - - autoln(i,k) = 0._r8 - accrln(i,k) = 0._r8 - bergnn(i,k) = 0._r8 - fhtimn(i,k) = 0._r8 - fhtctn(i,k) = 0._r8 - fhmln (i,k) = 0._r8 - fholn (i,k) = 0._r8 - accsln(i,k) = 0._r8 - activn(i,k) = 0._r8 - dlfn (i,k) = 0._r8 - - autoim(i,k) = 0._r8 - accsim(i,k) = 0._r8 - difm (i,k) = 0._r8 - - nuclin(i,k) = 0._r8 - autoin(i,k) = 0._r8 - accsin(i,k) = 0._r8 - hmpin (i,k) = 0._r8 - difn (i,k) = 0._r8 - - trspcm(i,k) = 0._r8 - trspcn(i,k) = 0._r8 - trspim(i,k) = 0._r8 - trspin(i,k) = 0._r8 - - ncadj (i,k) = 0._r8 - niadj (i,k) = 0._r8 - end do - end do - - ! initialize time-varying parameters - do k=1,pver - do i=1,il2g - if (k .eq.1) then - rhoh(i,k) = p(i,k)/(t(i,k)*rd) - rhom(i,k) = p(i,k)/(t(i,k)*rd) - th (i,k) = te(i,k) - qh (i,k) = qe(i,k) - dz (i,k) = zf(i,k) - zf(i,k+1) - ph(i,k) = p(i,k) - else - rhoh(i,k) = 0.5_r8*(p(i,k)+p(i,k-1))/(t(i,k)*rd) - if (k .eq. pver) then - rhom(i,k) = p(i,k)/(rd*t(i,k)) - else - rhom(i,k) = 2.0_r8*p(i,k)/(rd*(t(i,k)+t(i,k+1))) - end if - th (i,k) = 0.5_r8*(te(i,k)+te(i,k-1)) - qh (i,k) = 0.5_r8*(qe(i,k)+qe(i,k-1)) - dz(i,k) = zf(i,k-1) - zf(i,k) - ph(i,k) = 0.5_r8*(p(i,k) + p(i,k-1)) - end if - dv(i,k) = 8.794E-5_r8*t(i,k)**1.81_r8/ph(i,k) - mua(i,k) = 1.496E-6_r8*t(i,k)**1.5_r8/ & - (t(i,k)+120._r8) - - rho(i,k) = rhoh(i,k) - - ! air density adjustment for fallspeed parameters - ! add air density correction factor to the power of - ! 0.54 following Heymsfield and Bansemer 2006 - - arn(i,k)=ar*(rhosu/rho(i,k))**0.54_r8 - asn(i,k)=as*(rhosu/rho(i,k))**0.54_r8 - acn(i,k)=ac*(rhosu/rho(i,k))**0.54_r8 - ain(i,k)=ai*(rhosu/rho(i,k))**0.54_r8 - - end do - end do - - if (aero%scheme == 'modal') then - - wmix = 0._r8 - wmin = 0._r8 - wmax = 10._r8 - wdiab = 0._r8 - - do k=1,pver - do i=1,il2g - dum2l(i,k)=0._r8 - dum2i(i,k)=0._r8 - ntaer(i,k) = 0.0_r8 - ntaerh(i,k) = 0.0_r8 - do m = 1, aero%nmodes - ntaer(i,k) = ntaer(i,k) + aero%numg_a(i,k,m)*rhom(i,k) - enddo - end do - end do - - else if (aero%scheme == 'bulk') then - - ! initialize aerosol number - do k=1,pver - do i=1,il2g - naer2(i,k,:)=0._r8 - naer2h(i,k,:)=0._r8 - dum2l(i,k)=0._r8 - dum2i(i,k)=0._r8 - end do - end do - - do k=1,pver - do i=1,il2g - ntaer(i,k) = 0.0_r8 - ntaerh(i,k) = 0.0_r8 - do m = 1, aero%nbulk - maerosol(m) = aero%mmrg_bulk(i,k,m)*rhom(i,k) - - ! set number nucleated for sulfate based on Lohmann et al. 2000 (JGR) Eq.2 - ! Na=340.*(massSO4)^0.58 where Na=cm-3 and massSO4=ug/m3 - ! convert units to Na [m-3] and SO4 [kgm-3] - ! Na(m-3)= 1.e6 cm3 m-3 Na(cm-3)=340. *(massSO4[kg/m3]*1.e9ug/kg)^0.58 - ! or Na(m-3)= 1.e6* 340.*(1.e9ug/kg)^0.58 * (massSO4[kg/m3])^0.58 - - if (m .eq. aero%idxsul) then - naer2(i,k,m)= 5.64259e13_r8 * maerosol(m)**0.58_r8 - else - naer2(i,k,m)=maerosol(m)*aero%num_to_mass_aer(m) - end if - ntaer(i,k) = ntaer(i,k) + naer2(i,k,m) - end do - end do - end do - - end if - - do i=1,il2g - ltrue(i)=0 - do k=1,pver - if (qc(i,k).ge.qsmall.or.qi(i,k).ge.qsmall.or.cmel(i,k).ge.qsmall.or.cmei(i,k).ge.qsmall) ltrue(i)=1 - end do - end do - - ! skip microphysical calculations if no cloud water - do i=1,il2g - if (ltrue(i).eq.0) then - do k=1,pver - qctend(i,k)=0._r8 - qitend(i,k)=0._r8 - qnitend(i,k)=0._r8 - qrtend(i,k)=0._r8 - nctend(i,k)=0._r8 - nitend(i,k)=0._r8 - nrtend(i,k)=0._r8 - nstend(i,k)=0._r8 - qniic(i,k)=0._r8 - qric(i,k)=0._r8 - nsic(i,k)=0._r8 - nric(i,k)=0._r8 - qni(i,k)=0._r8 - qr(i,k)=0._r8 - ns(i,k)=0._r8 - nr(i,k)=0._r8 - qc(i,k) = 0._r8 - qi(i,k) = 0._r8 - nc(i,k) = 0._r8 - ni(i,k) = 0._r8 - qcde(i,k) = 0._r8 - qide(i,k) = 0._r8 - ncde(i,k) = 0._r8 - nide(i,k) = 0._r8 - rprd(i,k) = 0._r8 - sprd(i,k) = 0._r8 - frz(i,k) = 0._r8 - end do - goto 300 - end if - - kqc(i) = 1 - kqi(i) = 1 - lcbase(i) = .true. - libase(i) = .true. - - ! assign number of steps for iteration - ! use 2 steps following Song and Zhang, 2011, J. Clim. - iter = 2 - - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - ! iteration - !cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc - - do it=1,iter - - ! initialize sub-step microphysical tendencies - do k=1,pver - qctend(i,k)=0._r8 - qitend(i,k)=0._r8 - qnitend(i,k)=0._r8 - qrtend(i,k)=0._r8 - nctend(i,k)=0._r8 - nitend(i,k)=0._r8 - nrtend(i,k)=0._r8 - nstend(i,k)=0._r8 - rprd(i,k) = 0._r8 - sprd(i,k) = 0._r8 - frz(i,k) = 0._r8 - qniic(i,k)=0._r8 - qric(i,k)=0._r8 - nsic(i,k)=0._r8 - nric(i,k)=0._r8 - qiic(i,k)=0._r8 - qcic(i,k)=0._r8 - niic(i,k)=0._r8 - ncic(i,k)=0._r8 - qcimp(k) = .false. - ncimp(k) = .false. - qiimp(k) = .false. - niimp(k) = .false. - dum2l(i,k)=0._r8 - dum2i(i,k)=0._r8 - autolm(i,k) = 0._r8 - accrlm(i,k) = 0._r8 - bergnm(i,k) = 0._r8 - fhtimm(i,k) = 0._r8 - fhtctm(i,k) = 0._r8 - fhmlm (i,k) = 0._r8 - fholm (i,k) = 0._r8 - hmpim (i,k) = 0._r8 - accslm(i,k) = 0._r8 - dlfm (i,k) = 0._r8 - - autoln(i,k) = 0._r8 - accrln(i,k) = 0._r8 - bergnn(i,k) = 0._r8 - fhtimn(i,k) = 0._r8 - fhtctn(i,k) = 0._r8 - fhmln (i,k) = 0._r8 - fholn (i,k) = 0._r8 - accsln(i,k) = 0._r8 - activn(i,k) = 0._r8 - dlfn (i,k) = 0._r8 - ncadj (i,k) = 0._r8 - - autoim(i,k) = 0._r8 - accsim(i,k) = 0._r8 - difm (i,k) = 0._r8 - - nuclin(i,k) = 0._r8 - autoin(i,k) = 0._r8 - accsin(i,k) = 0._r8 - hmpin (i,k) = 0._r8 - difn (i,k) = 0._r8 - niadj (i,k) = 0._r8 - - trspcm(i,k) = 0._r8 - trspcn(i,k) = 0._r8 - trspim(i,k) = 0._r8 - trspin(i,k) = 0._r8 - - fhmrm (i,k) = 0._r8 - end do - - do k = pver,msg+2,-1 - - if (k > jt(i) .and. k <= jb(i) .and. eps0(i) > 0._r8 & - .and.mu(i,k).gt.0._r8 .and. mu(i,k-1).gt.0._r8) then - - ! initialize precip fallspeeds to zero - if (it.eq.1) then - ums(k)=0._r8 - uns(k)=0._r8 - umr(k)=0._r8 - unr(k)=0._r8 - prf(k)=0._r8 - pnrf(k)=0._r8 - psf(k) =0._r8 - pnsf(k) = 0._r8 - end if - ttend(k)=0._r8 - nnuccd(k)=0._r8 - npccn(k)=0._r8 - - !************************************************************************************ - ! obtain values of cloud water/ice mixing ratios and number concentrations in updraft - ! for microphysical process calculations - ! units are kg/kg for mixing ratio, 1/kg for number conc - !************************************************************************************ - - - if (it.eq.1) then - qcic(i,k) = qc(i,k) - qiic(i,k) = qi(i,k) - ncic(i,k) = nc(i,k) - niic(i,k) = ni(i,k) - qniic(i,k)= qni(i,k) - qric(i,k) = qr(i,k) - nsic(i,k) = ns(i,k) - nric(i,k) = nr(i,k) - else - if (k.le.kqc(i)) then - qcic(i,k) = qc(i,k) - ncic(i,k) = nc(i,k) - - ! consider rain falling from above - flxrm = 0._r8 - mvtrm = 0._r8 - flxrn = 0._r8 - mvtrn = 0._r8 - nlr = 0 - - do kk= k,jt(i)+3,-1 - if (qr(i,kk-1) .gt. 0._r8) then - nlr = nlr + 1 - flxrm = flxrm + umr(kk-1)*qr(i,kk-1)*arcf(i,kk-1) - flxrn = flxrn + unr(kk-1)*nr(i,kk-1)*arcf(i,kk-1) - mvtrm = mvtrm + umr(kk-1)*arcf(i,kk-1) - mvtrn = mvtrn + unr(kk-1)*arcf(i,kk-1) - end if - end do - if (mvtrm.gt.0) then - qric(i,k) = (qr(i,k)*mu(i,k)+flxrm)/(mu(i,k)+mvtrm) - else - qric(i,k) = qr(i,k) - end if - if (mvtrn.gt.0) then - nric(i,k) = (nr(i,k)*mu(i,k)+flxrn)/(mu(i,k)+mvtrn) - else - nric(i,k) = nr(i,k) - end if - - end if - if (k.eq.kqc(i)) then - qcic(i,k) = qc(i,k-1) - ncic(i,k) = nc(i,k-1) - end if - if(k.le.kqi(i)) then - qiic(i,k) = qi(i,k) - niic(i,k) = ni(i,k) -! consider snow falling from above - flxsm = 0._r8 - mvtsm = 0._r8 - flxsn = 0._r8 - mvtsn = 0._r8 - nls = 0 - - do kk= k,jt(i)+3,-1 - if (qni(i,kk-1) .gt. 0._r8) then - nls = nls + 1 - flxsm = flxsm + ums(kk-1)*qni(i,kk-1)*arcf(i,kk-1) - mvtsm = mvtsm + ums(kk-1)*arcf(i,kk-1) - flxsn = flxsn + uns(kk-1)*ns(i,kk-1)*arcf(i,kk-1) - mvtsn = mvtsn + uns(kk-1)*arcf(i,kk-1) - end if - end do - - if (mvtsm.gt.0) then - qniic(i,k) = (qni(i,k)*mu(i,k)+flxsm)/(mu(i,k)+mvtsm) - else - qniic(i,k) = qni(i,k) - end if - if (mvtsn.gt.0) then - nsic(i,k) = (ns(i,k)*mu(i,k)+flxsn)/(mu(i,k)+mvtsn) - else - nsic(i,k) = ns(i,k) - end if - end if - if(k.eq.kqi(i)) then - qiic(i,k) = qi(i,k-1) - niic(i,k) = ni(i,k-1) - end if - end if - - !********************************************************************** - ! boundary condition for cloud liquid water and cloud ice - !*********************************************************************** - - ! boundary condition for provisional cloud water - if (cmel(i,k-1).gt.qsmall .and. lcbase(i) .and. it.eq.1 ) then - kqc(i) = k - lcbase(i) = .false. - qcic(i,k) = dz(i,k)*cmel(i,k-1)/(mu(i,k-1)+dz(i,k)*du(i,k-1)) - ncic(i,k) = qcic(i,k)/(4._r8/3._r8*pi*10.e-6_r8**3*rhow) - end if - - ! boundary condition for provisional cloud ice - if (qiic(i,k).gt.qsmall .and. libase(i) .and. it.eq.1 ) then - kqi(i) = k - libase(i) = .false. - else if ( cmei(i,k-1).gt.qsmall .and. & - cmei(i,k).lt.qsmall .and. k.le.jb(i) .and. libase(i) .and. it.eq.1 ) then - kqi(i)=k - libase(i) = .false. - qiic(i,k) = dz(i,k)*cmei(i,k-1)/(mu(i,k-1)+dz(i,k)*du(i,k-1)) - niic(i,k) = qiic(i,k)/(4._r8/3._r8*pi*25.e-6_r8**3*rhoi) - end if - - !*************************************************************************** - ! get size distribution parameters based on in-cloud cloud water/ice - ! these calculations also ensure consistency between number and mixing ratio - !*************************************************************************** - ! cloud ice - if (qiic(i,k).ge.qsmall) then - - ! add upper limit to in-cloud number concentration to prevent numerical error - niic(i,k)=min(niic(i,k),qiic(i,k)*1.e20_r8) - lami(k) = (gamma(1._r8+di)*ci* & - niic(i,k)/qiic(i,k))**(1._r8/di) - n0i(k) = niic(i,k)*lami(k) - - ! check for slope - lammax = 1._r8/10.e-6_r8 - lammin = 1._r8/(2._r8*dcs) - - ! adjust vars - if (lami(k).lt.lammin) then - lami(k) = lammin - n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*gamma(1._r8+di)) - niic(i,k) = n0i(k)/lami(k) - else if (lami(k).gt.lammax) then - lami(k) = lammax - n0i(k) = lami(k)**(di+1._r8)*qiic(i,k)/(ci*gamma(1._r8+di)) - niic(i,k) = n0i(k)/lami(k) - end if - else - lami(k) = 0._r8 - n0i(k) = 0._r8 - end if - - ! cloud water - if (qcic(i,k).ge.qsmall) then - - ! add upper limit to in-cloud number concentration to prevent numerical error - ncic(i,k)=min(ncic(i,k),qcic(i,k)*1.e20_r8) - - ! get pgam from fit to observations of martin et al. 1994 - - pgam(i,k)=0.0005714_r8*(ncic(i,k)/1.e6_r8/rho(i,k))+0.2714_r8 - pgam(i,k)=1._r8/(pgam(i,k)**2)-1._r8 - pgam(i,k)=max(pgam(i,k),2._r8) - pgam(i,k)=min(pgam(i,k),15._r8) - - ! calculate lamc - lamc(i,k) = (pi/6._r8*rhow*ncic(i,k)*gamma(pgam(i,k)+4._r8)/ & - (qcic(i,k)*gamma(pgam(i,k)+1._r8)))**(1._r8/3._r8) - - ! lammin, 50 micron diameter max mean size - lammin = (pgam(i,k)+1._r8)/40.e-6_r8 - lammax = (pgam(i,k)+1._r8)/1.e-6_r8 - - if (lamc(i,k).lt.lammin) then - lamc(i,k) = lammin - ncic(i,k) = 6._r8*lamc(i,k)**3*qcic(i,k)* & - gamma(pgam(i,k)+1._r8)/ & - (pi*rhow*gamma(pgam(i,k)+4._r8)) - else if (lamc(i,k).gt.lammax) then - lamc(i,k) = lammax - ncic(i,k) = 6._r8*lamc(i,k)**3*qcic(i,k)* & - gamma(pgam(i,k)+1._r8)/ & - (pi*rhow*gamma(pgam(i,k)+4._r8)) - end if - - ! parameter to calculate droplet freezing - - cdist1(k) = ncic(i,k)/gamma(pgam(i,k)+1._r8) - else - lamc(i,k) = 0._r8 - cdist1(k) = 0._r8 - end if - - ! boundary condition for cloud liquid water - if ( kqc(i) .eq. k ) then - qc(i,k) = 0._r8 - nc(i,k) = 0._r8 - end if - - ! boundary condition for cloud ice - if (kqi(i).eq.k ) then - qi(i,k) = 0._r8 - ni(i,k) = 0._r8 - end if - - !************************************************************************** - ! begin micropysical process calculations - !************************************************************************** - - !................................................................. - ! autoconversion of cloud liquid water to rain - ! formula from Khrouditnov and Kogan (2000) - ! minimum qc of 1 x 10^-8 prevents floating point error - - if (qcic(i,k).ge.1.e-8_r8) then - - ! nprc is increase in rain number conc due to autoconversion - ! nprc1 is decrease in cloud droplet conc due to autoconversion - ! Khrouditnov and Kogan (2000) -! prc(k) = 1350._r8*qcic(i,k)**2.47_r8* & -! (ncic(i,k)/1.e6_r8*rho(i,k))**(-1.79_r8) - - ! Liu and Daum(2004)(modified), Wood(2005) - rmean = 1.e6_r8*((qcic(i,k)/ncic(i,k))/(4._r8/3._r8*pi*rhow))**(1._r8/3._r8) - - if (rmean .ge. 15._r8) then - - beta6 = (1._r8+3._r8/rmean)**(1._r8/3._r8) - beta66 = (1._r8+3._r8/rmean)**2._r8 - r6 = beta6*rmean - r6c = 7.5_r8/(r6**0.5_r8*(qcic(i,k)*rho(i,k))**(1._r8/6._r8)) - prc(k) = 1.3e9_r8*beta66*(qcic(i,k)*rho(i,k))**3._r8/ & - (ncic(i,k)*rho(i,k))*max(0._r8,r6-r6c)/rho(i,k) - - nprc1(k) = prc(k)/(qcic(i,k)/ncic(i,k)) - nprc(k) = nprc1(k)*0.5_r8 - else - prc(k)=0._r8 - nprc(k)=0._r8 - nprc1(k)=0._r8 - end if - else - prc(k)=0._r8 - nprc(k)=0._r8 - nprc1(k)=0._r8 - end if - - ! provisional rain mixing ratio and number concentration (qric and nric) - ! at boundary are estimated via autoconversion - - if (k.eq.kqc(i) .and. it.eq.1) then - qric(i,k) = prc(k)*dz(i,k)/0.55_r8 - nric(i,k) = nprc(k)*dz(i,k)/0.55_r8 - qr(i,k) = 0.0_r8 - nr(i,k) = 0.0_r8 - end if - - !....................................................................... - ! Autoconversion of cloud ice to snow - ! similar to Ferrier (1994) - - call ice_autoconversion(t(i,k), qiic(i,k), lami(k), n0i(k), dcs, prci(k), nprci(k), 1) - - ! provisional snow mixing ratio and number concentration (qniic and nsic) - ! at boundary are estimated via autoconversion - - if (k.eq.kqi(i) .and. it.eq.1) then - qniic(i,k)= prci(k)*dz(i,k)*0.25_r8 - nsic(i,k)= nprci(k)*dz(i,k)*0.25_r8 - qni(i,k)= 0.0_r8 - ns(i,k)= 0.0_r8 - end if - - ! if precip mix ratio is zero so should number concentration - if (qniic(i,k).lt.qsmall) then - qniic(i,k)=0._r8 - nsic(i,k)=0._r8 - end if - if (qric(i,k).lt.qsmall) then - qric(i,k)=0._r8 - nric(i,k)=0._r8 - end if - - ! make sure number concentration is a positive number to avoid - ! taking root of negative later - nric(i,k)=max(nric(i,k),0._r8) - nsic(i,k)=max(nsic(i,k),0._r8) - - !********************************************************************** - ! get size distribution parameters for precip - !********************************************************************** - ! rain - - if (qric(i,k).ge.qsmall) then - lamr(k) = (pi*rhow*nric(i,k)/qric(i,k))**(1._r8/3._r8) - n0r(k) = nric(i,k)*lamr(k) - - ! check for slope - lammax = 1._r8/150.e-6_r8 - lammin = 1._r8/3000.e-6_r8 - - ! adjust vars - if (lamr(k).lt.lammin) then - lamr(k) = lammin - n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) - nric(i,k) = n0r(k)/lamr(k) - else if (lamr(k).gt.lammax) then - lamr(k) = lammax - n0r(k) = lamr(k)**4*qric(i,k)/(pi*rhow) - nric(i,k) = n0r(k)/lamr(k) - end if - - ! provisional rain number and mass weighted mean fallspeed (m/s) - ! Eq.18 of Morrison and Gettelman, 2008, J. Climate - unr(k) = min(arn(i,k)*gamma(1._r8+br)/lamr(k)**br,10._r8) - umr(k) = min(arn(i,k)*gamma(4._r8+br)/(6._r8*lamr(k)**br),10._r8) - else - lamr(k) = 0._r8 - n0r(k) = 0._r8 - umr(k) = 0._r8 - unr(k) = 0._r8 - end if - - !...................................................................... - ! snow - if (qniic(i,k).ge.qsmall) then - lams(k) = (gamma(1._r8+ds)*cs*nsic(i,k)/ & - qniic(i,k))**(1._r8/ds) - n0s(k) = nsic(i,k)*lams(k) - - ! check for slope - lammax = 1._r8/10.e-6_r8 - lammin = 1._r8/2000.e-6_r8 - - ! adjust vars - if (lams(k).lt.lammin) then - lams(k) = lammin - n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*gamma(1._r8+ds)) - nsic(i,k) = n0s(k)/lams(k) - else if (lams(k).gt.lammax) then - lams(k) = lammax - n0s(k) = lams(k)**(ds+1._r8)*qniic(i,k)/(cs*gamma(1._r8+ds)) - nsic(i,k) = n0s(k)/lams(k) - end if - - ! provisional snow number and mass weighted mean fallspeed (m/s) - ums(k) = min(asn(i,k)*gamma(4._r8+bs)/(6._r8*lams(k)**bs),3.6_r8) - uns(k) = min(asn(i,k)*gamma(1._r8+bs)/lams(k)**bs,3.6_r8) - else - lams(k) = 0._r8 - n0s(k) = 0._r8 - ums(k) = 0._r8 - uns(k) = 0._r8 - end if - - !....................................................................... - ! snow self-aggregation from passarelli, 1978, used by Reisner(1998,Eq.A.35) - ! this is hard-wired for bs = 0.4 for now - ! ignore self-collection of cloud ice - - call snow_self_aggregation(t(i,k), rho(i,k), asn(i,k), rhosn, qniic(i,k), nsic(i,k), nsagg(k), 1) - - !....................................................................... - ! accretion of cloud droplets onto snow/graupel - ! here use continuous collection equation with - ! simple gravitational collection kernel - ! ignore collisions between droplets/cloud ice - - ! ignore collision of snow with droplets above freezing - - call accrete_cloud_water_snow(t(i,k), rho(i,k), asn(i,k), uns(k), mua(i,k), & - qcic(i,k), ncic(i,k), qniic(i,k), pgam(i,k), lamc(i,k), lams(k), n0s(k), & - psacws(k), npsacws(k), 1) - - ! secondary ice production due to accretion of droplets by snow - ! (Hallet-Mossop process) (from Cotton et al., 1986) - - call secondary_ice_production(t(i,k), psacws(k), msacwi(k), nsacwi(k), 1) - - !....................................................................... - ! accretion of rain water by snow - ! formula from ikawa and saito, 1991, used by reisner et al., 1998 - - call accrete_rain_snow(t(i,k), rho(i,k), umr(k), ums(k), unr(k), uns(k), qric(i,k), & - qniic(i,k), lamr(k), n0r(k), lams(k), n0s(k), pracs(k), npracs(k), 1 ) - - !....................................................................... - ! heterogeneous freezing of rain drops - ! follows from Bigg (1953) - - call heterogeneous_rain_freezing(t(i,k), qric(i,k), nric(i,k), lamr(k), mnuccr(k), nnuccr(k), 1) - - !....................................................................... - ! accretion of cloud liquid water by rain - ! formula from Khrouditnov and Kogan (2000) - ! gravitational collection kernel, droplet fall speed neglected - - call accrete_cloud_water_rain(.true., qric(i,k), qcic(i,k), ncic(i,k), [1._r8], [0._r8], pra(k), npra(k), 1) - - !....................................................................... - ! Self-collection of rain drops - ! from Beheng(1994) - - call self_collection_rain(rho(i,k), qric(i,k), nric(i,k), nragg(k), 1) - - !....................................................................... - ! Accretion of cloud ice by snow - ! For this calculation, it is assumed that the Vs >> Vi - ! and Ds >> Di for continuous collection - - call accrete_cloud_ice_snow(t(i,k), rho(i,k), asn(i,k), qiic(i,k), niic(i,k), & - qniic(i,k), lams(k), n0s(k), prai(k), nprai(k), 1) - - !....................................................................... - ! fallout term - prf(k) = -umr(k)*qric(i,k)/dz(i,k) - pnrf(k) = -unr(k)*nric(i,k)/dz(i,k) - psf(k) = -ums(k)*qniic(i,k)/dz(i,k) - pnsf(k) = -uns(k)*nsic(i,k)/dz(i,k) - - !........................................................................ - ! calculate vertical velocity in cumulus updraft - - if (k.eq.jb(i)) then - zkine(i,jb(i)) = 0.5_r8 - wu (i,jb(i)) = 1._r8 - zbuo (i,jb(i)) = (tu(i,jb(i))*(1._r8+retv*qu(i,jb(i)))- & - th(i,jb(i))*(1._r8+retv*qh(i,jb(i))))/ & - (th(i,jb(i))*(1._r8+retv*qh(i,jb(i)))) - else - if (.true.) then - ! ECMWF formula - zbc = tu(i,k)*(1._r8+retv*qu(i,k)-qr(i,k)-qni(i,k)-qi(i,k)-qc(i,k)) - zbe = th(i,k)*(1._r8+retv*qh(i,k)) - zbuo(i,k) = (zbc-zbe)/zbe - zbuoc= (zbuo(i,k)+zbuo(i,k+1))*0.5_r8 - zdkbuo = dz(i,k+1)*grav*zfacbuo*zbuoc - zdken = min(.99_r8,(1._r8+cwdrag)*max(du(i,k),eu(i,k))*dz(i,k+1)/ & - max(1.e-10_r8,mu(i,k+1))) - zkine(i,k) = (zkine(i,k+1)*(1._r8-zdken)+zdkbuo)/ & - (1._r8+zdken) - else - ! Gregory formula - zbc = tu(i,k)*(1._r8+retv*qu(i,k)) - zbe = th(i,k)*(1._r8+retv*qh(i,k)) - zbuo(i,k) = (zbc-zbe)/zbe-qr(i,k)-qni(i,k)-qi(i,k)-qc(i,k) - zbuoc= (zbuo(i,k)+zbuo(i,k+1))*0.5_r8 - zdkbuo = dz(i,k+1)*grav*zbuoc*(1.0_r8-0.25_r8)/6._r8 - zdken = du(i,k)*dz(i,k+1)/max(1.e-10_r8,mu(i,k+1)) - zkine(i,k) = (zkine(i,k+1)*(1._r8-zdken)+zdkbuo)/ & - (1._r8+zdken) - end if - wu(i,k) = min(15._r8,sqrt(2._r8*max(0.1_r8,zkine(i,k) ))) - end if - - arcf(i,k)= mu(i,k)/wu(i,k) - - !............................................................................ - ! droplet activation - ! calculate potential for droplet activation if cloud water is present - ! formulation from Abdul-Razzak and Ghan (2000) and Abdul-Razzak et al. (1998), AR98 - - if (aero%scheme == 'bulk') then - naer2h(i,k,:) = 0.5_r8*(naer2(i,k,:) + naer2(i,k-1,:)) - end if - - ntaerh(i,k) = 0.5_r8*(ntaer(i,k) + ntaer(i,k-1)) - - if (qcic(i,k).ge.qsmall ) then - - if (aero%scheme == 'modal') then - - nlsrc = 0._r8 - - do m = 1, aero%nmodes - vaerosol(m) = 0._r8 - hygro(m) = 0._r8 - do l = 1, aero%nspec(m) - vol = max(0.5_r8*(aero%mmrg_a(i,k,l,m)+aero%mmrg_a(i,k-1,l,m)) , 0._r8)/aero%specdens(l,m) - vaerosol(m) = vaerosol(m) + vol - hygro(m) = hygro(m) + vol*aero%spechygro(l,m) - end do - if (vaerosol(m) > 1.0e-30_r8) then - hygro(m) = hygro(m)/(vaerosol(m)) - vaerosol(m) = vaerosol(m)*rho(i,k) - else - hygro(m) = 0.0_r8 - vaerosol(m) = 0.0_r8 - endif - naermod(m) = 0.5_r8*(aero%numg_a(i,k,m)+aero%numg_a(i,k-1,m))*rho(i,k) - naermod(m) = max(naermod(m), vaerosol(m)*aero%voltonumbhi(m)) - naermod(m) = min(naermod(m), vaerosol(m)*aero%voltonumblo(m)) - end do - - in_cloud = (k < jb(i)) - smax_f = 0.0_r8 - if (in_cloud) then - if ( qcic(i,k).ge.qsmall ) & - smax_f = ncic(i,k)/lamc(i,k) * gamma(2.0_r8 + pgam(i,k))/gamma(1.0_r8 + pgam(i,k)) - if ( qric(i,k).ge.qsmall) smax_f = smax_f + nric(i,k)/lamr(k) - - end if - -! call activate_modal( & -! wu(i,k), wmix, wdiab, wmin, wmax, & -! t(i,k), rho(i,k), naermod, aero%nmodes, vaerosol, & -! hygro, fn, fm, & -! fluxn, fluxm, flux_fullact, in_cloud_in=in_cloud, smax_f=smax_f) - - do m = 1, aero%nmodes - nlsrc = nlsrc + fn(m)*naermod(m) ! number nucleated - end do - - if (nlsrc .ne. nlsrc) then - write(iulog,*) "nlsrc=",nlsrc,"wu(i,k)=",wu(i,k) - write(iulog,*) "fn(m)=",fn,"naermod(m)=",naermod,"aero%specdens(l,m)=",aero%specdens - write(iulog,*) "vaerosol(m)=",vaerosol,"aero%voltonumbhi(m)=",aero%voltonumbhi - write(iulog,*) "aero%voltonumblo(m)=",aero%voltonumblo,"k=",k,"i=",i - write(iulog,*) "aero%numg_a(i,k,m)=",aero%numg_a(i,k,:),"rho(i,k)=",rho(i,k) - write(iulog,*) "aero%mmrg_a(i,k,l,m)=",aero%mmrg_a(i,k,:,:) - end if - - dum2l(i,k) = nlsrc - - else if (aero%scheme == 'bulk') then - - call ndrop_bam_run( & - wu(i,k), t(i,k), rho(i,k), naer2h(i,k,:), aero%nbulk, & - aero%nbulk, maerosol, dum2) - - dum2l(i,k) = dum2 - - end if - - else - dum2l(i,k) = 0._r8 - end if - - ! get droplet activation rate - if (qcic(i,k).ge.qsmall .and. t(i,k).gt.238.15_r8 .and. k.gt.jt(i)+2 ) then - - ! assume aerosols already activated are equal number of existing droplets for simplicity - if (k.eq.kqc(i)) then - npccn(k) = dum2l(i,k)/deltat - else - npccn(k) = (dum2l(i,k)-ncic(i,k))/deltat - end if - - ! make sure number activated > 0 - npccn(k) = max(0._r8,npccn(k)) - ncmax = dum2l(i,k) - else - npccn(k)=0._r8 - ncmax = 0._r8 - end if - - !.............................................................................. - !ice nucleation - es(i,k) = svp_water(t(i,k)) ! over water in mixed clouds - esi(i,k) = svp_ice(t(i,k)) ! over ice - qs(i,k) = 0.622_r8*es(i,k)/(ph(i,k) - (1.0_r8-0.622_r8)*es(i,k)) - qs(i,k) = min(1.0_r8,qs(i,k)) - if (qs(i,k) < 0.0_r8) qs(i,k) = 1.0_r8 - - relhum(i,k)= 1.0_r8 - - if (t(i,k).lt.tmelt ) then - - ! compute aerosol number for so4, soot, and dust with units #/cm^3 - so4_num = 0._r8 - soot_num = 0._r8 - dst1_num = 0._r8 - dst2_num = 0._r8 - dst3_num = 0._r8 - dst4_num = 0._r8 - - if (aero%scheme == 'modal') then - - !For modal aerosols, assume for the upper troposphere: - ! soot = accumulation mode - ! sulfate = aiken mode - ! dust = coarse mode - ! since modal has internal mixtures. - soot_num = 0.5_r8*(aero%numg_a(i,k-1,aero%mode_accum_idx) & - +aero%numg_a(i,k,aero%mode_accum_idx))*rho(i,k)*1.0e-6_r8 - dmc = 0.5_r8*(aero%mmrg_a(i,k-1,aero%coarse_dust_idx,aero%mode_coarse_idx) & - +aero%mmrg_a(i,k,aero%coarse_dust_idx,aero%mode_coarse_idx)) - ssmc = 0.5_r8*(aero%mmrg_a(i,k-1,aero%coarse_nacl_idx,aero%mode_coarse_idx) & - +aero%mmrg_a(i,k,aero%coarse_nacl_idx,aero%mode_coarse_idx)) - if (dmc > 0._r8) then - dst_num = dmc/(ssmc + dmc) *(aero%numg_a(i,k-1,aero%mode_coarse_idx) & - + aero%numg_a(i,k,aero%mode_coarse_idx))*0.5_r8*rho(i,k)*1.0e-6_r8 - else - dst_num = 0.0_r8 - end if - dgnum_aitken = 0.5_r8*(aero%dgnumg(i,k,aero%mode_aitken_idx)+ & - aero%dgnumg(i,k-1,aero%mode_aitken_idx)) - if (dgnum_aitken > 0._r8) then - ! only allow so4 with D>0.1 um in ice nucleation - so4_num = 0.5_r8*(aero%numg_a(i,k-1,aero%mode_aitken_idx)+ & - aero%numg_a(i,k,aero%mode_aitken_idx))*rho(i,k)*1.0e-6_r8 & - * (0.5_r8 - 0.5_r8*erf(log(0.1e-6_r8/dgnum_aitken)/ & - (2._r8**0.5_r8*log(aero%sigmag_aitken)))) - else - so4_num = 0.0_r8 - end if - so4_num = max(0.0_r8, so4_num) - - else if (aero%scheme == 'bulk') then - - if (aero%idxsul > 0) then - so4_num = naer2h(i,k,aero%idxsul)/25._r8 *1.0e-6_r8 - end if - if (aero%idxbcphi > 0) then - soot_num = naer2h(i,k,aero%idxbcphi)/25._r8 *1.0e-6_r8 - end if - if (aero%idxdst1 > 0) then - dst1_num = naer2h(i,k,aero%idxdst1)/25._r8 *1.0e-6_r8 - end if - if (aero%idxdst2 > 0) then - dst2_num = naer2h(i,k,aero%idxdst2)/25._r8 *1.0e-6_r8 - end if - if (aero%idxdst3 > 0) then - dst3_num = naer2h(i,k,aero%idxdst3)/25._r8 *1.0e-6_r8 - end if - if (aero%idxdst4 > 0) then - dst4_num = naer2h(i,k,aero%idxdst4)/25._r8 *1.0e-6_r8 - end if - dst_num = dst1_num + dst2_num + dst3_num + dst4_num - - end if - - ! *** Turn off soot nucleation *** - soot_num = 0.0_r8 - - ! Liu et al.,J. climate, 2007 - if ( wu(i,k) .lt. 4.0_r8) then - call nucleati( & - wu(i,k), t(i,k), ph(i,k), relhum(i,k), 1.0_r8, qcic(i,k), & - 1.0e-20_r8, 0.0_r8, rho(i,k), so4_num, dst_num, soot_num, 1.0_r8, & - dum2i(i,k), nihf(i,k), niimm(i,k), nidep(i,k), nimey(i,k), & - wpice, weff, fhom, temp1, temp2, temp3, temp4, .true. ) - end if - nihf(i,k)=nihf(i,k)*rho(i,k) ! convert from #/kg -> #/m3) - niimm(i,k)=niimm(i,k)*rho(i,k) - nidep(i,k)=nidep(i,k)*rho(i,k) - nimey(i,k)=nimey(i,k)*rho(i,k) - - if (.false.) then - ! cooper curve (factor of 1000 is to convert from L-1 to m-3) - !dum2i(i,k)=0.005_r8*exp(0.304_r8*(273.15_r8-t(i,k)))*1000._r8 - - ! put limit on number of nucleated crystals, set to number at T=-30 C - ! cooper (limit to value at -35 C) - !dum2i(i,k)=min(dum2i(i,k),208.9e3_r8)/rho(i,k) ! convert from m-3 to kg-1 - end if - - else - dum2i(i,k)=0._r8 - end if - - ! ice nucleation if activated nuclei exist at t<0C - - if (dum2i(i,k).gt.0._r8.and.t(i,k).lt.tmelt.and. & - relhum(i,k)*es(i,k)/esi(i,k).gt. 1.05_r8 .and. k.gt.jt(i)+1) then - - if (k.eq.kqi(i)) then - nnuccd(k)=dum2i(i,k)/deltat - else - nnuccd(k)=(dum2i(i,k)-niic(i,k))/deltat - end if - nnuccd(k)=max(nnuccd(k),0._r8) - - !Calc mass of new particles using new crystal mass... - !also this will be multiplied by mtime as nnuccd is... - - mnuccd(k) = nnuccd(k) * mi0 - else - nnuccd(k)=0._r8 - mnuccd(k) = 0._r8 - end if - - !................................................................................ - ! Bergeron process - ! If 0C< T <-40C and both ice and liquid exist - - if (t(i,k).le.273.15_r8 .and. t(i,k).gt.233.15_r8 .and. & - qiic(i,k).gt.0.5e-6_r8 .and. qcic(i,k).gt. qsmall) then - plevap = qcic(i,k)/bergtsf - prb(k) = max(0._r8,plevap) - nprb(k) = prb(k)/(qcic(i,k)/ncic(i,k)) - else - prb(k)=0._r8 - nprb(k)=0._r8 - end if - - !................................................................................ - ! heterogeneous freezing of cloud water (-5C < T < -35C) - - if (qcic(i,k).ge.qsmall .and.ncic(i,k).gt.0._r8 .and. ntaerh(i,k).gt.0._r8 .and. & - t(i,k).le.268.15_r8 .and. t(i,k).gt.238.15_r8 ) then - - if (aero%scheme == 'bulk') then - ! immersion freezing (Diehl and Wurzler, 2004) - ttend(k) = -grav*wu(i,k)/cp/(1.0_r8+gamhat(i,k)) - - nai_bcphi = 0.0_r8 - nai_dst1 = 0.0_r8 - nai_dst2 = 0.0_r8 - nai_dst3 = 0.0_r8 - nai_dst4 = 0.0_r8 - - if (aero%idxbcphi > 0) nai_bcphi = naer2h(i,k,aero%idxbcphi) - if (aero%idxdst1 > 0) nai_dst1 = naer2h(i,k,aero%idxdst1) - if (aero%idxdst2 > 0) nai_dst2 = naer2h(i,k,aero%idxdst2) - if (aero%idxdst3 > 0) nai_dst3 = naer2h(i,k,aero%idxdst3) - if (aero%idxdst4 > 0) nai_dst4 = naer2h(i,k,aero%idxdst4) - - naimm = (0.00291_r8*nai_bcphi + 32.3_r8*(nai_dst1 + nai_dst2 + & - nai_dst3 + nai_dst4))/ntaerh(i,k) !m-3 - if (ttend(k) .lt. 0._r8) then - nnuccc(k) = -naimm*exp(273.15_r8-t(i,k))*ttend(k)*qcic(i,k)/rhow ! kg-1s-1 - mnuccc(k) = nnuccc(k)*qcic(i,k)/ncic(i,k) - end if - else - if (.false.) then - ! immersion freezing (Diehl and Wurzler, 2004) - ttend(k) = -grav*wu(i,k)/cp/(1.0_r8+gamhat(i,k)) - naimm = (0.00291_r8*soot_num + 32.3_r8*dst_num )*1.0e6_r8/ntaerh(i,k) !m-3 - if (ttend(k) .lt. 0._r8) then - nnuccc(k) = -naimm*exp(273.15_r8-t(i,k))*ttend(k)*qcic(i,k)/rhow ! kg-1s-1 - mnuccc(k) = nnuccc(k)*qcic(i,k)/ncic(i,k) - end if - else - ! immersion freezing (Bigg, 1953) - mnuccc(k) = pi*pi/36._r8*rhow* & - cdist1(k)*gamma(7._r8+pgam(i,k))* & - bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/ & - lamc(i,k)**3/lamc(i,k)**3 - - nnuccc(k) = pi/6._r8*cdist1(k)*gamma(pgam(i,k)+4._r8) & - *bimm*(exp(aimm*(273.15_r8-t(i,k)))-1._r8)/lamc(i,k)**3 - end if - end if - - ! contact freezing (Young, 1974) with hooks into simulated dust - - tcnt=(270.16_r8-t(i,k))**1.3_r8 - viscosity=1.8e-5_r8*(t(i,k)/298.0_r8)**0.85_r8 ! Viscosity (kg/m/s) - mfp=2.0_r8*viscosity/(ph(i,k) & ! Mean free path (m) - *sqrt(8.0_r8*28.96e-3_r8/(pi*8.314409_r8*t(i,k)))) - - slip1=1.0_r8+(mfp/rn_dst1)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst1/mfp))))! Slip correction factor - slip2=1.0_r8+(mfp/rn_dst2)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst2/mfp)))) - slip3=1.0_r8+(mfp/rn_dst3)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst3/mfp)))) - slip4=1.0_r8+(mfp/rn_dst4)*(1.257_r8+(0.4_r8*Exp(-(1.1_r8*rn_dst4/mfp)))) - - dfaer1=1.381e-23_r8*t(i,k)*slip1/(6._r8*pi*viscosity*rn_dst1) ! aerosol diffusivity (m2/s) - dfaer2=1.381e-23_r8*t(i,k)*slip2/(6._r8*pi*viscosity*rn_dst2) - dfaer3=1.381e-23_r8*t(i,k)*slip3/(6._r8*pi*viscosity*rn_dst3) - dfaer4=1.381e-23_r8*t(i,k)*slip4/(6._r8*pi*viscosity*rn_dst4) - - nacon1=0.0_r8 - nacon2=0.0_r8 - nacon3=0.0_r8 - nacon4=0.0_r8 - - if (aero%scheme == 'modal') then - - ! For modal aerosols: - ! use size '3' for dust coarse mode... - ! scale by dust fraction in coarse mode - - dmc = 0.5_r8*(aero%mmrg_a(i,k,aero%coarse_dust_idx,aero%mode_coarse_idx) & - +aero%mmrg_a(i,k-1,aero%coarse_dust_idx,aero%mode_coarse_idx)) - ssmc = 0.5_r8*(aero%mmrg_a(i,k,aero%coarse_nacl_idx,aero%mode_coarse_idx) & - +aero%mmrg_a(i,k-1,aero%coarse_nacl_idx,aero%mode_coarse_idx)) - if (dmc > 0.0_r8) then - nacon3 = dmc/(ssmc + dmc) * (aero%numg_a(i,k,aero%mode_coarse_idx) & - + aero%numg_a(i,k-1,aero%mode_coarse_idx))*0.5_r8*rho(i,k) - end if - - else if (aero%scheme == 'bulk') then - - if (aero%idxdst1.gt.0) then - nacon1=naer2h(i,k,aero%idxdst1)*tcnt *0.0_r8 - endif - if (aero%idxdst2.gt.0) then - nacon2=naer2h(i,k,aero%idxdst2)*tcnt ! 1/m3 - endif - if (aero%idxdst3.gt.0) then - nacon3=naer2h(i,k,aero%idxdst3)*tcnt - endif - if (aero%idxdst4.gt.0) then - nacon4=naer2h(i,k,aero%idxdst4)*tcnt - endif - end if - - mnucct(k) = (dfaer1*nacon1+dfaer2*nacon2+dfaer3*nacon3+dfaer4*nacon4)*pi*pi/3._r8*rhow* & - cdist1(k)*gamma(pgam(i,k)+5._r8)/lamc(i,k)**4 - - nnucct(k) = (dfaer1*nacon1+dfaer2*nacon2+dfaer3*nacon3+dfaer4*nacon4)*2._r8*pi* & - cdist1(k)*gamma(pgam(i,k)+2._r8)/lamc(i,k) - - ! if (nnuccc(k).gt.nnuccd(k)) then - ! dum=nnuccd(k)/nnuccc(k) - ! scale mixing ratio of droplet freezing with limit - ! mnuccc(k)=mnuccc(k)*dum - ! nnuccc(k)=nnuccd(k) - ! end if - - else - mnuccc(k) = 0._r8 - nnuccc(k) = 0._r8 - mnucct(k) = 0._r8 - nnucct(k) = 0._r8 - end if - - ! freeze cloud liquid water homogeneously at -40 C - if (t(i,k) < 233.15_r8 .and. qc(i,k) > 0._r8) then - - ! make sure freezing rain doesn't increase temperature above - ! threshold - dum = xlf/cp*qc(i,k) - if (t(i,k)+dum.gt.233.15_r8) then - dum = -(t(i,k)-233.15_r8)*cp/xlf - dum = dum/qc(i,k) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - else - dum = 1._r8 - end if - fholm(i,k) = mu(i,k)*dum*qc(i,k) - fholn(i,k) = mu(i,k)*dum*nc(i,k) - end if - - - !**************************************************************************************** - ! conservation to ensure no negative values of cloud water/precipitation - ! in case microphysical process rates are large - ! note: for check on conservation, processes are multiplied by omsm - ! to prevent problems due to round off error - - ! since activation/nucleation processes are fast, need to take into account - ! factor mtime = mixing timescale in cloud / model time step - ! for now mixing timescale is assumed to be 15 min - !***************************************************************************************** - - mtime=deltat/900._r8 - mtimec=deltat/900._r8 - - ! conservation of qc - ! ice mass production from ice nucleation(deposition/cond.-freezing), mnuccd, - ! is considered as a part of cmei. - - qce = mu(i,k)*qc(i,k)-fholm(i,k) +dz(i,k)*cmel(i,k-1) - dum = arcf(i,k)*(pra(k)+prc(k)+prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)+ & - psacws(k))*dz(i,k) - if( qce.lt.0._r8) then - qcimp(k) = .true. - prc(k) = 0._r8 - pra(k) = 0._r8 - prb(k) = 0._r8 - mnuccc(k) = 0._r8 - mnucct(k) = 0._r8 - msacwi(k) = 0._r8 - psacws(k) = 0._r8 - else if (dum.gt.qce) then - ratio = qce/dum*omsm - prc(k) = prc(k)*ratio - pra(k) = pra(k)*ratio - prb(k) = prb(k)*ratio - mnuccc(k) = mnuccc(k)*ratio - mnucct(k) = mnucct(k)*ratio - msacwi(k) = msacwi(k)*ratio - psacws(k) = psacws(k)*ratio - end if - - ! conservation of nc - nce = mu(i,k)*nc(i,k)-fholn(i,k) + (arcf(i,k)*npccn(k)*mtimec)*dz(i,k) - dum = arcf(i,k)*dz(i,k)*(nprc1(k)+npra(k)+nnuccc(k)+nnucct(k)+ & - npsacws(k)+ nprb(k) ) - if (nce.lt.0._r8) then - ncimp(k) = .true. - nprc1(k) = 0._r8 - npra(k) = 0._r8 - nnuccc(k) = 0._r8 - nnucct(k) = 0._r8 - npsacws(k) = 0._r8 - nprb(k) = 0._r8 - else if (dum.gt.nce) then - ratio = nce/dum*omsm - nprc1(k) = nprc1(k)*ratio - npra(k) = npra(k)*ratio - nnuccc(k) = nnuccc(k)*ratio - nnucct(k) = nnucct(k)*ratio - npsacws(k) = npsacws(k)*ratio - nprb(k) = nprb(k)*ratio - end if - - ! conservation of qi - qie = mu(i,k)*qi(i,k)+fholm(i,k) +dz(i,k)*(cmei(i,k-1) + & - ( mnuccc(k)+mnucct(k)+msacwi(k)+prb(k))*arcf(i,k) ) - dum = arcf(i,k)*(prci(k)+ prai(k))*dz(i,k) - if (qie.lt.0._r8) then - qiimp(k) = .true. - prci(k) = 0._r8 - prai(k) = 0._r8 - else if (dum.gt.qie) then - ratio = qie/dum*omsm - prci(k) = prci(k)*ratio - prai(k) = prai(k)*ratio - end if - - ! conservation of ni - nie = mu(i,k)*ni(i,k)+fholn(i,k) +dz(i,k)*(nnuccd(k)*mtime*arcf(i,k) & - +(nnuccc(k)+ nnucct(k))*arcf(i,k) ) - dum = arcf(i,k)*dz(i,k)*(-nsacwi(k)+nprci(k)+ nprai(k)) - if( nie.lt.0._r8) then - niimp(k) = .true. - nsacwi(k)= 0._r8 - nprci(k) = 0._r8 - nprai(k) = 0._r8 - else if (dum.gt.nie) then - ratio = nie/dum*omsm - nsacwi(k)= nsacwi(k)*ratio - nprci(k) = nprci(k)*ratio - nprai(k) = nprai(k)*ratio - end if - - ! conservation of qr - - qre = mu(i,k)*qr(i,k)+dz(i,k)*(pra(k)+prc(k))*arcf(i,k) - dum = arcf(i,k)*dz(i,k)*(pracs(k)+ mnuccr(k)-prf(k)) - if (qre.lt.0._r8) then - prf(k) = 0._r8 - pracs(k) = 0._r8 - mnuccr(k) = 0._r8 - else if (dum.gt.qre) then - ratio = qre/dum*omsm - prf(k) = prf(k)*ratio - pracs(k) = pracs(k)*ratio - mnuccr(k) = mnuccr(k)*ratio - end if - - ! conservation of nr - nre = mu(i,k)*nr(i,k) + nprc(k)*arcf(i,k)*dz(i,k) - dum = arcf(i,k)*dz(i,k)*(npracs(k)+nnuccr(k) & - -nragg(k)-pnrf(k)) - if(nre.lt.0._r8) then - npracs(k)= 0._r8 - nnuccr(k)= 0._r8 - nragg(k) = 0._r8 - pnrf(k) = 0._r8 - else if (dum.gt.nre) then - ratio = nre/dum*omsm - npracs(k)= npracs(k)*ratio - nnuccr(k)= nnuccr(k)*ratio - nragg(k) = nragg(k)*ratio - pnrf(k) = pnrf(k)*ratio - end if - - ! conservation of qni - - qnie = mu(i,k)*qni(i,k)+dz(i,k)*( (prai(k)+psacws(k)+prci(k)+ & - pracs(k)+mnuccr(k))*arcf(i,k) ) - dum = arcf(i,k)*dz(i,k)*(-psf(k)) - - if(qnie.lt.0._r8) then - psf(k) = 0._r8 - else if (dum.gt.qnie) then - ratio = qnie/dum*omsm - psf(k) = psf(k)*ratio - end if - - ! conservation of ns - nse = mu(i,k)*ns(i,k)+dz(i,k)*(nprci(k)+nnuccr(k))*arcf(i,k) - dum = arcf(i,k)*dz(i,k)*(-nsagg(k)-pnsf(k)) - if (nse.lt.0._r8) then - nsagg(k) = 0._r8 - pnsf(k) = 0._r8 - else if (dum.gt.nse) then - ratio = nse/dum*omsm - nsagg(k) = nsagg(k)*ratio - pnsf(k) = pnsf(k)*ratio - end if - - !***************************************************************************** - ! get tendencies due to microphysical conversion processes - !***************************************************************************** - - if (k.le.kqc(i)) then - qctend(i,k) = (-pra(k)-prc(k)-prb(k)-mnuccc(k)-mnucct(k)-msacwi(k)- & - psacws(k)) - - qitend(i,k) = (prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)-prci(k)- prai(k)) - - qrtend(i,k) = (pra(k)+prc(k))+(-pracs(k)- mnuccr(k)) - - qnitend(i,k) = (prai(k)+psacws(k)+prci(k))+(pracs(k)+mnuccr(k)) - - ! multiply activation/nucleation by mtime to account for fast timescale - - nctend(i,k) = npccn(k)*mtimec+(-nnuccc(k)-nnucct(k)-npsacws(k) & - -npra(k)-nprc1(k)-nprb(k)) - - nitend(i,k) = nnuccd(k)*mtime+(nnuccc(k)+ nnucct(k)+nsacwi(k)-nprci(k)- & - nprai(k)) - - nstend(i,k) = nsagg(k)+nnuccr(k) + nprci(k) - - nrtend(i,k) = nprc(k)+(-npracs(k)-nnuccr(k) +nragg(k)) - - ! for output - ! cloud liquid water------------- - - autolm(i,k-1) = -prc(k)*arcf(i,k) - accrlm(i,k-1) = -pra(k)*arcf(i,k) - bergnm(i,k-1) = -prb(k)*arcf(i,k) - fhtimm(i,k-1) = -mnuccc(k)*arcf(i,k) - fhtctm(i,k-1) = -mnucct(k)*arcf(i,k) - hmpim (i,k-1) = -msacwi(k)*arcf(i,k) - accslm(i,k-1) = -psacws(k)*arcf(i,k) - fhmlm(i,k-1) = -fholm(i,k)/dz(i,k) - - autoln(i,k-1) = -nprc1(k)*arcf(i,k) - accrln(i,k-1) = -npra(k)*arcf(i,k) - bergnn(i,k-1) = -nprb(k)*arcf(i,k) - fhtimn(i,k-1) = -nnuccc(k)*arcf(i,k) - fhtctn(i,k-1) = -nnucct(k)*arcf(i,k) - accsln(i,k-1) = -npsacws(k)*arcf(i,k) - activn(i,k-1) = npccn(k)*mtimec*arcf(i,k) - fhmln(i,k-1) = -fholn(i,k)/dz(i,k) - - !cloud ice------------------------ - - autoim(i,k-1) = -prci(k)*arcf(i,k) - accsim(i,k-1) = -prai(k)*arcf(i,k) - - nuclin(i,k-1) = nnuccd(k)*mtime*arcf(i,k) - autoin(i,k-1) = -nprci(k)*arcf(i,k) - accsin(i,k-1) = -nprai(k)*arcf(i,k) - hmpin (i,k-1) = nsacwi(k)*arcf(i,k) - - else - qctend(i,k) = 0._r8 - qitend(i,k) = 0._r8 - qrtend(i,k) = 0._r8 - qnitend(i,k) = 0._r8 - nctend(i,k) = 0._r8 - nitend(i,k) = 0._r8 - nstend(i,k) = 0._r8 - nrtend(i,k) = 0._r8 - end if - - !******************************************************************************** - ! vertical integration - !******************************************************************************** - ! snow - if ( k.le.kqi(i) ) then - qni(i,k-1) = 1._r8/mu(i,k-1)* & - (mu(i,k)*qni(i,k)+dz(i,k)*(qnitend(i,k)+psf(k))*arcf(i,k) ) - - ns(i,k-1) = 1._r8/mu(i,k-1)* & - (mu(i,k)*ns(i,k)+dz(i,k)*(nstend(i,k)+pnsf(k))*arcf(i,k) ) - - else - qni(i,k-1)=0._r8 - ns(i,k-1)=0._r8 - end if - - if (qni(i,k-1).le.0._r8) then - qni(i,k-1)=0._r8 - ns(i,k-1)=0._r8 - end if - - ! rain - if (k.le.kqc(i) ) then - qr(i,k-1) = 1._r8/mu(i,k-1)* & - (mu(i,k)*qr(i,k)+dz(i,k)*(qrtend(i,k)+prf(k))*arcf(i,k) ) - - nr(i,k-1) = 1._r8/mu(i,k-1)* & - (mu(i,k)*nr(i,k)+dz(i,k)*(nrtend(i,k)+pnrf(k))*arcf(i,k) ) - - else - qr(i,k-1)=0._r8 - nr(i,k-1)=0._r8 - end if - - if( qr(i,k-1) .le. 0._r8) then - qr(i,k-1)=0._r8 - nr(i,k-1)=0._r8 - end if - - ! freeze rain homogeneously at -40 C - - if (t(i,k-1) < 233.15_r8 .and. qr(i,k-1) > 0._r8) then - - ! make sure freezing rain doesn't increase temperature above threshold - dum = xlf/cp*qr(i,k-1) - if (t(i,k-1)+dum.gt.233.15_r8) then - dum = -(t(i,k-1)-233.15_r8)*cp/xlf - dum = dum/qr(i,k-1) - dum = max(0._r8,dum) - dum = min(1._r8,dum) - else - dum = 1._r8 - end if - qni(i,k-1)=qni(i,k-1)+dum*qr(i,k-1) - ns(i,k-1)=ns(i,k-1)+dum*nr(i,k-1) - qr(i,k-1)=(1._r8-dum)*qr(i,k-1) - nr(i,k-1)=(1._r8-dum)*nr(i,k-1) - fhmrm(i,k-1) = -mu(i,k-1)*dum*qr(i,k-1)/dz(i,k) - end if - - - ! cloud water - if ( k.le.kqc(i) ) then - qc(i,k-1) = (mu(i,k)*qc(i,k)-fholm(i,k)+dz(i,k)*qctend(i,k)*arcf(i,k) & - +dz(i,k)*cmel(i,k-1) )/(mu(i,k-1)+dz(i,k)*du(i,k-1)) - - qcde(i,k) = qc(i,k-1) - - nc(i,k-1) = (mu(i,k)*nc(i,k) -fholn(i,k) +dz(i,k)*nctend(i,k)*arcf(i,k) ) & - /(mu(i,k-1)+dz(i,k)*du(i,k-1)) - - ncde(i,k) = nc(i,k-1) - else - qc(i,k-1)=0._r8 - nc(i,k-1)=0._r8 - end if - - if (qc(i,k-1).lt.0._r8) write(iulog,*) "negative qc(i,k-1)=",qc(i,k-1) - dlfm(i,k-1) = -du(i,k-1)*qcde(i,k) - dlfn(i,k-1) = -du(i,k-1)*ncde(i,k) - - if (qc(i,k-1).le. 0._r8) then - qc(i,k-1)=0._r8 - nc(i,k-1)=0._r8 - end if - - if (nc(i,k-1).lt. 0._r8) then - write(iulog,*) "nc(i,k-1)=",nc(i,k-1),"k-1=",k-1,"arcf(i,k)=",arcf(i,k) - write(iulog,*) "mu(i,k-1)=",mu(i,k-1),"mu(i,k)=",mu(i,k),"nc(i,k)=",ni(i,k) - write(iulog,*) "dz(i,k)=",dz(i,k),"du(i,k-1)=",du(i,k-1),"nctend(i,k)=",nctend(i,k) - write(iulog,*) "eu(i,k-1)=",eu(i,k-1) - end if - - ! cloud ice - if( k.le.kqi(i)) then - qi(i,k-1) = (mu(i,k)*qi(i,k)+fholm(i,k) +dz(i,k)*qitend(i,k)*arcf(i,k) & - +dz(i,k)*cmei(i,k-1) )/(mu(i,k-1)+dz(i,k)*du(i,k-1)) - - qide(i,k) = qi(i,k-1) - - ni(i,k-1) = (mu(i,k)*ni(i,k)+fholn(i,k)+dz(i,k)*nitend(i,k)*arcf(i,k) ) & - /(mu(i,k-1)+dz(i,k)*du(i,k-1)) - - nide(i,k) = ni(i,k-1) - else - qi(i,k-1)=0._r8 - ni(i,k-1)=0._r8 - end if - - if (qi(i,k-1).lt.0._r8) write(iulog,*) "negative qi(i,k-1)=",qi(i,k-1) - difm(i,k-1) = -du(i,k-1)*qide(i,k) - difn(i,k-1) = -du(i,k-1)*nide(i,k) - - if (qi(i,k-1).le. 0._r8) then - qi(i,k-1)=0._r8 - ni(i,k-1)=0._r8 - end if - - - if (ni(i,k-1).lt. 0._r8) then - write(iulog,*) "ni(i,k-1)=",ni(i,k-1),"k-1=",k-1,"arcf(i,k)=",arcf(i,k) - write(iulog,*) "mu(i,k-1)=",mu(i,k-1),"mu(i,k)=",mu(i,k),"ni(i,k)=",ni(i,k) - write(iulog,*) "dz(i,k)=",dz(i,k),"du(i,k-1)=",du(i,k-1),"nitend(i,k)=",nitend(i,k) - write(iulog,*) "eu(i,k-1)=",eu(i,k-1) - end if - - - frz(i,k-1) = cmei(i,k-1) + arcf(i,k)*(prb(k)+mnuccc(k)+mnucct(k)+msacwi(k)+ & - pracs(k)+mnuccr(k)+psacws(k) )-fhmlm(i,k-1)-fhmrm(i,k-1) - - - !****************************************************************************** - ! get size distribution parameters based on in-cloud cloud water/ice - ! these calculations also ensure consistency between number and mixing ratio - - ! following equation(2,3,4) of Morrison and Gettelman, 2008, J. Climate. - ! Gamma(n)= (n-1)! - ! lamc <-> lambda for cloud liquid water - ! pgam <-> meu for cloud liquid water - ! meu=0 for ice,rain and snow - !******************************************************************************* - - ! cloud ice - niorg = ni(i,k-1) - if (qi(i,k-1).ge.qsmall) then - - ! add upper limit to in-cloud number concentration to prevent numerical error - ni(i,k-1)=min(ni(i,k-1),qi(i,k-1)*1.e20_r8) - ! ni should be non-negative - ! ni(i,k-1) = max(ni(i,k-1), 0._r8) - if (ni(i,k-1).lt. 0._r8) write(iulog,*) "ni(i,k-1)=",ni(i,k-1) - - lami(k-1) = (gamma(1._r8+di)*ci* & - ni(i,k-1)/qi(i,k-1))**(1._r8/di) - n0i(k-1) = ni(i,k-1)*lami(k-1) - - ! check for slope - lammax = 1._r8/10.e-6_r8 - lammin = 1._r8/(2._r8*dcs) - - ! adjust vars - if (lami(k-1).lt.lammin) then - lami(k-1) = lammin - n0i(k-1) = lami(k-1)**(di+1._r8)*qi(i,k-1)/(ci*gamma(1._r8+di)) - ni(i,k-1) = n0i(k-1)/lami(k-1) - else if (lami(k-1).gt.lammax) then - lami(k-1) = lammax - n0i(k-1) = lami(k-1)**(di+1._r8)*qi(i,k-1)/(ci*gamma(1._r8+di)) - ni(i,k-1) = n0i(k-1)/lami(k-1) - end if - else - lami(k-1) = 0._r8 - n0i(k-1) = 0._r8 - end if - - nide(i,k) = ni(i,k-1) - difn(i,k-1) = -du(i,k-1)*nide(i,k) - - niadj(i,k-1)= (ni(i,k-1)- niorg)*mu(i,k-1)/dz(i,k) - - if (niadj(i,k-1) .lt. 0._r8) then - total = nuclin(i,k-1)-fhtimn(i,k-1)-fhtctn(i,k-1)-fhmln(i,k-1)+ hmpin (i,k-1) - if (total .ne. 0._r8) then - nuclin(i,k-1) = nuclin(i,k-1) + nuclin(i,k-1)*niadj(i,k-1)/total - fhtimn(i,k-1) = fhtimn(i,k-1) + fhtimn(i,k-1)*niadj(i,k-1)/total - fhtctn(i,k-1) = fhtctn(i,k-1) + fhtctn(i,k-1)*niadj(i,k-1)/total - fhmln (i,k-1) = fhmln (i,k-1) + fhmln (i,k-1)*niadj(i,k-1)/total - hmpin (i,k-1) = hmpin (i,k-1) + hmpin (i,k-1)*niadj(i,k-1)/total - else - total = 5._r8 - nuclin(i,k-1) = nuclin(i,k-1) + niadj(i,k-1)/total - fhtimn(i,k-1) = fhtimn(i,k-1) + niadj(i,k-1)/total - fhtctn(i,k-1) = fhtctn(i,k-1) + niadj(i,k-1)/total - fhmln (i,k-1) = fhmln (i,k-1) + niadj(i,k-1)/total - hmpin (i,k-1) = hmpin (i,k-1) + niadj(i,k-1)/total - end if - else if (niadj(i,k-1) .gt. 0._r8) then - total = autoin(i,k-1)+accsin(i,k-1) - if (total .ne. 0._r8) then - autoin(i,k-1) = autoin(i,k-1) + autoin(i,k-1)*niadj(i,k-1)/total - accsin(i,k-1) = accsin(i,k-1) + accsin(i,k-1)*niadj(i,k-1)/total - else - total = 2._r8 - autoin(i,k-1) = autoin(i,k-1) + niadj(i,k-1)/total - accsin(i,k-1) = accsin(i,k-1) + niadj(i,k-1)/total - end if - end if - - !................................................................................ - !cloud water - ncorg = nc(i,k-1) - if (qc(i,k-1).ge.qsmall) then - - ! add upper limit to in-cloud number concentration to prevent numerical error - nc(i,k-1)=min(nc(i,k-1),qc(i,k-1)*1.e20_r8) - ! and make sure it's non-negative - ! nc(i,k-1) = max(nc(i,k-1), 0._r8) - if (nc(i,k-1).lt. 0._r8) write(iulog,*) "nc(i,k-1)=",nc(i,k-1) - - ! get pgam from fit to observations of martin et al. 1994 - - pgam(i,k-1)=0.0005714_r8*(nc(i,k-1)/1.e6_r8/rho(i,k-1))+0.2714_r8 - pgam(i,k-1)=1._r8/(pgam(i,k-1)**2)-1._r8 - pgam(i,k-1)=max(pgam(i,k-1),2._r8) - pgam(i,k-1)=min(pgam(i,k-1),15._r8) - ! calculate lamc - - lamc(i,k-1) = (pi/6._r8*rhow*nc(i,k-1)*gamma(pgam(i,k-1)+4._r8)/ & - (qc(i,k-1)*gamma(pgam(i,k-1)+1._r8)))**(1._r8/3._r8) - - ! lammin, 50 micron diameter max mean size - lammin = (pgam(i,k-1)+1._r8)/40.e-6_r8 - lammax = (pgam(i,k-1)+1._r8)/1.e-6_r8 - - if (lamc(i,k-1).lt.lammin) then - lamc(i,k-1) = lammin - nc(i,k-1) = 6._r8*lamc(i,k-1)**3*qc(i,k-1)* & - gamma(pgam(i,k-1)+1._r8)/ & - (pi*rhow*gamma(pgam(i,k-1)+4._r8)) - else if (lamc(i,k-1).gt.lammax) then - lamc(i,k-1) = lammax - nc(i,k-1) = 6._r8*lamc(i,k-1)**3*qc(i,k-1)* & - gamma(pgam(i,k-1)+1._r8)/ & - (pi*rhow*gamma(pgam(i,k-1)+4._r8)) - end if - - ! parameter to calculate droplet freezing - - cdist1(k-1) = nc(i,k-1)/gamma(pgam(i,k-1)+1._r8) - else - lamc(i,k-1) = 0._r8 - cdist1(k-1) = 0._r8 - end if - - ncde(i,k) = nc(i,k-1) - dlfn(i,k-1) = -du(i,k-1)*ncde(i,k) - - ncadj(i,k-1) = (nc(i,k-1)- ncorg)*mu(i,k-1)/dz(i,k) - if (ncadj(i,k-1) .lt. 0._r8) then - activn(i,k-1) = activn(i,k-1) + ncadj(i,k-1) - else if (ncadj(i,k-1) .gt. 0._r8) then - total = autoln(i,k-1)+accrln(i,k-1)+bergnn(i,k-1)+accsln(i,k-1) - if (total .ne. 0._r8) then - autoln(i,k-1) = autoln(i,k-1) + autoln(i,k-1)*ncadj(i,k-1)/total - accrln(i,k-1) = accrln(i,k-1) + accrln(i,k-1)*ncadj(i,k-1)/total - bergnn(i,k-1) = bergnn(i,k-1) + bergnn(i,k-1)*ncadj(i,k-1)/total - accsln(i,k-1) = accsln(i,k-1) + accsln(i,k-1)*ncadj(i,k-1)/total - else - total = 4._r8 - autoln(i,k-1) = autoln(i,k-1) + ncadj(i,k-1)/total - accrln(i,k-1) = accrln(i,k-1) + ncadj(i,k-1)/total - bergnn(i,k-1) = bergnn(i,k-1) + ncadj(i,k-1)/total - accsln(i,k-1) = accsln(i,k-1) + ncadj(i,k-1)/total - end if - end if - - trspcm(i,k-1) = (mu(i,k)*qc(i,k) - mu(i,k-1)*qc(i,k-1))/dz(i,k) - trspcn(i,k-1) = (mu(i,k)*nc(i,k) - mu(i,k-1)*nc(i,k-1))/dz(i,k) - trspim(i,k-1) = (mu(i,k)*qi(i,k) - mu(i,k-1)*qi(i,k-1))/dz(i,k) - trspin(i,k-1) = (mu(i,k)*ni(i,k) - mu(i,k-1)*ni(i,k-1))/dz(i,k) - - if (k-1 .eq. jt(i)+1) then - trspcm(i,k-2) = mu(i,k-1)*qc(i,k-1)/dz(i,k-1) - trspcn(i,k-2) = mu(i,k-1)*nc(i,k-1)/dz(i,k-1) - trspim(i,k-2) = mu(i,k-1)*qi(i,k-1)/dz(i,k-1) - trspin(i,k-2) = mu(i,k-1)*ni(i,k-1)/dz(i,k-1) - qcde(i,k-1) = qc(i,k-1) - ncde(i,k-1) = nc(i,k-1) - qide(i,k-1) = qi(i,k-1) - nide(i,k-1) = ni(i,k-1) - dlfm (i,k-2) = -du(i,k-2)*qcde(i,k-1) - dlfn (i,k-2) = -du(i,k-2)*ncde(i,k-1) - difm (i,k-2) = -du(i,k-2)*qide(i,k-1) - difn (i,k-2) = -du(i,k-2)*nide(i,k-1) - end if - - - !....................................................................... - ! get size distribution parameters for precip - !...................................................................... - ! rain - if (qr(i,k-1).ge.qsmall) then - - lamr(k-1) = (pi*rhow*nr(i,k-1)/qr(i,k-1))**(1._r8/3._r8) - n0r(k-1) = nr(i,k-1)*lamr(k-1) - - ! check for slope - lammax = 1._r8/150.e-6_r8 - lammin = 1._r8/3000.e-6_r8 - ! adjust vars - if (lamr(k-1).lt.lammin) then - lamr(k-1) = lammin - n0r(k-1) = lamr(k-1)**4*qr(i,k-1)/(pi*rhow) - nr(i,k-1) = n0r(k-1)/lamr(k-1) - else if (lamr(k-1).gt.lammax) then - lamr(k-1) = lammax - n0r(k-1) = lamr(k-1)**4*qr(i,k-1)/(pi*rhow) - nr(i,k-1) = n0r(k-1)/lamr(k-1) - end if - - unr(k-1) = min(arn(i,k-1)*gamma(1._r8+br)/lamr(k-1)**br,10._r8) - umr(k-1) = min(arn(i,k-1)*gamma(4._r8+br)/(6._r8*lamr(k-1)**br),10._r8) - else - lamr(k-1) = 0._r8 - n0r(k-1) = 0._r8 - umr(k-1) = 0._r8 - unr(k-1) = 0._r8 - end if - - !...................................................................... - ! snow - if (qni(i,k-1).ge.qsmall) then - lams(k-1) = (gamma(1._r8+ds)*cs*ns(i,k-1)/ & - qni(i,k-1))**(1._r8/ds) - n0s(k-1) = ns(i,k-1)*lams(k-1) - - ! check for slope - lammax = 1._r8/10.e-6_r8 - lammin = 1._r8/2000.e-6_r8 - - ! adjust vars - if (lams(k-1).lt.lammin) then - lams(k-1) = lammin - n0s(k-1) = lams(k-1)**(ds+1._r8)*qni(i,k-1)/(cs*gamma(1._r8+ds)) - ns(i,k-1) = n0s(k-1)/lams(k-1) - else if (lams(k-1).gt.lammax) then - lams(k-1) = lammax - n0s(k-1) = lams(k-1)**(ds+1._r8)*qni(i,k-1)/(cs*gamma(1._r8+ds)) - ns(i,k-1) = n0s(k-1)/lams(k-1) - end if - ums(k-1) = min(asn(i,k-1)*gamma(4._r8+bs)/(6._r8*lams(k-1)**bs),3.6_r8) - uns(k-1) = min(asn(i,k-1)*gamma(1._r8+bs)/lams(k-1)**bs,3.6_r8) - else - lams(k-1) = 0._r8 - n0s(k-1) = 0._r8 - ums(k-1) = 0._r8 - uns(k-1) = 0._r8 - end if - - rprd(i,k-1)= (qnitend(i,k) + qrtend(i,k))*arcf(i,k) - sprd(i,k-1)= qnitend(i,k) *arcf(i,k) -fhmrm(i,k-1) - - end if ! k Date: Sun, 3 Sep 2023 22:02:22 +0200 Subject: [PATCH 49/71] updates that are causing model to crash --- src/NorESM/physpkg.F90 | 2 +- src/chemistry/oslo_aero/aero_model.F90 | 10 ++--- ...{aerocom_mod.F90 => oslo_aero_aerocom.F90} | 12 +++--- ..._dry_mod.F90 => oslo_aero_aerocom_dry.F90} | 4 +- ..._opt_mod.F90 => oslo_aero_aerocom_opt.F90} | 4 +- src/chemistry/oslo_aero/oslo_aero_coag.F90 | 41 +++++++++---------- src/chemistry/oslo_aero/oslo_aero_conc.F90 | 2 +- .../oslo_aero/oslo_aero_condtend.F90 | 2 +- .../{const.F90 => oslo_aero_const.F90} | 4 +- src/chemistry/oslo_aero/oslo_aero_ndrop.F90 | 2 +- .../oslo_aero/oslo_aero_nucleate_ice.F90 | 2 +- .../oslo_aero/oslo_aero_optical_params.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_seasalt.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_utils.F90 | 2 +- 14 files changed, 44 insertions(+), 47 deletions(-) rename src/chemistry/oslo_aero/{aerocom_mod.F90 => oslo_aero_aerocom.F90} (99%) rename src/chemistry/oslo_aero/{aerocom_dry_mod.F90 => oslo_aero_aerocom_dry.F90} (99%) rename src/chemistry/oslo_aero/{aerocom_opt_mod.F90 => oslo_aero_aerocom_opt.F90} (99%) rename src/chemistry/oslo_aero/{const.F90 => oslo_aero_const.F90} (96%) diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index 1500d8f263..94839a0ebc 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -32,7 +32,7 @@ module physpkg use cam_logfile, only: iulog use camsrfexch, only: cam_export #ifdef AEROCOM - use aerocom_intfrh_mod, only: intfrh + use oslo_aero_aerocom, only: intfrh #endif use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 9bc96dbdad..fc99504687 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -49,10 +49,10 @@ module aero_model use oslo_aero_sox_cldaero, only: sox_cldaero_init use commondefinitions, only: originalSigma, originalNumberMedianRadius use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes - use const, only: numberToSurface + use oslo_aero_const, only: numberToSurface #ifdef AEROCOM - use aerocom_opt_mod, only: initaeropt - use aerocom_dry_mod, only: initdryp + use oslo_aero_aerocom_opt, only: initaeropt + use oslo_aero_aerocom_dry, only: initdryp #endif implicit none @@ -679,9 +679,9 @@ subroutine aero_model_constants() ! Updated by Alf Kirkev May 2013 ! Updated by Alf Grini February 2014 - use const - use aerosoldef + use oslo_aero_const use oslo_aero_utils + use aerosoldef ! local variables integer :: kcomp,i diff --git a/src/chemistry/oslo_aero/aerocom_mod.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 similarity index 99% rename from src/chemistry/oslo_aero/aerocom_mod.F90 rename to src/chemistry/oslo_aero/oslo_aero_aerocom.F90 index 55803eadb2..c9cf6eb98e 100644 --- a/src/chemistry/oslo_aero/aerocom_mod.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 @@ -1,4 +1,4 @@ -module aerocom_mod +module oslo_aero_aerocom #ifdef AEROCOM @@ -7,12 +7,12 @@ module aerocom_mod use cam_history, only: outfld use physics_types, only: physics_state ! - use aerocom_opt_mod, only: extinction_coeffs, extinction_coeffsn - use aerocom_dry_mod, only: aerodry_prop + use oslo_aero_aerocom_opt, only: extinction_coeffs, extinction_coeffsn + use oslo_aero_aerocom_dry, only: aerodry_prop + use oslo_aero_sw_tables use aerosoldef use commondefinitions - use oslo_aero_sw_tables - use const + use oslo_aero_const public :: aerocom public :: opticsAtConstRh @@ -1902,4 +1902,4 @@ end subroutine intfrh #endif -end module aerocom_mod +end module oslo_aero_aerocom diff --git a/src/chemistry/oslo_aero/aerocom_dry_mod.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 similarity index 99% rename from src/chemistry/oslo_aero/aerocom_dry_mod.F90 rename to src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 index 77df9b1cae..59e3fe954d 100644 --- a/src/chemistry/oslo_aero/aerocom_dry_mod.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 @@ -1,4 +1,4 @@ -module aerocom_dry_mod +module oslo_aero_aerocom_dry #ifdef AEROCOM @@ -1135,4 +1135,4 @@ end subroutine checkTableHeader #endif -end module aerocom_dry_mod +end module oslo_aero_aerocom_dry diff --git a/src/chemistry/oslo_aero/aerocom_opt_mod.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 similarity index 99% rename from src/chemistry/oslo_aero/aerocom_opt_mod.F90 rename to src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 index 700c982abd..8aa3c64d8e 100644 --- a/src/chemistry/oslo_aero/aerocom_opt_mod.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 @@ -1,4 +1,4 @@ -module aerocom_opt_mod +module oslo_aero_aerocom_opt #ifdef AEROCOM @@ -1293,4 +1293,4 @@ end subroutine checkTableHeader #endif -end module aerocom_opt_mod +end module oslo_aero_aerocom_opt diff --git a/src/chemistry/oslo_aero/oslo_aero_coag.F90 b/src/chemistry/oslo_aero/oslo_aero_coag.F90 index 801759ae21..8b31a7710d 100644 --- a/src/chemistry/oslo_aero/oslo_aero_coag.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_coag.F90 @@ -11,7 +11,7 @@ module oslo_aero_coag use physconst, only: rair, gravit use cam_logfile, only: iulog use aerosoldef - use const + use oslo_aero_const implicit none private @@ -158,7 +158,7 @@ end subroutine initializeCoagulationReceivers subroutine initializeCoagulationCoefficients(rhob,rk) use mo_constants, only: pi - use const, only: normnk + use oslo_aero_const, only: normnk real(r8), intent(in) :: rk(0:nmodes) ![unit] radius of background (receiver) mode real(r8), intent(in) :: rhob(0:nmodes) !density of background mode @@ -380,7 +380,7 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) use ppgrid, only : pcols, pver use cam_history, only: outfld use aerosoldef - use const + use oslo_aero_const use physics_buffer, only : physics_buffer_desc ! input arguments @@ -560,30 +560,27 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc ! cloud droplets. Only particles smaller that dry radius of ! 40 nm is assumed to have an efficient coagulation with other particles. - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only : pcols, pver - use cam_history, only: outfld + use shr_kind_mod, only: r8 => shr_kind_r8 + use ppgrid, only: pcols, pver + use physics_buffer, only: physics_buffer_desc + use cam_history, only: outfld + ! use aerosoldef - use const - use physics_buffer, only : physics_buffer_desc + use oslo_aero_const ! input arguments - integer, intent(in) :: ncol ! number of horizontal grid cells (columns) - real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure - real(r8), intent(in) :: pdel(pcols,pver) - real(r8), intent(in) :: temperature(pcols,pver) ! [K] temperature - - real(r8), dimension(ncol,pver),intent(in) :: cldnum ! Droplet concentration #/kg - real(r8), dimension(ncol,pver),intent(in) :: cldfrc ! Cloud volume fraction - - real(r8), intent(in) :: delt_inverse ! [1/s] inverse time step - integer, intent(in) :: lchnk ! [] chnk id needed for output - integer, intent(in) :: im - + integer , intent(in) :: ncol ! number of horizontal grid cells (columns) + real(r8) , intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture + real(r8) , intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure + real(r8) , intent(in) :: pdel(pcols,pver) + real(r8) , intent(in) :: temperature(pcols,pver) ! [K] temperature + real(r8) , intent(in) :: cldnum(ncol,pver) ! Droplet concentration #/kg + real(r8) , intent(in) :: cldfrc(ncol,pver) ! Cloud volume fraction + real(r8) , intent(in) :: delt_inverse ! [1/s] inverse time step + integer , intent(in) :: lchnk ! [] chnk id needed for output + integer , intent(in) :: im type(physics_buffer_desc), pointer :: pbuf(:) - ! local integer :: k ! level counter integer :: i ! horizontal counter diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 index 3c88bf0702..a063dc404a 100644 --- a/src/chemistry/oslo_aero/oslo_aero_conc.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_conc.F90 @@ -11,7 +11,7 @@ module oslo_aero_conc use oslo_aero_utils, only: calculateNumberConcentration use oslo_aero_coag, only: normalizedCoagulationSink use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV - use const, only: smallNumber, volumeToNumber,smallNumber + use oslo_aero_const, only: smallNumber, volumeToNumber,smallNumber use commondefinitions use aerosoldef diff --git a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 index 66e6ef2421..39b59b7889 100644 --- a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 @@ -23,7 +23,7 @@ module oslo_aero_condtend use constituents, only: pcnst ! h2so4 and soa nucleation (cka) use aerosoldef ! only: MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na use commondefinitions ! only: originalNumberMedianRadius - use const ! only: volumeToNumber + use oslo_aero_const ! only: volumeToNumber implicit none private diff --git a/src/chemistry/oslo_aero/const.F90 b/src/chemistry/oslo_aero/oslo_aero_const.F90 similarity index 96% rename from src/chemistry/oslo_aero/const.F90 rename to src/chemistry/oslo_aero/oslo_aero_const.F90 index 0733e3432f..57f67993ef 100644 --- a/src/chemistry/oslo_aero/const.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_const.F90 @@ -1,4 +1,4 @@ -module const +module oslo_aero_const !----------------------------------------------------------------------------- ! Module containing oslo_aero constants @@ -25,7 +25,7 @@ module const real(r8) :: volumeToNumber(0:nmodes) !m3 ==> # real(r8) :: numberToSurface(0:nmodes) !# ==> m2 -end module const +end module oslo_aero_const diff --git a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 index e456fcedd4..29cae2acba 100644 --- a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 @@ -26,7 +26,7 @@ module oslo_aero_ndrop use aerosoldef, only: getCloudTracerName, getCloudTracerIndex, getConstituentFraction use aerosoldef, only: fillAerosolTracerList, fillInverseAerosolTracerList use commondefinitions, only: nmodes, nbmodes - use const, only: smallNumber + use oslo_aero_const, only: smallNumber implicit none private diff --git a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 index e90f536e67..fa5b41a0ed 100644 --- a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 @@ -42,7 +42,7 @@ module oslo_aero_nucleate_ice ! use aerosoldef, only: l_dst_a2, l_dst_a3, MODE_IDX_DST_A2, MODE_IDX_DST_A3, rhopart, qqcw_get_field use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC,MODE_IDX_OMBC_INTMIX_COAT_AIT - use const, only: volumeToNumber + use oslo_aero_const, only: volumeToNumber use commondefinitions, only: nmodes implicit none diff --git a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 index 35cf14b619..b20fa9314c 100644 --- a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 @@ -15,7 +15,7 @@ module oslo_aero_optical_params use oslo_aero_conc, only: calculateBulkProperties, partitionMass use oslo_aero_sw_tables use commondefinitions - use const + use oslo_aero_const use aerosoldef implicit none diff --git a/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 b/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 index a2e7be1106..e40d093dc8 100644 --- a/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 @@ -10,7 +10,7 @@ module oslo_aero_seasalt use camsrfexch, only: cam_in_t use physics_types, only: physics_state ! - use const, only: volumeToNumber + use oslo_aero_const, only: volumeToNumber use oslo_aero_ocean, only: oslo_aero_opom_inq, oslo_aero_opom_emis use aerosoldef, only: rhopart, l_om_ni, l_ss_a1, l_ss_a2, l_ss_a3 use aerosoldef, only: MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 diff --git a/src/chemistry/oslo_aero/oslo_aero_utils.F90 b/src/chemistry/oslo_aero/oslo_aero_utils.F90 index 12b0ca7f83..b46219ee87 100644 --- a/src/chemistry/oslo_aero/oslo_aero_utils.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_utils.F90 @@ -6,7 +6,7 @@ module oslo_aero_utils use constituents, only: pcnst ! use aerosoldef, only: getDryDensity, getNumberOfBackgroundTracersInMode, getTracerIndex - use const, only: volumeToNumber, rbinMidPoint, rbinEdge, nBinsTab, nmodes + use oslo_aero_const, only: volumeToNumber, rbinMidPoint, rbinEdge, nBinsTab, nmodes use commondefinitions, only: originalNumberMedianRadius implicit none From 36ee8482d03d58a9f64845d280af151205cf0428 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 4 Sep 2023 11:29:50 +0200 Subject: [PATCH 50/71] renamed commondefinitions.F90 as oslo_aero_params.F90 --- src/NorESM/cam_diagnostics.F90 | 6 +- src/NorESM/physpkg.F90 | 13 ++- src/chemistry/mozart/mo_chm_diags.F90 | 4 +- src/chemistry/mozart/mo_usrrxt.F90 | 2 +- src/chemistry/oslo_aero/aero_model.F90 | 6 +- src/chemistry/oslo_aero/commondefinitions.F90 | 79 ------------------- src/chemistry/oslo_aero/oslo_aero_aerocom.F90 | 2 +- .../oslo_aero/oslo_aero_aerocom_dry.F90 | 2 +- .../oslo_aero/oslo_aero_aerocom_opt.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_conc.F90 | 2 +- .../oslo_aero/oslo_aero_condtend.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_const.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_depos.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 | 2 +- .../oslo_aero/oslo_aero_logn_tables.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_microp.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_ndrop.F90 | 2 +- .../oslo_aero/oslo_aero_nucleate_ice.F90 | 2 +- .../oslo_aero/oslo_aero_optical_params.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_params.F90 | 79 +++++++++++++++++++ .../oslo_aero/oslo_aero_sw_tables.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_utils.F90 | 2 +- src/physics/rrtmg/radiation.F90 | 6 +- 23 files changed, 112 insertions(+), 113 deletions(-) delete mode 100644 src/chemistry/oslo_aero/commondefinitions.F90 create mode 100644 src/chemistry/oslo_aero/oslo_aero_params.F90 diff --git a/src/NorESM/cam_diagnostics.F90 b/src/NorESM/cam_diagnostics.F90 index 3a7bede3ff..51c0412080 100644 --- a/src/NorESM/cam_diagnostics.F90 +++ b/src/NorESM/cam_diagnostics.F90 @@ -180,9 +180,9 @@ subroutine diag_init_dry(pbuf2d) use constituent_burden, only: constituent_burden_init use physics_buffer, only: pbuf_set_field use tidal_diag, only: tidal_diag_init -!+ - use commondefinitions, only: nbmodes -!- +#ifdef OSLO_AERO + use oslo_aero_params, only: nbmodes +#endif type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index 94839a0ebc..e3dc6efb52 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -15,9 +15,9 @@ module physpkg use spmd_utils, only: masterproc use physconst, only: latvap, latice, rh2o use physics_types, only: physics_state, physics_tend, physics_state_set_grid, & - physics_ptend, physics_tend_init, physics_update, & - physics_type_alloc, physics_ptend_dealloc,& - physics_state_alloc, physics_state_dealloc, physics_tend_alloc, physics_tend_dealloc + physics_ptend, physics_tend_init, physics_update, & + physics_type_alloc, physics_ptend_dealloc,& + physics_state_alloc, physics_state_dealloc, physics_tend_alloc, physics_tend_dealloc use phys_grid, only: get_ncols_p use phys_gmean, only: gmean_mass use ppgrid, only: begchunk, endchunk, pcols, pver, pverp, psubcols @@ -1753,11 +1753,10 @@ subroutine tphysbc (ztodt, state, & use subcol_utils, only: subcol_ptend_copy, is_subcol_on use qneg_module, only: qneg3 - ! OSLO_AERO beg - use commondefinitions +#ifdef OSLO_AERO + use oslo_aero_params use aerosoldef !, only: nmodes - ! OSLO_AERO end - +#endif implicit none real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) diff --git a/src/chemistry/mozart/mo_chm_diags.F90 b/src/chemistry/mozart/mo_chm_diags.F90 index db7e048d62..e73ac0f5af 100644 --- a/src/chemistry/mozart/mo_chm_diags.F90 +++ b/src/chemistry/mozart/mo_chm_diags.F90 @@ -69,7 +69,7 @@ subroutine chm_diags_inti use mo_drydep, only : has_drydep use species_sums_diags, only : species_sums_init #ifdef OSLO_AERO - use commondefinitions + use oslo_aero_params use aerosoldef, only: getCloudTracerIndexDirect, getCloudTracerName, isAerosol #endif @@ -570,7 +570,7 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf use aerosoldef, only : getCloudTracerIndexDirect, getCloudTracerName, aerosolType, isAerosol use physics_buffer, only : pbuf_get_field, pbuf_get_index use physics_buffer, only : physics_buffer_desc - use commondefinitions + use oslo_aero_params #endif ! ! CCMI diff --git a/src/chemistry/mozart/mo_usrrxt.F90 b/src/chemistry/mozart/mo_usrrxt.F90 index 6cb617b894..aa7f526a94 100644 --- a/src/chemistry/mozart/mo_usrrxt.F90 +++ b/src/chemistry/mozart/mo_usrrxt.F90 @@ -4,7 +4,7 @@ module mo_usrrxt use cam_logfile, only : iulog use ppgrid, only : pver, pcols #ifdef OSLO_AERO - use commondefinitions, only: nmodes_oslo=> nmodes + use oslo_aero_params, only: nmodes_oslo=> nmodes #endif implicit none diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index fc99504687..1a2443f334 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -47,8 +47,8 @@ module aero_model use aerosoldef, only: getCloudTracerName use aerosoldef, only: aero_register use oslo_aero_sox_cldaero, only: sox_cldaero_init - use commondefinitions, only: originalSigma, originalNumberMedianRadius - use commondefinitions, only: nmodes_oslo=>nmodes, nbmodes + use oslo_aero_params, only: originalSigma, originalNumberMedianRadius + use oslo_aero_params, only: nmodes_oslo=>nmodes, nbmodes use oslo_aero_const, only: numberToSurface #ifdef AEROCOM use oslo_aero_aerocom_opt, only: initaeropt @@ -791,7 +791,7 @@ subroutine calcaersize_sub( ncol, t, h2ommr, pmid, pdel,wetnumberMedianDiameter, ! Seland Calculates mean volume size and hygroscopic growth for use in dry deposition - use commondefinitions, only: nmodes + use oslo_aero_params, only: nmodes use aerosoldef integer, intent(in) :: ncol ! number of columns diff --git a/src/chemistry/oslo_aero/commondefinitions.F90 b/src/chemistry/oslo_aero/commondefinitions.F90 deleted file mode 100644 index aaccd85641..0000000000 --- a/src/chemistry/oslo_aero/commondefinitions.F90 +++ /dev/null @@ -1,79 +0,0 @@ - -module commondefinitions - -!--------------------------------------------------------------------------------- -! Module for aerosol hygroscopicities and dry size parameters which are common -! in AeroTab and CAM5-Oslo. Note: This file is not yet linked with AeroTab, so -! make sure that the look-up tables made with AeroTab (optics and the dry size -! parameters for modified size distributions) are based on the same version of -! commondefinitions.F90. -!--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - implicit none - - - !Define some aerosol types and their properties.. - integer, parameter, public :: N_AEROSOL_TYPES = 5 - integer, parameter, public :: AEROSOL_TYPE_SULFATE = 1 - integer, parameter, public :: AEROSOL_TYPE_BC = 2 - integer, parameter, public :: AEROSOL_TYPE_OM = 3 - integer, parameter, public :: AEROSOL_TYPE_DUST = 4 - integer, parameter, public :: AEROSOL_TYPE_SALT = 5 - - !NUMBERS BELOW ARE ESSENTIAL TO CALCULATE HYGROSCOPICITY AND THEREFORE INDIRECT EFFECT! - !These numbers define the "hygroscopicity parameter" Numbers are selected so that they give reasonable hygroscipity - !note that changing numbers individually changes the hygroscopicity! - !Hygroscopicity is defined in Abdul-Razzak and S. Ghan: (B in their eqn 4) - !A parameterization of aerosol activation 2. Multiple aerosol types, JGR, vol 105, noD5, pp 6837 - !http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract - ! - !Further note that changing any of these numbers without changing aerotab will lead to - !inconsistencies in the simulation since Aerotab tabulates hygroscopical growth! - ! - !Main reference for numbers chosen: Ghan et al MIRAGE paper (JRG, vol 106, D6, pp 5295), 2001 - !References: - !SULFATE : Using same numbers as MIRAGE paper (ammonium sulfate) - !BC : Does not really matter as long as soluble mass fraction is small - ! However, numbers below reproduces values from MIRAGE paper - ! New mass density (October 2016) is based on Bond and Bergstrom (2007): Light Absorption - ! by Carbonaceous Particles: An Investigative Review, Aerosol Science and Technology, 40:27œôòó67. - !OM : Soluble mass fraction tuned to give B of MIRAGE Paper - !DUST : The numbers give B of ~ 0.07 (high end of Kohler, Kreidenweis et al, GRL, vol 36, 2009. - ! (10% as soluble mass fraction seems reasonable) - ! (see also Osada et al, Atmospheric Research, vol 124, 2013, pp 101 - !SEA SALT: Soluble mass fraction tuned to give consistent values for (r/r0) at 99% when using the parametrization in - ! Koepke, Hess, Schult and Shettle: Max-Plack-Institut fur Meteorolgie, report No. 243 "GLOBAL AEROSOL DATA SET" - ! These values give "B" of 1.20 instead of 1.16 in MIRAGE paper. - - character(len=8),public, dimension(N_AEROSOL_TYPES) :: aerosol_type_name = & - (/"SULFATE ", "BC ","OM ", "DUST ", "SALT " /) - real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_density = & - (/1769.0_r8, 1800.0_r8, 1500.0_r8, 2600.0_r8, 2200.0_r8 /) !kg/m3 - real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_molecular_weight = & - (/132.0_r8, 12.0_r8, 168.2_r8, 135.0_r8, 58.44_r8 /) !kg/kmol - real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_osmotic_coefficient = & - (/0.7_r8, 1.111_r8, 1.0_r8, 1.0_r8, 1.0_r8 /) ![-] - real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_soluble_mass_fraction = & - (/1.0_r8, 1.67e-7_r8, 0.8725_r8, 0.1_r8, 0.885_r8 /) ![-] - real(r8), public, dimension(N_AEROSOL_TYPES) :: aerosol_type_number_of_ions = & - (/3.0_r8, 1.0_r8, 1.0_r8, 2.0_r8, 2.0_r8 /) ![-] - -! Define lognormal size parameters for each size mode (dry, at point of emission/production) - integer, public, parameter :: nmodes = 14 - integer, public, parameter :: nbmodes = 10 - !Number median radius of background emissions THESE DO NOT ASSUME IMPLICIT GROWTH!! - real(r8), parameter, public, dimension(0:nmodes) :: originalNumberMedianRadius = & - 1.e-6_r8* (/ 0.0626_r8, & !0 - 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8, 0.075_r8, & !1-5 - 0.22_r8, 0.63_r8, 0.0475_r8, 0.30_r8, 0.75_r8, & !6-10 ! SS: Salter et al. (2015) - 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8 /) !11-14 - - !sigma of background aerosols ) - real(r8), parameter, public, dimension(0:nmodes) :: originalSigma = & - (/1.6_r8, & !0 - 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8, 1.59_r8, & !1-5 - 1.59_r8, 2.0_r8, 2.1_r8, 1.72_r8, 1.60_r8, & !6-10 ! SS: Salter et al. (2015) - 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 /) !11-14 - -end module diff --git a/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 index c9cf6eb98e..dafe27cd72 100644 --- a/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 @@ -11,7 +11,7 @@ module oslo_aero_aerocom use oslo_aero_aerocom_dry, only: aerodry_prop use oslo_aero_sw_tables use aerosoldef - use commondefinitions + use oslo_aero_params use oslo_aero_const public :: aerocom diff --git a/src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 index 59e3fe954d..0b8b24075c 100644 --- a/src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 @@ -6,7 +6,7 @@ module oslo_aero_aerocom_dry use ppgrid , only: pcols, pver use cam_logfile , only: iulog ! - use commondefinitions , only: nmodes, nbmodes + use oslo_aero_params , only: nmodes, nbmodes use oslo_aero_sw_tables , only: cate, cat, fac, faq, fbc, fombg, fbcbg, nbmp1 use oslo_aero_linear_interp , only: lininterpol3dim, lininterpol4dim, lininterpol5dim use oslo_aero_control , only: oslo_aero_getopts, dir_string_length diff --git a/src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 index 8aa3c64d8e..709070ce85 100644 --- a/src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 @@ -6,7 +6,7 @@ module oslo_aero_aerocom_opt use ppgrid , only : pcols, pver use cam_logfile , only : iulog ! - use commondefinitions , only : nmodes, nbmodes + use oslo_aero_params , only : nmodes, nbmodes use oslo_aero_sw_tables , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg use oslo_aero_control , only : oslo_aero_getopts, dir_string_length use oslo_aero_linear_interp , only : lininterpol3dim, lininterpol4dim, lininterpol5dim diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 index a063dc404a..24b14fdbc7 100644 --- a/src/chemistry/oslo_aero/oslo_aero_conc.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_conc.F90 @@ -12,7 +12,7 @@ module oslo_aero_conc use oslo_aero_coag, only: normalizedCoagulationSink use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV use oslo_aero_const, only: smallNumber, volumeToNumber,smallNumber - use commondefinitions + use oslo_aero_params use aerosoldef implicit none diff --git a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 index 39b59b7889..366e2094ad 100644 --- a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 @@ -22,7 +22,7 @@ module oslo_aero_condtend use oslo_aero_coag, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd use constituents, only: pcnst ! h2so4 and soa nucleation (cka) use aerosoldef ! only: MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na - use commondefinitions ! only: originalNumberMedianRadius + use oslo_aero_params ! only: originalNumberMedianRadius use oslo_aero_const ! only: volumeToNumber implicit none diff --git a/src/chemistry/oslo_aero/oslo_aero_const.F90 b/src/chemistry/oslo_aero/oslo_aero_const.F90 index 57f67993ef..12e111eb17 100644 --- a/src/chemistry/oslo_aero/oslo_aero_const.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_const.F90 @@ -5,7 +5,7 @@ module oslo_aero_const !----------------------------------------------------------------------------- use shr_kind_mod, only: r8 => shr_kind_r8 - use commondefinitions, only: nmodes + use oslo_aero_params, only: nmodes use physconst, only: pi ! implicit none diff --git a/src/chemistry/oslo_aero/oslo_aero_depos.F90 b/src/chemistry/oslo_aero/oslo_aero_depos.F90 index 41e79f4a2b..4cb468db9f 100644 --- a/src/chemistry/oslo_aero/oslo_aero_depos.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_depos.F90 @@ -24,8 +24,8 @@ module oslo_aero_depos use ref_pres, only: top_lev => clim_modal_aero_top_lev ! use oslo_aero_dust_sediment, only: oslo_aero_dust_sediment_tend, oslo_aero_dust_sediment_vel + use oslo_aero_params use aerosoldef - use commondefinitions ! use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac ! use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 diff --git a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 index 66dc578a3a..475bf0419a 100644 --- a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 @@ -31,7 +31,7 @@ module oslo_aero_hetfrz use cam_abortutils, only: endrun ! use oslo_aero_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius - use commondefinitions, only: nmodes_oslo => nmodes + use oslo_aero_params, only: nmodes_oslo => nmodes use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex use aerosoldef, only: qqcw_get_field diff --git a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 index 36b665c86f..bdd42c913e 100644 --- a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 @@ -8,7 +8,7 @@ module oslo_aero_logn_tables use oslo_aero_control, only: oslo_aero_getopts,dir_string_length use oslo_aero_sw_tables, only: cate, fac, faq, fbc, cat use oslo_aero_linear_interp, only: lininterpol3dim, lininterpol4dim - use commondefinitions, only: nmodes, nbmodes + use oslo_aero_params, only: nmodes, nbmodes use aerosoldef implicit none diff --git a/src/chemistry/oslo_aero/oslo_aero_microp.F90 b/src/chemistry/oslo_aero/oslo_aero_microp.F90 index 5bfcc6ad18..3f96f8f2ad 100644 --- a/src/chemistry/oslo_aero/oslo_aero_microp.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_microp.F90 @@ -31,7 +31,7 @@ module oslo_aero_microp use oslo_aero_hetfrz, only: hetfrz_classnuc_oslo_calc, hetfrz_classnuc_oslo_save_cbaero use oslo_aero_nucleate_ice, only: nucleate_ice_oslo_register, nucleate_ice_oslo_init, nucleate_ice_oslo_readnl use oslo_aero_nucleate_ice, only: nucleate_ice_oslo_calc, use_preexisting_ice - use commondefinitions, only: nmodes_oslo => nmodes + use oslo_aero_params, only: nmodes_oslo => nmodes use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC, MODE_IDX_OMBC_INTMIX_COAT_AIT use aerosoldef, only: lifeCycleNumberMedianRadius, l_dst_a2, l_dst_a3, l_bc_ai use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex, getCloudTracerIndex diff --git a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 index 29cae2acba..f32cf11b2b 100644 --- a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 @@ -25,7 +25,7 @@ module oslo_aero_ndrop use aerosoldef, only: getNumberOfTracersInMode, getNumberOfAerosolTracers, getTracerIndex use aerosoldef, only: getCloudTracerName, getCloudTracerIndex, getConstituentFraction use aerosoldef, only: fillAerosolTracerList, fillInverseAerosolTracerList - use commondefinitions, only: nmodes, nbmodes + use oslo_aero_params, only: nmodes, nbmodes use oslo_aero_const, only: smallNumber implicit none diff --git a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 index fa5b41a0ed..cb54a75051 100644 --- a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 @@ -43,7 +43,7 @@ module oslo_aero_nucleate_ice use aerosoldef, only: l_dst_a2, l_dst_a3, MODE_IDX_DST_A2, MODE_IDX_DST_A3, rhopart, qqcw_get_field use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC,MODE_IDX_OMBC_INTMIX_COAT_AIT use oslo_aero_const, only: volumeToNumber - use commondefinitions, only: nmodes + use oslo_aero_params, only: nmodes implicit none private diff --git a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 index b20fa9314c..d400669140 100644 --- a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 @@ -14,7 +14,7 @@ module oslo_aero_optical_params use oslo_aero_utils, only: calculateNumberConcentration use oslo_aero_conc, only: calculateBulkProperties, partitionMass use oslo_aero_sw_tables - use commondefinitions + use oslo_aero_params use oslo_aero_const use aerosoldef diff --git a/src/chemistry/oslo_aero/oslo_aero_params.F90 b/src/chemistry/oslo_aero/oslo_aero_params.F90 new file mode 100644 index 0000000000..f612b2845f --- /dev/null +++ b/src/chemistry/oslo_aero/oslo_aero_params.F90 @@ -0,0 +1,79 @@ +module oslo_aero_params + + !--------------------------------------------------------------------------------- + ! Module for aerosol hygroscopicities and dry size parameters which are common + ! in AeroTab and CAM5-Oslo. Note: This file is not yet linked with AeroTab, so + ! make sure that the look-up tables made with AeroTab (optics and the dry size + ! parameters for modified size distributions) are based on the same version of + ! commondefinitions.F90. + !--------------------------------------------------------------------------------- + + use shr_kind_mod, only: r8 => shr_kind_r8 + + implicit none + public + + ! Define some aerosol types and their properties.. + integer, parameter, public :: N_AEROSOL_TYPES = 5 + integer, parameter, public :: AEROSOL_TYPE_SULFATE = 1 + integer, parameter, public :: AEROSOL_TYPE_BC = 2 + integer, parameter, public :: AEROSOL_TYPE_OM = 3 + integer, parameter, public :: AEROSOL_TYPE_DUST = 4 + integer, parameter, public :: AEROSOL_TYPE_SALT = 5 + + ! NUMBERS BELOW ARE ESSENTIAL TO CALCULATE HYGROSCOPICITY AND THEREFORE INDIRECT EFFECT! + ! These numbers define the "hygroscopicity parameter" Numbers are selected so that they give reasonable hygroscipity + ! note that changing numbers individually changes the hygroscopicity! + ! Hygroscopicity is defined in Abdul-Razzak and S. Ghan: (B in their eqn 4) + ! A parameterization of aerosol activation 2. Multiple aerosol types, JGR, vol 105, noD5, pp 6837 + ! http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract + ! + ! Further note that changing any of these numbers without changing aerotab will lead to + ! inconsistencies in the simulation since Aerotab tabulates hygroscopical growth! + ! + ! Main reference for numbers chosen: Ghan et al MIRAGE paper (JRG, vol 106, D6, pp 5295), 2001 References: + ! SULFATE : Using same numbers as MIRAGE paper (ammonium sulfate) + ! BC : Does not really matter as long as soluble mass fraction is small + ! However, numbers below reproduces values from MIRAGE paper + ! New mass density (October 2016) is based on Bond and Bergstrom (2007): Light Absorption + ! by Carbonaceous Particles: An Investigative Review, Aerosol Science and Technology, 40:27•¡¹67. + ! OM : Soluble mass fraction tuned to give B of MIRAGE Paper + ! DUST : The numbers give B of ~ 0.07 (high end of Kohler, Kreidenweis et al, GRL, vol 36, 2009. + ! (10% as soluble mass fraction seems reasonable) + ! (see also Osada et al, Atmospheric Research, vol 124, 2013, pp 101 + ! SEA SALT: Soluble mass fraction tuned to give consistent values for (r/r0) at 99% when using the parametrization in + ! Koepke, Hess, Schult and Shettle: Max-Plack-Institut fur Meteorolgie, report No. 243 "GLOBAL AEROSOL DATA SET" + ! These values give "B" of 1.20 instead of 1.16 in MIRAGE paper. + + character(len=8) :: aerosol_type_name(N_AEROSOL_TYPES) = & + (/"SULFATE ", "BC ","OM ", "DUST ", "SALT " /) + real(r8) :: aerosol_type_density(N_AEROSOL_TYPES) = & + (/1769.0_r8, 1800.0_r8, 1500.0_r8, 2600.0_r8, 2200.0_r8 /) !kg/m3 + real(r8) :: aerosol_type_molecular_weight(N_AEROSOL_TYPES) = & + (/132.0_r8, 12.0_r8, 168.2_r8, 135.0_r8, 58.44_r8 /) !kg/kmol + real(r8) :: aerosol_type_osmotic_coefficient(N_AEROSOL_TYPES) = & + (/0.7_r8, 1.111_r8, 1.0_r8, 1.0_r8, 1.0_r8 /) ![-] + real(r8) :: aerosol_type_soluble_mass_fraction(N_AEROSOL_TYPES) = & + (/1.0_r8, 1.67e-7_r8, 0.8725_r8, 0.1_r8, 0.885_r8 /) ![-] + real(r8) :: aerosol_type_number_of_ions(N_AEROSOL_TYPES) = & + (/3.0_r8, 1.0_r8, 1.0_r8, 2.0_r8, 2.0_r8 /) ![-] + + ! Define lognormal size parameters for each size mode (dry, at point of emission/production) + integer, parameter :: nmodes = 14 + integer, parameter :: nbmodes = 10 + + ! Number median radius of background emissions THESE DO NOT ASSUME IMPLICIT GROWTH!! + real(r8), parameter :: originalNumberMedianRadius(0:nmodes) = & + 1.e-6_r8* (/ 0.0626_r8, & !0 + 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8, 0.075_r8, & !1-5 + 0.22_r8, 0.63_r8, 0.0475_r8, 0.30_r8, 0.75_r8, & !6-10 ! SS: Salter et al. (2015) + 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8 /) !11-14 + + ! sigma of background aerosols ) + real(r8), parameter :: originalSigma(0:nmodes) = & + (/1.6_r8, & !0 + 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8, 1.59_r8, & !1-5 + 1.59_r8, 2.0_r8, 2.1_r8, 1.72_r8, 1.60_r8, & !6-10 ! SS: Salter et al. (2015) + 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 /) !11-14 + +end module oslo_aero_params diff --git a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 index b9720790f5..945b54a978 100644 --- a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 @@ -42,7 +42,7 @@ module oslo_aero_sw_tables ! use oslo_aero_control , only: oslo_aero_getopts, dir_string_length use oslo_aero_linear_interp , only: lininterpol3dim, lininterpol4dim, lininterpol5dim - use commondefinitions , only: nmodes, nbmodes + use oslo_aero_params , only: nmodes, nbmodes implicit none private diff --git a/src/chemistry/oslo_aero/oslo_aero_utils.F90 b/src/chemistry/oslo_aero/oslo_aero_utils.F90 index b46219ee87..b776a653aa 100644 --- a/src/chemistry/oslo_aero/oslo_aero_utils.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_utils.F90 @@ -7,7 +7,7 @@ module oslo_aero_utils ! use aerosoldef, only: getDryDensity, getNumberOfBackgroundTracersInMode, getTracerIndex use oslo_aero_const, only: volumeToNumber, rbinMidPoint, rbinEdge, nBinsTab, nmodes - use commondefinitions, only: originalNumberMedianRadius + use oslo_aero_params, only: originalNumberMedianRadius implicit none private diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index a3e699a0ef..95d98eede1 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -45,7 +45,7 @@ module radiation #ifdef OSLO_AERO use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands use oslo_aero_optical_params, only: oslo_aero_optical_params_calc - use commondefinitions, only: nmodes, nbmodes + use oslo_aero_params, only: nmodes, nbmodes #endif implicit none @@ -729,9 +729,9 @@ subroutine radiation_tend( & use constituents, only: pcnst #ifdef OSLO_AERO - use physics_buffer, only: pbuf_get_index + use physics_buffer, only: pbuf_get_index use oslo_aero_control, only: oslo_aero_getopts - use commondefinitions + use oslo_aero_params use aerosoldef #endif From f90b69cd2f2f6c4588423b86f9e06e9eb5f969a7 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 4 Sep 2023 11:49:30 +0200 Subject: [PATCH 51/71] moved aerosoldef to oslo_aero_share --- src/NorESM/physpkg.F90 | 2 +- src/chemistry/mozart/mo_chm_diags.F90 | 5 +- src/chemistry/oslo_aero/aero_model.F90 | 14 +- src/chemistry/oslo_aero/oslo_aero_aerocom.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_coag.F90 | 6 +- src/chemistry/oslo_aero/oslo_aero_conc.F90 | 2 +- .../oslo_aero/oslo_aero_condtend.F90 | 6 +- src/chemistry/oslo_aero/oslo_aero_depos.F90 | 6 +- src/chemistry/oslo_aero/oslo_aero_dust.F90 | 4 +- src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 | 10 +- .../oslo_aero/oslo_aero_logn_tables.F90 | 93 +++++++------- src/chemistry/oslo_aero/oslo_aero_microp.F90 | 6 +- src/chemistry/oslo_aero/oslo_aero_ndrop.F90 | 6 +- .../oslo_aero/oslo_aero_nucleate_ice.F90 | 4 +- .../oslo_aero/oslo_aero_optical_params.F90 | 4 +- src/chemistry/oslo_aero/oslo_aero_seasalt.F90 | 4 +- .../{aerosoldef.F90 => oslo_aero_share.F90} | 120 ++++++++++-------- .../oslo_aero/oslo_aero_sox_cldaero.F90 | 2 +- src/chemistry/oslo_aero/oslo_aero_utils.F90 | 2 +- src/physics/cam_oslo/vertical_diffusion.F90 | 4 +- src/physics/rrtmg/radiation.F90 | 2 +- 21 files changed, 158 insertions(+), 146 deletions(-) rename src/chemistry/oslo_aero/{aerosoldef.F90 => oslo_aero_share.F90} (92%) diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index e3dc6efb52..44e3d66d51 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -1755,7 +1755,7 @@ subroutine tphysbc (ztodt, state, & #ifdef OSLO_AERO use oslo_aero_params - use aerosoldef !, only: nmodes + use oslo_aero_share #endif implicit none diff --git a/src/chemistry/mozart/mo_chm_diags.F90 b/src/chemistry/mozart/mo_chm_diags.F90 index e73ac0f5af..c695d91c99 100644 --- a/src/chemistry/mozart/mo_chm_diags.F90 +++ b/src/chemistry/mozart/mo_chm_diags.F90 @@ -69,8 +69,8 @@ subroutine chm_diags_inti use mo_drydep, only : has_drydep use species_sums_diags, only : species_sums_init #ifdef OSLO_AERO + use oslo_aero_share, only: getCloudTracerIndexDirect, getCloudTracerName, isAerosol use oslo_aero_params - use aerosoldef, only: getCloudTracerIndexDirect, getCloudTracerName, isAerosol #endif integer :: j, k, m, n @@ -567,9 +567,10 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf #ifdef OSLO_AERO use constituents, only : cnst_get_ind use phys_grid, only : pcols - use aerosoldef, only : getCloudTracerIndexDirect, getCloudTracerName, aerosolType, isAerosol use physics_buffer, only : pbuf_get_field, pbuf_get_index use physics_buffer, only : physics_buffer_desc + ! + use oslo_aero_share,only : getCloudTracerIndexDirect, getCloudTracerName, aerosolType, isAerosol use oslo_aero_params #endif ! diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/aero_model.F90 index 1a2443f334..bf097403c1 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/aero_model.F90 @@ -41,11 +41,11 @@ module aero_model use oslo_aero_dust, only: oslo_aero_dust_init, oslo_aero_dust_emis, dust_active use oslo_aero_ocean, only: oslo_aero_ocean_init, oslo_aero_dms_emis use oslo_aero_sw_tables, only: initopt, initopt_lw - use aerosoldef, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName - use aerosoldef, only: qqcw_get_field, numberOfProcessModeTracers - use aerosoldef, only: lifeCycleNumberMedianRadius - use aerosoldef, only: getCloudTracerName - use aerosoldef, only: aero_register + use oslo_aero_share, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName + use oslo_aero_share, only: qqcw_get_field, numberOfProcessModeTracers + use oslo_aero_share, only: lifeCycleNumberMedianRadius + use oslo_aero_share, only: getCloudTracerName + use oslo_aero_share, only: aero_register use oslo_aero_sox_cldaero, only: sox_cldaero_init use oslo_aero_params, only: originalSigma, originalNumberMedianRadius use oslo_aero_params, only: nmodes_oslo=>nmodes, nbmodes @@ -681,7 +681,7 @@ subroutine aero_model_constants() use oslo_aero_const use oslo_aero_utils - use aerosoldef + use oslo_aero_share ! local variables integer :: kcomp,i @@ -792,7 +792,7 @@ subroutine calcaersize_sub( ncol, t, h2ommr, pmid, pdel,wetnumberMedianDiameter, ! Seland Calculates mean volume size and hygroscopic growth for use in dry deposition use oslo_aero_params, only: nmodes - use aerosoldef + use oslo_aero_share integer, intent(in) :: ncol ! number of columns real(r8), intent(in) :: t(pcols,pver) ! layer temperatures (K) diff --git a/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 index dafe27cd72..8af15920c2 100644 --- a/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 @@ -10,7 +10,7 @@ module oslo_aero_aerocom use oslo_aero_aerocom_opt, only: extinction_coeffs, extinction_coeffsn use oslo_aero_aerocom_dry, only: aerodry_prop use oslo_aero_sw_tables - use aerosoldef + use oslo_aero_share use oslo_aero_params use oslo_aero_const diff --git a/src/chemistry/oslo_aero/oslo_aero_coag.F90 b/src/chemistry/oslo_aero/oslo_aero_coag.F90 index 8b31a7710d..150401b0c2 100644 --- a/src/chemistry/oslo_aero/oslo_aero_coag.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_coag.F90 @@ -10,7 +10,7 @@ module oslo_aero_coag use mo_tracname, only: solsym use physconst, only: rair, gravit use cam_logfile, only: iulog - use aerosoldef + use oslo_aero_share use oslo_aero_const implicit none @@ -379,7 +379,7 @@ subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only : pcols, pver use cam_history, only: outfld - use aerosoldef + use oslo_aero_share use oslo_aero_const use physics_buffer, only : physics_buffer_desc @@ -565,7 +565,7 @@ subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, nc use physics_buffer, only: physics_buffer_desc use cam_history, only: outfld ! - use aerosoldef + use oslo_aero_share use oslo_aero_const ! input arguments diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 index 24b14fdbc7..4904bb9a52 100644 --- a/src/chemistry/oslo_aero/oslo_aero_conc.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_conc.F90 @@ -13,7 +13,7 @@ module oslo_aero_conc use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV use oslo_aero_const, only: smallNumber, volumeToNumber,smallNumber use oslo_aero_params - use aerosoldef + use oslo_aero_share implicit none private diff --git a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 index 366e2094ad..c38cf2bc7e 100644 --- a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 @@ -21,8 +21,8 @@ module oslo_aero_condtend use oslo_aero_coag, only: normalizedCoagulationSink, receiverMode,numberOfCoagulationReceivers use oslo_aero_coag, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd use constituents, only: pcnst ! h2so4 and soa nucleation (cka) - use aerosoldef ! only: MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na - use oslo_aero_params ! only: originalNumberMedianRadius + use oslo_aero_share ! only: MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na + use oslo_aero_params ! only: originalNumberMedianRadius use oslo_aero_const ! only: volumeToNumber implicit none @@ -150,7 +150,7 @@ subroutine initializeCondensation() do cond_vap_idx = 1, N_COND_VAP - rho = rhopart(physicsIndex(cond_vap_map(cond_vap_idx))) !pick up densities from aerosoldef + rho = rhopart(physicsIndex(cond_vap_map(cond_vap_idx))) !pick up densities from oslo_aero_share molecularWeight=adv_mass(cond_vap_map(cond_vap_idx)) !pick up molecular weights from mozart diff --git a/src/chemistry/oslo_aero/oslo_aero_depos.F90 b/src/chemistry/oslo_aero/oslo_aero_depos.F90 index 4cb468db9f..e967c27243 100644 --- a/src/chemistry/oslo_aero/oslo_aero_depos.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_depos.F90 @@ -25,9 +25,9 @@ module oslo_aero_depos ! use oslo_aero_dust_sediment, only: oslo_aero_dust_sediment_tend, oslo_aero_dust_sediment_vel use oslo_aero_params - use aerosoldef - ! use aerosoldef, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac - ! use aerosoldef, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 + use oslo_aero_share + ! use oslo_aero_share, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac + ! use oslo_aero_share, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 implicit none private ! Make default type private to the module diff --git a/src/chemistry/oslo_aero/oslo_aero_dust.F90 b/src/chemistry/oslo_aero/oslo_aero_dust.F90 index 6a1637ea7d..4c3302e98b 100644 --- a/src/chemistry/oslo_aero/oslo_aero_dust.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_dust.F90 @@ -19,7 +19,7 @@ module oslo_aero_dust use ioFileMod, only: getfil use pio, only: file_desc_t,pio_inq_dimid,pio_inq_dimlen,pio_get_var,pio_inq_varid, PIO_NOWRITE ! - use aerosoldef, only: l_dst_a2, l_dst_a3 + use oslo_aero_share, only: l_dst_a2, l_dst_a3 implicit none private @@ -34,7 +34,7 @@ module oslo_aero_dust character(len=6), public :: dust_names(10) - integer , parameter :: numberOfDustModes = 2 !define in aerosoldef? + integer , parameter :: numberOfDustModes = 2 !define in oslo_aero_share? real(r8), parameter :: emis_fraction_in_mode(numberOfDustModes) = (/0.13_r8, 0.87_r8 /) integer :: tracerMap(numberOfDustModes) = (/-99, -99/) !index of dust tracers in the modes diff --git a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 index 475bf0419a..f7ff34e929 100644 --- a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 @@ -32,11 +32,11 @@ module oslo_aero_hetfrz ! use oslo_aero_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius use oslo_aero_params, only: nmodes_oslo => nmodes - use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT - use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex - use aerosoldef, only: qqcw_get_field - use aerosoldef, only: l_dst_a2, l_dst_a3, l_bc_ai, l_bc_ac - use aerosoldef, only: lifeCycleNumberMedianRadius, lifeCycleSigma + use oslo_aero_share, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT + use oslo_aero_share, only: getNumberOfTracersInMode, getTracerIndex + use oslo_aero_share, only: qqcw_get_field + use oslo_aero_share, only: l_dst_a2, l_dst_a3, l_bc_ai, l_bc_ac + use oslo_aero_share, only: lifeCycleNumberMedianRadius, lifeCycleSigma implicit none private diff --git a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 index bdd42c913e..faa1380466 100644 --- a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 @@ -9,7 +9,7 @@ module oslo_aero_logn_tables use oslo_aero_sw_tables, only: cate, fac, faq, fbc, cat use oslo_aero_linear_interp, only: lininterpol3dim, lininterpol4dim use oslo_aero_params, only: nmodes, nbmodes - use aerosoldef + use oslo_aero_share implicit none private @@ -21,33 +21,33 @@ module oslo_aero_logn_tables real(r8) :: rrr1to3 (3,16,6) ! Modal radius array, mode 1 - 3 real(r8) :: sss1to3 (3,16,6) ! Standard deviation array, Mode 1 -3 - real(r8) :: rrr4 (16,6,6) ! Modal radius array, mode 4 - real(r8) :: sss4 (16,6,6) ! Modal radius array, mode 4 + real(r8) :: rrr4 (16,6,6) ! Modal radius array, mode 4 + real(r8) :: sss4 (16,6,6) ! Modal radius array, mode 4 real(r8) :: rrr (5:10,6,6,6,6) ! Modal radius array, mode 5 - 10 real(r8) :: sss (5:10,6,6,6,6) ! Standard deviation array, mode 5 - 10 real(r8) :: calog1to3(3,96) ! Array for reading catot from file real(r8) :: rk1to3 (3,96) ! Array for reading modal radius from file real(r8) :: stdv1to3 (3,96) ! Array for reading std. dev. from file - real(r8) :: fraclog1to3 (3,96) ! Same as frac4, but for initlogn.F90 + real(r8) :: fraclog1to3 (3,96) ! Same as frac4, but for initlogn.F90 real(r8) :: calog4(576) ! Same as catot4, but for initlogn.F90 - real(r8) :: fraclog4(576) ! Same as frac4, but for initlogn.F90 + real(r8) :: fraclog4(576) ! Same as frac4, but for initlogn.F90 real(r8) :: fraqlog4(576) ! Same as fraq4, but for initlogn.F90 real(r8) :: rk4 (576) ! Array for reading modal radius from file real(r8) :: stdv4 (576) ! Array for reading std. dev. from file real(r8) :: calog (5:10,1296) ! Same as catot, but for initlogn.F90 - real(r8) :: fraclog5to10 (5:10,1296) ! Same as frac5to10, but for initlogn.F90 - real(r8) :: fabclog5to10 (5:10,1296) ! Same as fabc5to10, but for initlogn.F90 - real(r8) :: fraqlog5to10 (5:10,1296) ! Same as fraq5to10, but for initlogn.F90 + real(r8) :: fraclog5to10 (5:10,1296) ! Same as frac5to10, but for initlogn.F90 + real(r8) :: fabclog5to10 (5:10,1296) ! Same as fabc5to10, but for initlogn.F90 + real(r8) :: fraqlog5to10 (5:10,1296) ! Same as fraq5to10, but for initlogn.F90 real(r8) :: rk5to10 (5:10,1296) ! Array for reading modal radius from file real(r8) :: stdv5to10 (5:10,1296) ! Array for reading std. dev. from file !======================================================= contains !======================================================= - + subroutine initlogn() ! Reads the tabulated parameters for "best lognormal fits" of the @@ -73,7 +73,7 @@ subroutine initlogn() open(28,file=trim(aerotab_table_dir)//'/logntilp9.out' ,form='formatted',status='old') ! SEASACC open(29,file=trim(aerotab_table_dir)//'/logntilp10.out',form='formatted',status='old') ! SEASCOA if (masterproc) then - write(iulog,*)'nlog open ok' + write(iulog,*)'nlog open ok' end if ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) @@ -85,14 +85,14 @@ subroutine initlogn() ! Mode 1 (SO4&SOA + condesate from H2SO4 and SOA) ! Modes 2 to 3 (BC/OC + condesate from H2SO4 and SOA) ! - ! These two are treated the same way since there is no dependence on - ! fombg (SOA fraction in the background) for mode 1. + ! These two are treated the same way since there is no dependence on + ! fombg (SOA fraction in the background) for mode 1. ! ************************************************************************ do ifil = 1,2 - do lin = 1,96 ! 16*6 entries + do lin = 1,96 ! 16*6 entries read(19+ifil,993) kcomp, calog1to3(ifil,lin), fraclog1to3 (ifil, lin), & - rk1to3(ifil,lin), stdv1to3(ifil,lin) + rk1to3(ifil,lin), stdv1to3(ifil,lin) do ic=1,16 if(abs((calog1to3(ifil,lin)-cate(kcomp,ic))/cate(kcomp,ic)) nmodes - use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC, MODE_IDX_OMBC_INTMIX_COAT_AIT - use aerosoldef, only: lifeCycleNumberMedianRadius, l_dst_a2, l_dst_a3, l_bc_ai - use aerosoldef, only: getNumberOfTracersInMode, getTracerIndex, getCloudTracerIndex + use oslo_aero_share, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC, MODE_IDX_OMBC_INTMIX_COAT_AIT + use oslo_aero_share, only: lifeCycleNumberMedianRadius, l_dst_a2, l_dst_a3, l_bc_ai + use oslo_aero_share, only: getNumberOfTracersInMode, getTracerIndex, getCloudTracerIndex implicit none private diff --git a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 index f32cf11b2b..e4fb4ffb0e 100644 --- a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 @@ -22,9 +22,9 @@ module oslo_aero_ndrop use cam_logfile, only: iulog ! use oslo_aero_utils, only: calculateNumberMedianRadius - use aerosoldef, only: getNumberOfTracersInMode, getNumberOfAerosolTracers, getTracerIndex - use aerosoldef, only: getCloudTracerName, getCloudTracerIndex, getConstituentFraction - use aerosoldef, only: fillAerosolTracerList, fillInverseAerosolTracerList + use oslo_aero_share, only: getNumberOfTracersInMode, getNumberOfAerosolTracers, getTracerIndex + use oslo_aero_share, only: getCloudTracerName, getCloudTracerIndex, getConstituentFraction + use oslo_aero_share, only: fillAerosolTracerList, fillInverseAerosolTracerList use oslo_aero_params, only: nmodes, nbmodes use oslo_aero_const, only: smallNumber diff --git a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 index cb54a75051..7dc5b5d19f 100644 --- a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 @@ -40,8 +40,8 @@ module oslo_aero_nucleate_ice use cam_logfile, only: iulog use cam_abortutils, only: endrun ! - use aerosoldef, only: l_dst_a2, l_dst_a3, MODE_IDX_DST_A2, MODE_IDX_DST_A3, rhopart, qqcw_get_field - use aerosoldef, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC,MODE_IDX_OMBC_INTMIX_COAT_AIT + use oslo_aero_share, only: l_dst_a2, l_dst_a3, MODE_IDX_DST_A2, MODE_IDX_DST_A3, rhopart, qqcw_get_field + use oslo_aero_share, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC,MODE_IDX_OMBC_INTMIX_COAT_AIT use oslo_aero_const, only: volumeToNumber use oslo_aero_params, only: nmodes diff --git a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 index d400669140..c0ce77ff69 100644 --- a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 @@ -4,7 +4,7 @@ module oslo_aero_optical_params ! from the tables kcomp1.out-kcomp14.out. use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver, pverp + use ppgrid, only: pcols, pver, pverp use constituents, only: pcnst use cam_history, only: outfld use physconst, only: rair,pi @@ -16,7 +16,7 @@ module oslo_aero_optical_params use oslo_aero_sw_tables use oslo_aero_params use oslo_aero_const - use aerosoldef + use oslo_aero_share implicit none private diff --git a/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 b/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 index e40d093dc8..77944a529d 100644 --- a/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 @@ -12,8 +12,8 @@ module oslo_aero_seasalt ! use oslo_aero_const, only: volumeToNumber use oslo_aero_ocean, only: oslo_aero_opom_inq, oslo_aero_opom_emis - use aerosoldef, only: rhopart, l_om_ni, l_ss_a1, l_ss_a2, l_ss_a3 - use aerosoldef, only: MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 + use oslo_aero_share, only: rhopart, l_om_ni, l_ss_a1, l_ss_a2, l_ss_a3 + use oslo_aero_share, only: MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 implicit none private diff --git a/src/chemistry/oslo_aero/aerosoldef.F90 b/src/chemistry/oslo_aero/oslo_aero_share.F90 similarity index 92% rename from src/chemistry/oslo_aero/aerosoldef.F90 rename to src/chemistry/oslo_aero/oslo_aero_share.F90 index c0ae9dbc86..c73a18423d 100644 --- a/src/chemistry/oslo_aero/aerosoldef.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_share.F90 @@ -1,15 +1,16 @@ -module aerosoldef +module oslo_aero_share !--------------------------------------------------------------------------------- ! Module to set up register aerosols indexes, number of gas and particle ! species and their scavenging rates. Tables for humidity growth !--------------------------------------------------------------------------------- - use commondefinitions use shr_kind_mod, only: r8 => shr_kind_r8 - use mo_tracname, only: solsym use constituents, only: pcnst, cnst_name, cnst_get_ind + use mo_tracname, only: solsym use cam_abortutils, only: endrun + ! + use oslo_aero_params implicit none private ! Make default type private to the module @@ -27,43 +28,43 @@ module aerosoldef ! ! Public interfaces ! - public aero_register ! register consituents - public is_process_mode ! Check is an aerosol specie is a process mode - public isAerosol ! Check is specie is aerosol (i.e. gases get .FALSE. here) - public getTracerIndex - public getNumberOfTracersInMode - public getNumberOfBackgroundTracersInMode - public getCloudTracerIndex - public getCloudTracerIndexDirect - public getCloudTracerName - public chemistryIndex - public physicsIndex - public getDryDensity - public getConstituentFraction - public isTracerInMode - public fillAerosolTracerList - public getNumberOfAerosolTracers - public fillInverseAerosolTracerList - public qqcw_get_field - - integer, parameter, public :: MODE_IDX_BC_EXT_AC = 0 !Externally mixed BC accumulation mode - integer, parameter, public :: MODE_IDX_SO4SOA_AIT = 1 !SO4 and SOA in aitken mode, Created from 11 by growth (condensation) of SO4 - integer, parameter, public :: MODE_IDX_BC_AIT = 2 !Created from 12 by growth (condensation) SO4 - integer, parameter, public :: MODE_IDX_NOT_USED = 3 !Not used - integer, parameter, public :: MODE_IDX_OMBC_INTMIX_COAT_AIT = 4 !Created from 14 by growth (condensation) of SO4 and from cloud processing/wet-phas - integer, parameter, public :: MODE_IDX_SO4_AC = 5 !Accumulation mode SO4 (mode will have other comps added) - integer, parameter, public :: MODE_IDX_DST_A2 = 6 !Accumulation mode dust (mode will have other comps added) - integer, parameter, public :: MODE_IDX_DST_A3 = 7 !Coarse mode dust (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SS_A1 = 8 !Fine mode sea-salt (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SS_A2 = 9 !Accumulation mode sea-salt (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SS_A3 = 10 !Coarse mode sea-salt (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SO4SOA_NUC = 11 !SO4 and SOA nucleation mode - integer, parameter, public :: MODE_IDX_BC_NUC = 12 !BC nucleation mode - integer, parameter, public :: MODE_IDX_LUMPED_ORGANICS = 13 !not used in lifecycle, but some extra mass goes here when max. allowed LUT conc. are too small - integer, parameter, public :: MODE_IDX_OMBC_INTMIX_AIT = 14 !mix quickly formed in fire-plumes - - integer, parameter, public :: numberOfExternallyMixedModes = 4 !Modes 0;11-14 (13 is not used in lifecycle) - integer, parameter, public :: numberOfInternallyMIxedMOdes = 9 !Modes 1-10 (3 is not used in lifecycle) + public :: aero_register ! register consituents + public :: is_process_mode ! Check is an aerosol specie is a process mode + public :: isAerosol ! Check is specie is aerosol (i.e. gases get .FALSE. here) + public :: getTracerIndex + public :: getNumberOfTracersInMode + public :: getNumberOfBackgroundTracersInMode + public :: getCloudTracerIndex + public :: getCloudTracerIndexDirect + public :: getCloudTracerName + public :: chemistryIndex + public :: physicsIndex + public :: getDryDensity + public :: getConstituentFraction + public :: isTracerInMode + public :: fillAerosolTracerList + public :: getNumberOfAerosolTracers + public :: fillInverseAerosolTracerList + public :: qqcw_get_field + + integer, parameter, public :: MODE_IDX_BC_EXT_AC = 0 !Externally mixed BC accumulation mode + integer, parameter, public :: MODE_IDX_SO4SOA_AIT = 1 !SO4 and SOA in aitken mode, Created from 11 by growth (condensation) of SO4 + integer, parameter, public :: MODE_IDX_BC_AIT = 2 !Created from 12 by growth (condensation) SO4 + integer, parameter, public :: MODE_IDX_NOT_USED = 3 !Not used + integer, parameter, public :: MODE_IDX_OMBC_INTMIX_COAT_AIT = 4 !Created from 14 by growth (condensation) of SO4 and from cloud processing/wet-phas + integer, parameter, public :: MODE_IDX_SO4_AC = 5 !Accumulation mode SO4 (mode will have other comps added) + integer, parameter, public :: MODE_IDX_DST_A2 = 6 !Accumulation mode dust (mode will have other comps added) + integer, parameter, public :: MODE_IDX_DST_A3 = 7 !Coarse mode dust (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SS_A1 = 8 !Fine mode sea-salt (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SS_A2 = 9 !Accumulation mode sea-salt (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SS_A3 = 10 !Coarse mode sea-salt (mode will have other comps added) + integer, parameter, public :: MODE_IDX_SO4SOA_NUC = 11 !SO4 and SOA nucleation mode + integer, parameter, public :: MODE_IDX_BC_NUC = 12 !BC nucleation mode + integer, parameter, public :: MODE_IDX_LUMPED_ORGANICS = 13 !not used in lifecycle, but some extra mass goes here when max. allowed LUT conc. are too small + integer, parameter, public :: MODE_IDX_OMBC_INTMIX_AIT = 14 !mix quickly formed in fire-plumes + + integer, parameter, public :: numberOfExternallyMixedModes = 4 !Modes 0;11-14 (13 is not used in lifecycle) + integer, parameter, public :: numberOfInternallyMIxedMOdes = 9 !Modes 1-10 (3 is not used in lifecycle) integer, parameter, public :: numberOfProcessModeTracers = 6 integer, public, dimension(numberOfProcessModeTracers) :: tracerInProcessMode @@ -71,11 +72,21 @@ module aerosoldef !These tables describe how the tracers behave chemically integer, dimension(numberOfExternallyMixedModes), public :: externallyMixedMode = & - (/MODE_IDX_BC_EXT_AC,MODE_IDX_SO4SOA_NUC, MODE_IDX_BC_NUC, MODE_IDX_OMBC_INTMIX_AIT /) + (/MODE_IDX_BC_EXT_AC, & + MODE_IDX_SO4SOA_NUC, & + MODE_IDX_BC_NUC, & + MODE_IDX_OMBC_INTMIX_AIT /) + integer, dimension(numberOfInternallyMixedMOdes), public :: internallyMixedMode = & - (/MODE_IDX_SO4SOA_AIT, MODE_IDX_BC_AIT, MODE_IDX_OMBC_INTMIX_COAT_AIT & - ,MODE_IDX_SO4_AC, MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SS_A1 & - ,MODE_IDX_SS_A2, MODE_IDX_SS_A3 /) + (/MODE_IDX_SO4SOA_AIT, & + MODE_IDX_BC_AIT, & + MODE_IDX_OMBC_INTMIX_COAT_AIT, & + MODE_IDX_SO4_AC, & + MODE_IDX_DST_A2, & + MODE_IDX_DST_A3, & + MODE_IDX_SS_A1, & + MODE_IDX_SS_A2, & + MODE_IDX_SS_A3 /) ! species indices for individual camuio species integer,public :: l_so4_na, l_so4_a1, l_so4_a2, l_so4_ac @@ -185,7 +196,7 @@ subroutine aero_register integer :: idx_dum, l,m,mm logical :: isAlreadyCounted(pcnst) - ! register the species + ! register the species call cnst_get_ind('SO4_NA' ,l_so4_na, abort=.true.) !Aitken mode sulfate (growth from so4_n) call cnst_get_ind('SO4_A1' ,l_so4_a1, abort=.true.) !sulfate condensate (gas phase production) @@ -217,13 +228,13 @@ subroutine aero_register call cnst_get_ind('SOA_LV' ,l_soa_lv, abort=.true.) !Gas phase low volatile SOA call cnst_get_ind('SOA_SV' ,l_soa_sv, abort=.true.) !Gas phase semi volatile SOA - !gas phase h2so4 + ! gas phase h2so4 call cnst_get_ind('H2SO4' ,l_h2so4, abort=.true.) - !Register the tracers in modes + ! Register the tracers in modes call registerTracersInMode() - !Set the aerosol types + ! Set the aerosol types aerosolType(:) = -99 aerosolType(l_so4_na) = AEROSOL_TYPE_SULFATE aerosolType(l_so4_a1) = AEROSOL_TYPE_SULFATE @@ -249,7 +260,7 @@ subroutine aero_register rhopart(:)= 1000.0_r8 - !assign values based on aerosol type + ! assign values based on aerosol type do m=0,nmodes do l=1,n_tracers_in_mode(m) mm= getTracerIndex(m,l,.false.) @@ -331,7 +342,6 @@ end function getNumberOfAerosolTracers !============================================================================= function chemistryIndex(phys_index) RESULT (chemistryIndexOut) - implicit none integer, intent(in) :: phys_index integer :: chemistryIndexOut chemistryIndexOut = phys_index - imozart + 1 @@ -352,7 +362,6 @@ function isAerosol(phys_index) RESULT(answer) if(aerosolType(phys_index) .gt. 0)then answer = .TRUE. endif - return end function isAerosol !============================================================================= @@ -537,11 +546,10 @@ function isTracerInMode(modeIndex, constituentIndex)RESULT(answer) answer = .TRUE. endif enddo - return end function isTracerInMode !=============================================================================== - function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond,f_soa & + function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond, f_soa & ,Cam, f_acm, f_bcm, f_aqm, f_so4_condm,f_soam, constituentIndex,debugPrint ) RESULT(fraction) ! mass fraction real(r8), intent(in) :: CProcessModes @@ -558,7 +566,8 @@ function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond,f_soa real(r8), intent(in) :: f_soam integer, intent(in) :: constituentIndex logical, optional, intent(in) :: debugPrint - logical :: doPrint = .false. + + logical :: doPrint = .false. real(r8) :: fraction if(present(debugPrint))then @@ -691,6 +700,7 @@ function qqcw_get_field(pbuf, index) type(physics_buffer_desc), pointer :: pbuf(:) integer, intent(in) :: index + real(r8), pointer :: qqcw_get_field(:,:) nullify(qqcw_get_field) @@ -701,4 +711,4 @@ function qqcw_get_field(pbuf, index) end if end function qqcw_get_field -end module aerosoldef +end module oslo_aero_share diff --git a/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 b/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 index 45b9f6966b..a15e140a4a 100644 --- a/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 @@ -9,7 +9,7 @@ module oslo_aero_sox_cldaero use physconst, only: gravit use chem_mods, only: gas_pcnst ! - use aerosoldef, only: l_so4_a2, chemistryIndex + use oslo_aero_share, only: l_so4_a2, chemistryIndex implicit none private diff --git a/src/chemistry/oslo_aero/oslo_aero_utils.F90 b/src/chemistry/oslo_aero/oslo_aero_utils.F90 index b776a653aa..0660c0cfb0 100644 --- a/src/chemistry/oslo_aero/oslo_aero_utils.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_utils.F90 @@ -5,7 +5,7 @@ module oslo_aero_utils use physconst, only: pi use constituents, only: pcnst ! - use aerosoldef, only: getDryDensity, getNumberOfBackgroundTracersInMode, getTracerIndex + use oslo_aero_share, only: getDryDensity, getNumberOfBackgroundTracersInMode, getTracerIndex use oslo_aero_const, only: volumeToNumber, rbinMidPoint, rbinEdge, nBinsTab, nmodes use oslo_aero_params, only: originalNumberMedianRadius diff --git a/src/physics/cam_oslo/vertical_diffusion.F90 b/src/physics/cam_oslo/vertical_diffusion.F90 index a1477e3958..459aaba460 100644 --- a/src/physics/cam_oslo/vertical_diffusion.F90 +++ b/src/physics/cam_oslo/vertical_diffusion.F90 @@ -72,7 +72,9 @@ module vertical_diffusion use ref_pres, only : do_molec_diff, nbot_molec use phys_control, only : phys_getopts use time_manager, only : is_first_step - use aerosoldef, only: getNumberOfAerosolTracers, fillAerosolTracerList +#ifdef OSLO_AERO + use oslo_aero_share, only: getNumberOfAerosolTracers, fillAerosolTracerList +#endif implicit none private diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index 95d98eede1..b7727a174c 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -732,7 +732,7 @@ subroutine radiation_tend( & use physics_buffer, only: pbuf_get_index use oslo_aero_control, only: oslo_aero_getopts use oslo_aero_params - use aerosoldef + use oslo_aero_share #endif #ifdef OSLO_AERO From c3698ad6a403861980868e423f8f2ed99ee20e20 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 4 Sep 2023 12:02:14 +0200 Subject: [PATCH 52/71] updated vertical diffusion with #ifdefs --- src/physics/cam_oslo/vertical_diffusion.F90 | 2964 ++++++++++--------- 1 file changed, 1507 insertions(+), 1457 deletions(-) diff --git a/src/physics/cam_oslo/vertical_diffusion.F90 b/src/physics/cam_oslo/vertical_diffusion.F90 index 459aaba460..ec48a4cb6e 100644 --- a/src/physics/cam_oslo/vertical_diffusion.F90 +++ b/src/physics/cam_oslo/vertical_diffusion.F90 @@ -1,1501 +1,1551 @@ module vertical_diffusion - !----------------------------------------------------------------------------------------------------- ! - ! Module to compute vertical diffusion of momentum, moisture, trace constituents ! - ! and static energy. Separate modules compute ! - ! 1. stresses associated with turbulent flow over orography ! - ! ( turbulent mountain stress ) ! - ! 2. eddy diffusivities, including nonlocal tranport terms ! - ! 3. molecular diffusivities ! - ! Lastly, a implicit diffusion solver is called, and tendencies retrieved by ! - ! differencing the diffused and initial states. ! - ! ! - ! Calling sequence: ! - ! ! - ! vertical_diffusion_init Initializes vertical diffustion constants and modules ! - ! init_molec_diff Initializes molecular diffusivity module ! - ! init_eddy_diff Initializes eddy diffusivity module (includes PBL) ! - ! init_tms Initializes turbulent mountain stress module ! - ! init_vdiff Initializes diffusion solver module ! - ! vertical_diffusion_ts_init Time step initialization (only used for upper boundary condition) ! - ! vertical_diffusion_tend Computes vertical diffusion tendencies ! - ! compute_tms Computes turbulent mountain stresses ! - ! compute_eddy_diff Computes eddy diffusivities and countergradient terms ! - ! compute_vdiff Solves vertical diffusion equations, including molecular diffusivities ! - ! ! - !----------------------------------------------------------------------------------------------------- ! - ! Some notes on refactoring changes made in 2015, which were not quite finished. ! - ! ! - ! - eddy_diff_tend should really only have state, pbuf, and cam_in as inputs. The process of ! - ! removing these arguments, and referring to pbuf fields instead, is not complete. ! - ! ! - ! - compute_vdiff was intended to be split up into three components: ! - ! ! - ! 1. Diffusion of winds and heat ("U", "V", and "S" in the fieldlist object). ! - ! ! - ! 2. Turbulent diffusion of a single constituent ! - ! ! - ! 3. Molecular diffusion of a single constituent ! - ! ! - ! This reorganization would allow the three resulting functions to each use a simpler interface ! - ! than the current combined version, and possibly also remove the need to use the fieldlist ! - ! object at all. ! - ! ! - ! - The conditionals controlled by "do_pbl_diags" are somewhat scattered. It might be better to ! - ! pull out these diagnostic calculations and outfld calls into separate functions. ! - ! ! - !---------------------------Code history-------------------------------------------------------------- ! - ! J. Rosinski : Jun. 1992 ! - ! J. McCaa : Sep. 2004 ! - ! S. Park : Aug. 2006, Dec. 2008. Jan. 2010 ! - !----------------------------------------------------------------------------------------------------- ! - - use shr_kind_mod, only : r8 => shr_kind_r8, i4=> shr_kind_i4 - use ppgrid, only : pcols, pver, pverp - use constituents, only : pcnst - use diffusion_solver, only : vdiff_selector - use cam_abortutils, only : endrun - use error_messages, only : handle_errmsg - use physconst, only : & - cpair , & ! Specific heat of dry air - gravit , & ! Acceleration due to gravity - rair , & ! Gas constant for dry air - zvir , & ! rh2o/rair - 1 - latvap , & ! Latent heat of vaporization - latice , & ! Latent heat of fusion - karman , & ! von Karman constant - mwdry , & ! Molecular weight of dry air - avogad ! Avogadro's number - use cam_history, only : fieldname_len - use perf_mod - use cam_logfile, only : iulog - use ref_pres, only : do_molec_diff, nbot_molec - use phys_control, only : phys_getopts - use time_manager, only : is_first_step +!----------------------------------------------------------------------------------------------------- ! +! Module to compute vertical diffusion of momentum, moisture, trace constituents ! +! and static energy. Separate modules compute ! +! 1. stresses associated with turbulent flow over orography ! +! ( turbulent mountain stress ) ! +! 2. eddy diffusivities, including nonlocal tranport terms ! +! 3. molecular diffusivities ! +! Lastly, a implicit diffusion solver is called, and tendencies retrieved by ! +! differencing the diffused and initial states. ! +! ! +! Calling sequence: ! +! ! +! vertical_diffusion_init Initializes vertical diffustion constants and modules ! +! init_molec_diff Initializes molecular diffusivity module ! +! init_eddy_diff Initializes eddy diffusivity module (includes PBL) ! +! init_tms Initializes turbulent mountain stress module ! +! init_vdiff Initializes diffusion solver module ! +! vertical_diffusion_ts_init Time step initialization (only used for upper boundary condition) ! +! vertical_diffusion_tend Computes vertical diffusion tendencies ! +! compute_tms Computes turbulent mountain stresses ! +! compute_eddy_diff Computes eddy diffusivities and countergradient terms ! +! compute_vdiff Solves vertical diffusion equations, including molecular diffusivities ! +! ! +!----------------------------------------------------------------------------------------------------- ! +! Some notes on refactoring changes made in 2015, which were not quite finished. ! +! ! +! - eddy_diff_tend should really only have state, pbuf, and cam_in as inputs. The process of ! +! removing these arguments, and referring to pbuf fields instead, is not complete. ! +! ! +! - compute_vdiff was intended to be split up into three components: ! +! ! +! 1. Diffusion of winds and heat ("U", "V", and "S" in the fieldlist object). ! +! ! +! 2. Turbulent diffusion of a single constituent ! +! ! +! 3. Molecular diffusion of a single constituent ! +! ! +! This reorganization would allow the three resulting functions to each use a simpler interface ! +! than the current combined version, and possibly also remove the need to use the fieldlist ! +! object at all. ! +! ! +! - The conditionals controlled by "do_pbl_diags" are somewhat scattered. It might be better to ! +! pull out these diagnostic calculations and outfld calls into separate functions. ! +! ! +!---------------------------Code history-------------------------------------------------------------- ! +! J. Rosinski : Jun. 1992 ! +! J. McCaa : Sep. 2004 ! +! S. Park : Aug. 2006, Dec. 2008. Jan. 2010 ! +!----------------------------------------------------------------------------------------------------- ! + +use shr_kind_mod, only : r8 => shr_kind_r8, i4=> shr_kind_i4 +use ppgrid, only : pcols, pver, pverp +use constituents, only : pcnst +use diffusion_solver, only : vdiff_selector +use cam_abortutils, only : endrun +use error_messages, only : handle_errmsg +use physconst, only : & + cpair , & ! Specific heat of dry air + gravit , & ! Acceleration due to gravity + rair , & ! Gas constant for dry air + zvir , & ! rh2o/rair - 1 + latvap , & ! Latent heat of vaporization + latice , & ! Latent heat of fusion + karman , & ! von Karman constant + mwdry , & ! Molecular weight of dry air + avogad ! Avogadro's number +use cam_history, only : fieldname_len +use perf_mod +use cam_logfile, only : iulog +use ref_pres, only : do_molec_diff, nbot_molec +use phys_control, only : phys_getopts +use time_manager, only : is_first_step #ifdef OSLO_AERO use oslo_aero_share, only: getNumberOfAerosolTracers, fillAerosolTracerList #endif - implicit none - private - - ! ----------------- ! - ! Public interfaces ! - ! ----------------- ! - - public vd_readnl - public vd_register ! Register multi-time-level variables with physics buffer - public vertical_diffusion_init ! Initialization - public vertical_diffusion_ts_init ! Time step initialization (only used for upper boundary condition) - public vertical_diffusion_tend ! Full vertical diffusion routine - - ! ------------ ! - ! Private data ! - ! ------------ ! - - character(len=16) :: eddy_scheme ! Default set in phys_control.F90, use namelist to change - ! 'HB' = Holtslag and Boville (default) - ! 'HBR' = Holtslag and Boville and Rash - ! 'diag_TKE' = Bretherton and Park ( UW Moist Turbulence Scheme ) - logical, parameter :: wstarent = .true. ! Use wstar (.true.) or TKE (.false.) entrainment closure - ! ( when 'diag_TKE' scheme is selected ) - logical :: do_pseudocon_diff = .false. ! If .true., do pseudo-conservative variables diffusion - - character(len=16) :: shallow_scheme ! Shallow convection scheme - - type(vdiff_selector) :: fieldlist_wet ! Logical switches for moist mixing ratio diffusion - type(vdiff_selector) :: fieldlist_dry ! Logical switches for dry mixing ratio diffusion - type(vdiff_selector) :: fieldlist_molec ! Logical switches for molecular diffusion - integer :: tke_idx, kvh_idx, kvm_idx ! TKE and eddy diffusivity indices for fields in the physics buffer - integer :: kvt_idx ! Index for kinematic molecular conductivity - integer :: turbtype_idx, smaw_idx ! Turbulence type and instability functions - integer :: tauresx_idx, tauresy_idx ! Redisual stress for implicit surface stress - - character(len=fieldname_len) :: vdiffnam(pcnst) ! Names of vertical diffusion tendencies - integer :: ixcldice, ixcldliq ! Constituent indices for cloud liquid and ice water - integer :: ixnumice, ixnumliq - - integer :: pblh_idx, tpert_idx, qpert_idx - - ! pbuf fields for unicon - integer :: qtl_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on - integer :: qti_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on - - ! pbuf fields for tms - integer :: ksrftms_idx = -1 - integer :: tautmsx_idx = -1 - integer :: tautmsy_idx = -1 - - ! pbuf fields for blj (Beljaars) - integer :: dragblj_idx = -1 - integer :: taubljx_idx = -1 - integer :: taubljy_idx = -1 - - logical :: diff_cnsrv_mass_check ! do mass conservation check - logical :: do_iss ! switch for implicit turbulent surface stress - logical :: prog_modal_aero = .false. ! set true if prognostic modal aerosols are present - integer :: pmam_ncnst = 0 ! number of prognostic modal aerosol constituents - integer, allocatable :: pmam_cnst_idx(:) ! constituent indices of prognostic modal aerosols - - logical :: do_pbl_diags = .false. - logical :: waccmx_mode = .false. +implicit none +private +save + +! ----------------- ! +! Public interfaces ! +! ----------------- ! + +public vd_readnl +public vd_register ! Register multi-time-level variables with physics buffer +public vertical_diffusion_init ! Initialization +public vertical_diffusion_ts_init ! Time step initialization (only used for upper boundary condition) +public vertical_diffusion_tend ! Full vertical diffusion routine + +! ------------ ! +! Private data ! +! ------------ ! + +character(len=16) :: eddy_scheme ! Default set in phys_control.F90, use namelist to change +! 'HB' = Holtslag and Boville (default) +! 'HBR' = Holtslag and Boville and Rash +! 'diag_TKE' = Bretherton and Park ( UW Moist Turbulence Scheme ) +logical, parameter :: wstarent = .true. ! Use wstar (.true.) or TKE (.false.) entrainment closure +! ( when 'diag_TKE' scheme is selected ) +logical :: do_pseudocon_diff = .false. ! If .true., do pseudo-conservative variables diffusion + +character(len=16) :: shallow_scheme ! Shallow convection scheme + +type(vdiff_selector) :: fieldlist_wet ! Logical switches for moist mixing ratio diffusion +type(vdiff_selector) :: fieldlist_dry ! Logical switches for dry mixing ratio diffusion +type(vdiff_selector) :: fieldlist_molec ! Logical switches for molecular diffusion +integer :: tke_idx, kvh_idx, kvm_idx ! TKE and eddy diffusivity indices for fields in the physics buffer +integer :: kvt_idx ! Index for kinematic molecular conductivity +integer :: turbtype_idx, smaw_idx ! Turbulence type and instability functions +integer :: tauresx_idx, tauresy_idx ! Redisual stress for implicit surface stress + +character(len=fieldname_len) :: vdiffnam(pcnst) ! Names of vertical diffusion tendencies +integer :: ixcldice, ixcldliq ! Constituent indices for cloud liquid and ice water +integer :: ixnumice, ixnumliq + +integer :: pblh_idx, tpert_idx, qpert_idx + +! pbuf fields for unicon +integer :: qtl_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on +integer :: qti_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on + +! pbuf fields for tms +integer :: ksrftms_idx = -1 +integer :: tautmsx_idx = -1 +integer :: tautmsy_idx = -1 + +! pbuf fields for blj (Beljaars) +integer :: dragblj_idx = -1 +integer :: taubljx_idx = -1 +integer :: taubljy_idx = -1 + +logical :: diff_cnsrv_mass_check ! do mass conservation check +logical :: do_iss ! switch for implicit turbulent surface stress +logical :: prog_modal_aero = .false. ! set true if prognostic modal aerosols are present +integer :: pmam_ncnst = 0 ! number of prognostic modal aerosol constituents +integer, allocatable :: pmam_cnst_idx(:) ! constituent indices of prognostic modal aerosols + +logical :: do_pbl_diags = .false. +logical :: waccmx_mode = .false. -! =============================================================================== ! contains -! =============================================================================== ! - - subroutine vd_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: masterproc, masterprocid, mpi_logical, mpicom - use shr_log_mod, only: errMsg => shr_log_errMsg - use trb_mtn_stress_cam, only: trb_mtn_stress_readnl - use beljaars_drag_cam, only: beljaars_drag_readnl - use eddy_diff_cam, only: eddy_diff_readnl - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'vd_readnl' - - namelist /vert_diff_nl/ diff_cnsrv_mass_check, do_iss - !----------------------------------------------------------------------------- - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'vert_diff_nl', status=ierr) - if (ierr == 0) then - read(unitn, vert_diff_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if + ! =============================================================================== ! + ! ! + ! =============================================================================== ! +subroutine vd_readnl(nlfile) + + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: masterproc, masterprocid, mpi_logical, mpicom + use shr_log_mod, only: errMsg => shr_log_errMsg + use trb_mtn_stress_cam, only: trb_mtn_stress_readnl + use beljaars_drag_cam, only: beljaars_drag_readnl + use eddy_diff_cam, only: eddy_diff_readnl + + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + + ! Local variables + integer :: unitn, ierr + character(len=*), parameter :: subname = 'vd_readnl' + + namelist /vert_diff_nl/ diff_cnsrv_mass_check, do_iss + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'vert_diff_nl', status=ierr) + if (ierr == 0) then + read(unitn, vert_diff_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(subname // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if + + call mpi_bcast(diff_cnsrv_mass_check, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") + call mpi_bcast(do_iss, 1, mpi_logical, masterprocid, mpicom, ierr) + if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") + + ! Get eddy_scheme setting from phys_control. + call phys_getopts( eddy_scheme_out = eddy_scheme, & + shallow_scheme_out = shallow_scheme ) + + ! TMS reads its own namelist. + call trb_mtn_stress_readnl(nlfile) + + ! Beljaars reads its own namelist. + call beljaars_drag_readnl(nlfile) + + if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005' ) call eddy_diff_readnl(nlfile) + +end subroutine vd_readnl - call mpi_bcast(diff_cnsrv_mass_check, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") - call mpi_bcast(do_iss, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") +! =============================================================================== ! +! ! +! =============================================================================== ! - ! Get eddy_scheme setting from phys_control. - call phys_getopts( eddy_scheme_out = eddy_scheme, & - shallow_scheme_out = shallow_scheme ) +subroutine vd_register() - ! TMS reads its own namelist. - call trb_mtn_stress_readnl(nlfile) + !------------------------------------------------ ! + ! Register physics buffer fields and constituents ! + !------------------------------------------------ ! - ! Beljaars reads its own namelist. - call beljaars_drag_readnl(nlfile) + use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 + use trb_mtn_stress_cam, only : trb_mtn_stress_register + use beljaars_drag_cam, only : beljaars_drag_register + use eddy_diff_cam, only : eddy_diff_register - if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005' ) call eddy_diff_readnl(nlfile) + ! Add fields to physics buffer - end subroutine vd_readnl + ! kvt is used by gw_drag. only needs physpkg scope. + call pbuf_add_field('kvt', 'physpkg', dtype_r8, (/pcols,pverp/), kvt_idx) - ! =============================================================================== ! - subroutine vd_register() - !------------------------------------------------ ! - ! Register physics buffer fields and constituents ! - !------------------------------------------------ ! + if (eddy_scheme /= 'CLUBB_SGS') then + call pbuf_add_field('kvh', 'global', dtype_r8, (/pcols, pverp/), kvh_idx) + end if - use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 - use trb_mtn_stress_cam, only : trb_mtn_stress_register - use beljaars_drag_cam, only : beljaars_drag_register - use eddy_diff_cam, only : eddy_diff_register + call pbuf_add_field('kvm', 'global', dtype_r8, (/pcols, pverp/), kvm_idx ) + call pbuf_add_field('pblh', 'global', dtype_r8, (/pcols/), pblh_idx) + call pbuf_add_field('tke', 'global', dtype_r8, (/pcols, pverp/), tke_idx) + call pbuf_add_field('turbtype', 'global', dtype_i4, (/pcols, pverp/), turbtype_idx) + call pbuf_add_field('smaw', 'global', dtype_r8, (/pcols, pverp/), smaw_idx) - ! Add fields to physics buffer + call pbuf_add_field('tauresx', 'global', dtype_r8, (/pcols/), tauresx_idx) + call pbuf_add_field('tauresy', 'global', dtype_r8, (/pcols/), tauresy_idx) - ! kvt is used by gw_drag. only needs physpkg scope. - call pbuf_add_field('kvt', 'physpkg', dtype_r8, (/pcols,pverp/), kvt_idx) + call pbuf_add_field('tpert', 'global', dtype_r8, (/pcols/), tpert_idx) + call pbuf_add_field('qpert', 'global', dtype_r8, (/pcols,pcnst/), qpert_idx) + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_add_field('qtl_flx', 'global', dtype_r8, (/pcols, pverp/), qtl_flx_idx) + call pbuf_add_field('qti_flx', 'global', dtype_r8, (/pcols, pverp/), qti_flx_idx) + end if - if (eddy_scheme /= 'CLUBB_SGS') then - call pbuf_add_field('kvh', 'global', dtype_r8, (/pcols, pverp/), kvh_idx) - end if + ! diag_TKE fields + if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005') then + call eddy_diff_register() + end if - call pbuf_add_field('kvm', 'global', dtype_r8, (/pcols, pverp/), kvm_idx ) - call pbuf_add_field('pblh', 'global', dtype_r8, (/pcols/), pblh_idx) - call pbuf_add_field('tke', 'global', dtype_r8, (/pcols, pverp/), tke_idx) - call pbuf_add_field('turbtype', 'global', dtype_i4, (/pcols, pverp/), turbtype_idx) - call pbuf_add_field('smaw', 'global', dtype_r8, (/pcols, pverp/), smaw_idx) + ! TMS fields + call trb_mtn_stress_register() - call pbuf_add_field('tauresx', 'global', dtype_r8, (/pcols/), tauresx_idx) - call pbuf_add_field('tauresy', 'global', dtype_r8, (/pcols/), tauresy_idx) + ! Beljaars fields + call beljaars_drag_register() - call pbuf_add_field('tpert', 'global', dtype_r8, (/pcols/), tpert_idx) - call pbuf_add_field('qpert', 'global', dtype_r8, (/pcols,pcnst/), qpert_idx) +end subroutine vd_register - if (trim(shallow_scheme) == 'UNICON') then - call pbuf_add_field('qtl_flx', 'global', dtype_r8, (/pcols, pverp/), qtl_flx_idx) - call pbuf_add_field('qti_flx', 'global', dtype_r8, (/pcols, pverp/), qti_flx_idx) - end if +! =============================================================================== ! +! ! +! =============================================================================== ! - ! diag_TKE fields - if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005') then - call eddy_diff_register() - end if +subroutine vertical_diffusion_init(pbuf2d) + + !------------------------------------------------------------------! + ! Initialization of time independent fields for vertical diffusion ! + ! Calls initialization routines for subsidiary modules ! + !----------------------------------------------------------------- ! + + use cam_history, only : addfld, add_default, horiz_only + use cam_history, only : register_vector_field + use eddy_diff_cam, only : eddy_diff_init + use hb_diff, only : init_hb_diff + use molec_diff, only : init_molec_diff + use diffusion_solver, only : init_vdiff, new_fieldlist_vdiff, vdiff_select + use constituents, only : cnst_get_ind, cnst_get_type_byind, cnst_name, cnst_get_molec_byind + use spmd_utils, only : masterproc + use ref_pres, only : press_lim_idx, pref_mid + use physics_buffer, only : pbuf_set_field, pbuf_get_index, physics_buffer_desc + use rad_constituents, only : rad_cnst_get_info, rad_cnst_get_mode_num_idx, & + rad_cnst_get_mam_mmr_idx + use trb_mtn_stress_cam,only : trb_mtn_stress_init + use beljaars_drag_cam, only : beljaars_drag_init + use upper_bc, only : ubc_init + use phys_control, only : waccmx_is, fv_am_correction + + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + character(128) :: errstring ! Error status for init_vdiff + integer :: ntop_eddy ! Top interface level to which eddy vertical diffusion is applied ( = 1 ) + integer :: nbot_eddy ! Bottom interface level to which eddy vertical diffusion is applied ( = pver ) + integer :: k ! Vertical loop index + + real(r8), parameter :: ntop_eddy_pres = 1.e-5_r8 ! Pressure below which eddy diffusion is not done in WACCM-X. (Pa) + + integer :: im, l, m, nmodes, nspec + + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_eddy ! output the eddy variables + logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi + integer :: history_budget_histfile_num ! output history file number for budget fields + logical :: history_waccm ! output variables of interest for WACCM runs + + ! ----------------------------------------------------------------- ! + + if (masterproc) then + write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)' + end if + + ! Check to see if WACCM-X is on (currently we don't care whether the + ! ionosphere is on or not, since this neutral diffusion code is the + ! same either way). + waccmx_mode = waccmx_is('ionosphere') .or. waccmx_is('neutral') + + ! ----------------------------------------------------------------- ! + ! Get indices of cloud liquid and ice within the constituents array ! + ! ----------------------------------------------------------------- ! + + call cnst_get_ind( 'CLDLIQ', ixcldliq ) + call cnst_get_ind( 'CLDICE', ixcldice ) + ! These are optional; with the CAM4 microphysics, there are no number + ! constituents. + call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. ) + call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. ) + + ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. + call phys_getopts(prog_modal_aero_out=prog_modal_aero) - ! TMS fields - call trb_mtn_stress_register() +#ifdef OSLO_AERO + prog_modal_aero = .TRUE. + pmam_ncnst = getNumberOfAerosolTracers() + allocate(pmam_cnst_idx(pmam_ncnst)) + call fillAerosolTracerList(pmam_cnst_idx) +#else + !NOTE THAT THIS BREAKS THE CONCEPT OF KEEPEING MAM-AEROSOLS OUT OF + !DIFFUSION, BUT IF YOU ARE USING MAM, YOU SHOULD NOT BEE HERE ANYWAY!! + ! First need total number of mam constituents + call rad_cnst_get_info(0, nmodes=nmodes) + do m = 1, nmodes + call rad_cnst_get_info(0, m, nspec=nspec) + pmam_ncnst = pmam_ncnst + 1 + nspec + end do + + allocate(pmam_cnst_idx(pmam_ncnst)) + + ! Get the constituent indicies + im = 1 + do m = 1, nmodes + call rad_cnst_get_mode_num_idx(m, pmam_cnst_idx(im)) + im = im + 1 + call rad_cnst_get_info(0, m, nspec=nspec) + do l = 1, nspec + call rad_cnst_get_mam_mmr_idx(m, l, pmam_cnst_idx(im)) + im = im + 1 + end do + end do + end if +#endif - ! Beljaars fields - call beljaars_drag_register() + ! Initialize upper boundary condition module + + call ubc_init() + + ! ---------------------------------------------------------------------------------------- ! + ! Initialize molecular diffusivity module ! + ! Note that computing molecular diffusivities is a trivial expense, but constituent ! + ! diffusivities depend on their molecular weights. Decomposing the diffusion matrix ! + ! for each constituent is a needless expense unless the diffusivity is significant. ! + ! ---------------------------------------------------------------------------------------- ! + + !---------------------------------------------------------------------------------------- + ! Initialize molecular diffusion and get top and bottom molecular diffusion limits + !---------------------------------------------------------------------------------------- + + if( do_molec_diff ) then + call init_molec_diff( r8, pcnst, mwdry, avogad, & + errstring) + + call handle_errmsg(errstring, subname="init_molec_diff") + + call addfld( 'TTPXMLC', horiz_only, 'A', 'K/S', 'Top interf. temp. flux: molec. viscosity' ) + if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NBOT_MOLEC =', nbot_molec + end if + + ! ---------------------------------- ! + ! Initialize eddy diffusivity module ! + ! ---------------------------------- ! + + ! ntop_eddy must be 1 or <= nbot_molec + ! Currently, it is always 1 except for WACCM-X. + if ( waccmx_mode ) then + ntop_eddy = press_lim_idx(ntop_eddy_pres, top=.true.) + else + ntop_eddy = 1 + end if + nbot_eddy = pver + + if (masterproc) write(iulog, fmt='(a,i3,5x,a,i3)') 'NTOP_EDDY =', ntop_eddy, 'NBOT_EDDY =', nbot_eddy + + select case ( eddy_scheme ) + case ( 'diag_TKE', 'SPCAM_m2005' ) + if( masterproc ) write(iulog,*) & + 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park' + call eddy_diff_init(pbuf2d, ntop_eddy, nbot_eddy) + case ( 'HB', 'HBR', 'SPCAM_sam1mom') + if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: Holtslag and Boville' + call init_hb_diff(gravit, cpair, ntop_eddy, nbot_eddy, pref_mid, & + karman, eddy_scheme) + call addfld('HB_ri', (/ 'lev' /), 'A', 'no', 'Richardson Number (HB Scheme), I' ) + case ( 'CLUBB_SGS' ) + do_pbl_diags = .true. + end select + + ! ------------------------------------------- ! + ! Initialize turbulent mountain stress module ! + ! ------------------------------------------- ! + + call trb_mtn_stress_init() + + ! ----------------------------------- ! + ! Initialize Beljaars SGO drag module ! + ! ----------------------------------- ! + + call beljaars_drag_init() + + ! ---------------------------------- ! + ! Initialize diffusion solver module ! + ! ---------------------------------- ! + + call init_vdiff(r8, iulog, rair, cpair, gravit, do_iss, fv_am_correction, errstring) + call handle_errmsg(errstring, subname="init_vdiff") + + ! Use fieldlist_wet to select the fields which will be diffused using moist mixing ratios ( all by default ) + ! Use fieldlist_dry to select the fields which will be diffused using dry mixing ratios. + + fieldlist_wet = new_fieldlist_vdiff( pcnst) + fieldlist_dry = new_fieldlist_vdiff( pcnst) + fieldlist_molec = new_fieldlist_vdiff( pcnst) + + if( vdiff_select( fieldlist_wet, 'u' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'u' ) ) + if( vdiff_select( fieldlist_wet, 'v' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'v' ) ) + if( vdiff_select( fieldlist_wet, 's' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 's' ) ) + + constit_loop: do k = 1, pcnst + + if (prog_modal_aero) then + ! Do not diffuse droplet number - treated in dropmixnuc + if (k == ixnumliq) cycle constit_loop + ! Don't diffuse modal aerosol - treated in dropmixnuc + do m = 1, pmam_ncnst + if (k == pmam_cnst_idx(m)) cycle constit_loop + enddo + end if + + if( cnst_get_type_byind(k) .eq. 'wet' ) then + if( vdiff_select( fieldlist_wet, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'q', k ) ) + else + if( vdiff_select( fieldlist_dry, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_dry, 'q', k ) ) + endif + + ! ----------------------------------------------- ! + ! Select constituents for molecular diffusion ! + ! ----------------------------------------------- ! + if ( cnst_get_molec_byind(k) .eq. 'minor' ) then + if( vdiff_select(fieldlist_molec,'q',k) .ne. '' ) call endrun( vdiff_select( fieldlist_molec,'q',k ) ) + endif + + end do constit_loop + + ! ------------------------ ! + ! Diagnostic output fields ! + ! ------------------------ ! + + do k = 1, pcnst + vdiffnam(k) = 'VD'//cnst_name(k) + if( k == 1 ) vdiffnam(k) = 'VD01' !**** compatibility with old code **** + call addfld( vdiffnam(k), (/ 'lev' /), 'A', 'kg/kg/s', 'Vertical diffusion of '//cnst_name(k) ) + end do + + if (.not. do_pbl_diags) then + call addfld( 'PBLH' , horiz_only , 'A', 'm' , 'PBL height' ) + call addfld( 'QT' , (/ 'lev' /) , 'A', 'kg/kg' , 'Total water mixing ratio' ) + call addfld( 'SL' , (/ 'lev' /) , 'A', 'J/kg' , 'Liquid water static energy' ) + call addfld( 'SLV' , (/ 'lev' /) , 'A', 'J/kg' , 'Liq wat virtual static energy' ) + call addfld( 'SLFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Liquid static energy flux' ) + call addfld( 'QTFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Total water flux' ) + call addfld( 'TKE' , (/ 'ilev' /) , 'A', 'm2/s2' , 'Turbulent Kinetic Energy' ) + call addfld( 'TPERT' , horiz_only , 'A', 'K' , 'Perturbation temperature (eddies in PBL)' ) + call addfld( 'QPERT' , horiz_only , 'A', 'kg/kg' , 'Perturbation specific humidity (eddies in PBL)' ) + + call addfld( 'UFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Zonal momentum flux' ) + call addfld( 'VFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Meridional momentm flux' ) + call register_vector_field('UFLX', 'VFLX') + end if + + call addfld( 'USTAR' , horiz_only , 'A', 'm/s' , 'Surface friction velocity' ) + call addfld( 'KVH' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (heat/moisture)' ) + call addfld( 'KVM' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (momentum)' ) + call addfld( 'KVT' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion kinematic molecular conductivity') + call addfld( 'CGS' , (/ 'ilev' /) , 'A', 's/m2' , 'Counter-gradient coeff on surface kinematic fluxes' ) + call addfld( 'DTVKE' , (/ 'lev' /) , 'A', 'K/s' , 'dT/dt vertical diffusion KE dissipation' ) + call addfld( 'DTV' , (/ 'lev' /) , 'A', 'K/s' , 'T vertical diffusion' ) + call addfld( 'DUV' , (/ 'lev' /) , 'A', 'm/s2' , 'U vertical diffusion' ) + call addfld( 'DVV' , (/ 'lev' /) , 'A', 'm/s2' , 'V vertical diffusion' ) + + ! ---------------------------------------------------------------------------- ! + ! Below ( with '_PBL') are for detailed analysis of UW Moist Turbulence Scheme ! + ! ---------------------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + call addfld( 'qt_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_prePBL' ) + call addfld( 'sl_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_prePBL' ) + call addfld( 'slv_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_prePBL' ) + call addfld( 'u_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_prePBL' ) + call addfld( 'v_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_prePBL' ) + call addfld( 'qv_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_prePBL' ) + call addfld( 'ql_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_prePBL' ) + call addfld( 'qi_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_prePBL' ) + call addfld( 't_pre_PBL', (/ 'lev' /) , 'A', 'K' , 't_prePBL' ) + call addfld( 'rh_pre_PBL', (/ 'lev' /) , 'A', '%' , 'rh_prePBL' ) + + call addfld( 'qt_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_afterPBL' ) + call addfld( 'sl_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_afterPBL' ) + call addfld( 'slv_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_afterPBL' ) + call addfld( 'u_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_afterPBL' ) + call addfld( 'v_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_afterPBL' ) + call addfld( 'qv_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_afterPBL' ) + call addfld( 'ql_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_afterPBL' ) + call addfld( 'qi_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_afterPBL' ) + call addfld( 't_aft_PBL', (/ 'lev' /) , 'A', 'K' , 't_afterPBL' ) + call addfld( 'rh_aft_PBL', (/ 'lev' /) , 'A', '%' , 'rh_afterPBL' ) + + call addfld( 'slflx_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl flux by PBL' ) + call addfld( 'qtflx_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt flux by PBL' ) + call addfld( 'uflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u flux by PBL' ) + call addfld( 'vflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v flux by PBL' ) + + call addfld( 'slflx_cg_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl_cg flux by PBL' ) + call addfld( 'qtflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt_cg flux by PBL' ) + call addfld( 'uflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u_cg flux by PBL' ) + call addfld( 'vflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v_cg flux by PBL' ) + + call addfld( 'qtten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qt tendency by PBL' ) + call addfld( 'slten_PBL', (/ 'lev' /) , 'A', 'J/kg/s' , 'sl tendency by PBL' ) + call addfld( 'uten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'u tendency by PBL' ) + call addfld( 'vten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'v tendency by PBL' ) + call addfld( 'qvten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qv tendency by PBL' ) + call addfld( 'qlten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'ql tendency by PBL' ) + call addfld( 'qiten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qi tendency by PBL' ) + call addfld( 'tten_PBL', (/ 'lev' /) , 'A', 'K/s' , 'T tendency by PBL' ) + call addfld( 'rhten_PBL', (/ 'lev' /) , 'A', '%/s' , 'RH tendency by PBL' ) + + end if + + call addfld ('ustar',horiz_only, 'A', ' ',' ') + call addfld ('obklen',horiz_only, 'A', ' ',' ') + + ! ---------------------------- + ! determine default variables + ! ---------------------------- + + call phys_getopts( history_amwg_out = history_amwg, & + history_eddy_out = history_eddy, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num, & + history_waccm_out = history_waccm) + + if (history_amwg) then + call add_default( vdiffnam(1), 1, ' ' ) + call add_default( 'DTV' , 1, ' ' ) + if (.not. do_pbl_diags) then + call add_default( 'PBLH' , 1, ' ' ) + end if + endif + + if (history_eddy) then + call add_default( 'UFLX ', 1, ' ' ) + call add_default( 'VFLX ', 1, ' ' ) + endif + + if( history_budget ) then + call add_default( vdiffnam(ixcldliq), history_budget_histfile_num, ' ' ) + call add_default( vdiffnam(ixcldice), history_budget_histfile_num, ' ' ) +#ifdef OSLO_AERO + call add_default( vdiffnam(ixnumliq), history_budget_histfile_num, ' ' ) + call add_default( vdiffnam(ixnumice), history_budget_histfile_num, ' ' ) +#endif + if( history_budget_histfile_num > 1 ) then + call add_default( vdiffnam(1), history_budget_histfile_num, ' ' ) + call add_default( 'DTV' , history_budget_histfile_num, ' ' ) + end if + end if + + if ( history_waccm ) then + if (do_molec_diff) then + call add_default ( 'TTPXMLC', 1, ' ' ) + end if + call add_default( 'DUV' , 1, ' ' ) + call add_default( 'DVV' , 1, ' ' ) + end if + ! ---------------------------- + + + ksrftms_idx = pbuf_get_index('ksrftms') + tautmsx_idx = pbuf_get_index('tautmsx') + tautmsy_idx = pbuf_get_index('tautmsy') + + dragblj_idx = pbuf_get_index('dragblj') + taubljx_idx = pbuf_get_index('taubljx') + taubljy_idx = pbuf_get_index('taubljy') + + if (eddy_scheme == 'CLUBB_SGS') then + kvh_idx = pbuf_get_index('kvh') + end if + + ! Initialization of some pbuf fields + if (is_first_step()) then + ! Initialization of pbuf fields tke, kvh, kvm are done in phys_inidat + call pbuf_set_field(pbuf2d, turbtype_idx, 0 ) + call pbuf_set_field(pbuf2d, smaw_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tauresx_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, tauresy_idx, 0.0_r8) + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_set_field(pbuf2d, qtl_flx_idx, 0.0_r8) + call pbuf_set_field(pbuf2d, qti_flx_idx, 0.0_r8) + end if + end if + +end subroutine vertical_diffusion_init - end subroutine vd_register +! =============================================================================== ! +! ! +! =============================================================================== ! - ! =============================================================================== ! - subroutine vertical_diffusion_init(pbuf2d) - - !------------------------------------------------------------------! - ! Initialization of time independent fields for vertical diffusion ! - ! Calls initialization routines for subsidiary modules ! - !----------------------------------------------------------------- ! - - use cam_history, only : addfld, add_default, horiz_only - use cam_history, only : register_vector_field - use eddy_diff_cam, only : eddy_diff_init - use hb_diff, only : init_hb_diff - use molec_diff, only : init_molec_diff - use diffusion_solver, only : init_vdiff, new_fieldlist_vdiff, vdiff_select - use constituents, only : cnst_get_ind, cnst_get_type_byind, cnst_name, cnst_get_molec_byind - use spmd_utils, only : masterproc - use ref_pres, only : press_lim_idx, pref_mid - use physics_buffer, only : pbuf_set_field, pbuf_get_index, physics_buffer_desc - use rad_constituents, only : rad_cnst_get_info, rad_cnst_get_mode_num_idx, & - rad_cnst_get_mam_mmr_idx - use trb_mtn_stress_cam,only : trb_mtn_stress_init - use beljaars_drag_cam, only : beljaars_drag_init - use upper_bc, only : ubc_init - use phys_control, only : waccmx_is, fv_am_correction - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - character(128) :: errstring ! Error status for init_vdiff - integer :: ntop_eddy ! Top interface level to which eddy vertical diffusion is applied ( = 1 ) - integer :: nbot_eddy ! Bottom interface level to which eddy vertical diffusion is applied ( = pver ) - integer :: k ! Vertical loop index - - real(r8), parameter :: ntop_eddy_pres = 1.e-5_r8 ! Pressure below which eddy diffusion is not done in WACCM-X. (Pa) - - integer :: im, l, m, nmodes, nspec - - logical :: history_amwg ! output the variables used by the AMWG diag package - logical :: history_eddy ! output the eddy variables - logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi - integer :: history_budget_histfile_num ! output history file number for budget fields - logical :: history_waccm ! output variables of interest for WACCM runs - - ! ----------------------------------------------------------------- ! - - if (masterproc) then - write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)' - end if - - ! Check to see if WACCM-X is on (currently we don't care whether the - ! ionosphere is on or not, since this neutral diffusion code is the - ! same either way). - waccmx_mode = waccmx_is('ionosphere') .or. waccmx_is('neutral') - - ! ----------------------------------------------------------------- ! - ! Get indices of cloud liquid and ice within the constituents array ! - ! ----------------------------------------------------------------- ! - - call cnst_get_ind( 'CLDLIQ', ixcldliq ) - call cnst_get_ind( 'CLDICE', ixcldice ) - ! These are optional; with the CAM4 microphysics, there are no number - ! constituents. - call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. ) - call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. ) - - ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. - call phys_getopts(prog_modal_aero_out=prog_modal_aero) - prog_modal_aero = .TRUE. - if (prog_modal_aero) then - - ! Get the constituent indices of the number and mass mixing ratios of the modal - ! aerosols. - ! - ! N.B. - This implementation assumes that the prognostic modal aerosols are - ! impacting the climate calculation (i.e., can get info from list 0). - ! - pmam_ncnst = getNumberOfAerosolTracers() - allocate(pmam_cnst_idx(pmam_ncnst)) - call fillAerosolTracerList(pmam_cnst_idx) - end if - - ! Initialize upper boundary condition module - - call ubc_init() - - ! ---------------------------------------------------------------------------------------- ! - ! Initialize molecular diffusivity module ! - ! Note that computing molecular diffusivities is a trivial expense, but constituent ! - ! diffusivities depend on their molecular weights. Decomposing the diffusion matrix ! - ! for each constituent is a needless expense unless the diffusivity is significant. ! - ! ---------------------------------------------------------------------------------------- ! - - !---------------------------------------------------------------------------------------- - ! Initialize molecular diffusion and get top and bottom molecular diffusion limits - !---------------------------------------------------------------------------------------- - - if( do_molec_diff ) then - call init_molec_diff( r8, pcnst, mwdry, avogad, & - errstring) - - call handle_errmsg(errstring, subname="init_molec_diff") - - call addfld( 'TTPXMLC', horiz_only, 'A', 'K/S', 'Top interf. temp. flux: molec. viscosity' ) - if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NBOT_MOLEC =', nbot_molec - end if - - ! ---------------------------------- ! - ! Initialize eddy diffusivity module ! - ! ---------------------------------- ! - - ! ntop_eddy must be 1 or <= nbot_molec - ! Currently, it is always 1 except for WACCM-X. - if ( waccmx_mode ) then - ntop_eddy = press_lim_idx(ntop_eddy_pres, top=.true.) - else - ntop_eddy = 1 - end if - nbot_eddy = pver - - if (masterproc) write(iulog, fmt='(a,i3,5x,a,i3)') 'NTOP_EDDY =', ntop_eddy, 'NBOT_EDDY =', nbot_eddy - - select case ( eddy_scheme ) - case ( 'diag_TKE', 'SPCAM_m2005' ) - if( masterproc ) write(iulog,*) & - 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park' - call eddy_diff_init(pbuf2d, ntop_eddy, nbot_eddy) - case ( 'HB', 'HBR', 'SPCAM_sam1mom') - if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: Holtslag and Boville' - call init_hb_diff(gravit, cpair, ntop_eddy, nbot_eddy, pref_mid, & - karman, eddy_scheme) - call addfld('HB_ri', (/ 'lev' /), 'A', 'no', 'Richardson Number (HB Scheme), I' ) - case ( 'CLUBB_SGS' ) - do_pbl_diags = .true. - end select - - ! ------------------------------------------- ! - ! Initialize turbulent mountain stress module ! - ! ------------------------------------------- ! - - call trb_mtn_stress_init() - - ! ----------------------------------- ! - ! Initialize Beljaars SGO drag module ! - ! ----------------------------------- ! - - call beljaars_drag_init() - - ! ---------------------------------- ! - ! Initialize diffusion solver module ! - ! ---------------------------------- ! - - call init_vdiff(r8, iulog, rair, cpair, gravit, do_iss, fv_am_correction, errstring) - call handle_errmsg(errstring, subname="init_vdiff") - - ! Use fieldlist_wet to select the fields which will be diffused using moist mixing ratios ( all by default ) - ! Use fieldlist_dry to select the fields which will be diffused using dry mixing ratios. - - fieldlist_wet = new_fieldlist_vdiff( pcnst) - fieldlist_dry = new_fieldlist_vdiff( pcnst) - fieldlist_molec = new_fieldlist_vdiff( pcnst) - - if( vdiff_select( fieldlist_wet, 'u' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'u' ) ) - if( vdiff_select( fieldlist_wet, 'v' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'v' ) ) - if( vdiff_select( fieldlist_wet, 's' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 's' ) ) - - constit_loop: do k = 1, pcnst - - if (prog_modal_aero) then - ! Do not diffuse droplet number - treated in dropmixnuc - if (k == ixnumliq) cycle constit_loop - ! Don't diffuse modal aerosol - treated in dropmixnuc - do m = 1, pmam_ncnst - if (k == pmam_cnst_idx(m)) cycle constit_loop - enddo - end if - - if( cnst_get_type_byind(k) .eq. 'wet' ) then - if( vdiff_select( fieldlist_wet, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'q', k ) ) - else - if( vdiff_select( fieldlist_dry, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_dry, 'q', k ) ) - endif - - ! ----------------------------------------------- ! - ! Select constituents for molecular diffusion ! - ! ----------------------------------------------- ! - if ( cnst_get_molec_byind(k) .eq. 'minor' ) then - if( vdiff_select(fieldlist_molec,'q',k) .ne. '' ) call endrun( vdiff_select( fieldlist_molec,'q',k ) ) - endif - - end do constit_loop - - ! ------------------------ ! - ! Diagnostic output fields ! - ! ------------------------ ! - - do k = 1, pcnst - vdiffnam(k) = 'VD'//cnst_name(k) - if( k == 1 ) vdiffnam(k) = 'VD01' !**** compatibility with old code **** - call addfld( vdiffnam(k), (/ 'lev' /), 'A', 'kg/kg/s', 'Vertical diffusion of '//cnst_name(k) ) - end do - - if (.not. do_pbl_diags) then - call addfld( 'PBLH' , horiz_only , 'A', 'm' , 'PBL height' ) - call addfld( 'QT' , (/ 'lev' /) , 'A', 'kg/kg' , 'Total water mixing ratio' ) - call addfld( 'SL' , (/ 'lev' /) , 'A', 'J/kg' , 'Liquid water static energy' ) - call addfld( 'SLV' , (/ 'lev' /) , 'A', 'J/kg' , 'Liq wat virtual static energy' ) - call addfld( 'SLFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Liquid static energy flux' ) - call addfld( 'QTFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Total water flux' ) - call addfld( 'TKE' , (/ 'ilev' /) , 'A', 'm2/s2' , 'Turbulent Kinetic Energy' ) - call addfld( 'TPERT' , horiz_only , 'A', 'K' , 'Perturbation temperature (eddies in PBL)' ) - call addfld( 'QPERT' , horiz_only , 'A', 'kg/kg' , 'Perturbation specific humidity (eddies in PBL)' ) - - call addfld( 'UFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Zonal momentum flux' ) - call addfld( 'VFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Meridional momentm flux' ) - call register_vector_field('UFLX', 'VFLX') - end if - - call addfld( 'USTAR' , horiz_only , 'A', 'm/s' , 'Surface friction velocity' ) - call addfld( 'KVH' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (heat/moisture)' ) - call addfld( 'KVM' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (momentum)' ) - call addfld( 'KVT' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion kinematic molecular conductivity') - call addfld( 'CGS' , (/ 'ilev' /) , 'A', 's/m2' , 'Counter-gradient coeff on surface kinematic fluxes' ) - call addfld( 'DTVKE' , (/ 'lev' /) , 'A', 'K/s' , 'dT/dt vertical diffusion KE dissipation' ) - call addfld( 'DTV' , (/ 'lev' /) , 'A', 'K/s' , 'T vertical diffusion' ) - call addfld( 'DUV' , (/ 'lev' /) , 'A', 'm/s2' , 'U vertical diffusion' ) - call addfld( 'DVV' , (/ 'lev' /) , 'A', 'm/s2' , 'V vertical diffusion' ) - - ! ---------------------------------------------------------------------------- ! - ! Below ( with '_PBL') are for detailed analysis of UW Moist Turbulence Scheme ! - ! ---------------------------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - call addfld( 'qt_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_prePBL' ) - call addfld( 'sl_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_prePBL' ) - call addfld( 'slv_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_prePBL' ) - call addfld( 'u_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_prePBL' ) - call addfld( 'v_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_prePBL' ) - call addfld( 'qv_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_prePBL' ) - call addfld( 'ql_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_prePBL' ) - call addfld( 'qi_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_prePBL' ) - call addfld( 't_pre_PBL', (/ 'lev' /) , 'A', 'K' , 't_prePBL' ) - call addfld( 'rh_pre_PBL', (/ 'lev' /) , 'A', '%' , 'rh_prePBL' ) - - call addfld( 'qt_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_afterPBL' ) - call addfld( 'sl_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_afterPBL' ) - call addfld( 'slv_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_afterPBL' ) - call addfld( 'u_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_afterPBL' ) - call addfld( 'v_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_afterPBL' ) - call addfld( 'qv_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_afterPBL' ) - call addfld( 'ql_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_afterPBL' ) - call addfld( 'qi_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_afterPBL' ) - call addfld( 't_aft_PBL', (/ 'lev' /) , 'A', 'K' , 't_afterPBL' ) - call addfld( 'rh_aft_PBL', (/ 'lev' /) , 'A', '%' , 'rh_afterPBL' ) - - call addfld( 'slflx_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl flux by PBL' ) - call addfld( 'qtflx_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt flux by PBL' ) - call addfld( 'uflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u flux by PBL' ) - call addfld( 'vflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v flux by PBL' ) - - call addfld( 'slflx_cg_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl_cg flux by PBL' ) - call addfld( 'qtflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt_cg flux by PBL' ) - call addfld( 'uflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u_cg flux by PBL' ) - call addfld( 'vflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v_cg flux by PBL' ) - - call addfld( 'qtten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qt tendency by PBL' ) - call addfld( 'slten_PBL', (/ 'lev' /) , 'A', 'J/kg/s' , 'sl tendency by PBL' ) - call addfld( 'uten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'u tendency by PBL' ) - call addfld( 'vten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'v tendency by PBL' ) - call addfld( 'qvten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qv tendency by PBL' ) - call addfld( 'qlten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'ql tendency by PBL' ) - call addfld( 'qiten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qi tendency by PBL' ) - call addfld( 'tten_PBL', (/ 'lev' /) , 'A', 'K/s' , 'T tendency by PBL' ) - call addfld( 'rhten_PBL', (/ 'lev' /) , 'A', '%/s' , 'RH tendency by PBL' ) - - end if - - call addfld ('ustar',horiz_only, 'A', ' ',' ') - call addfld ('obklen',horiz_only, 'A', ' ',' ') - - ! ---------------------------- - ! determine default variables - ! ---------------------------- - - call phys_getopts( history_amwg_out = history_amwg, & - history_eddy_out = history_eddy, & - history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num, & - history_waccm_out = history_waccm) - - if (history_amwg) then - call add_default( vdiffnam(1), 1, ' ' ) - call add_default( 'DTV' , 1, ' ' ) - if (.not. do_pbl_diags) then - call add_default( 'PBLH' , 1, ' ' ) - end if - endif - - if (history_eddy) then - call add_default( 'UFLX ', 1, ' ' ) - call add_default( 'VFLX ', 1, ' ' ) - endif - - if( history_budget ) then - call add_default( vdiffnam(ixcldliq), history_budget_histfile_num, ' ' ) - call add_default( vdiffnam(ixcldice), history_budget_histfile_num, ' ' ) - !AL - call add_default( vdiffnam(ixnumliq), history_budget_histfile_num, ' ' ) - call add_default( vdiffnam(ixnumice), history_budget_histfile_num, ' ' ) - !AL - if( history_budget_histfile_num > 1 ) then - call add_default( vdiffnam(1), history_budget_histfile_num, ' ' ) - call add_default( 'DTV' , history_budget_histfile_num, ' ' ) - end if - end if - - if ( history_waccm ) then - if (do_molec_diff) then - call add_default ( 'TTPXMLC', 1, ' ' ) - end if - call add_default( 'DUV' , 1, ' ' ) - call add_default( 'DVV' , 1, ' ' ) - end if - ! ---------------------------- - - - ksrftms_idx = pbuf_get_index('ksrftms') - tautmsx_idx = pbuf_get_index('tautmsx') - tautmsy_idx = pbuf_get_index('tautmsy') - - dragblj_idx = pbuf_get_index('dragblj') - taubljx_idx = pbuf_get_index('taubljx') - taubljy_idx = pbuf_get_index('taubljy') - - if (eddy_scheme == 'CLUBB_SGS') then - kvh_idx = pbuf_get_index('kvh') - end if - - ! Initialization of some pbuf fields - if (is_first_step()) then - ! Initialization of pbuf fields tke, kvh, kvm are done in phys_inidat - call pbuf_set_field(pbuf2d, turbtype_idx, 0 ) - call pbuf_set_field(pbuf2d, smaw_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, tauresx_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, tauresy_idx, 0.0_r8) - if (trim(shallow_scheme) == 'UNICON') then - call pbuf_set_field(pbuf2d, qtl_flx_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, qti_flx_idx, 0.0_r8) - end if - end if - - end subroutine vertical_diffusion_init +subroutine vertical_diffusion_ts_init( pbuf2d, state ) - ! =============================================================================== ! - subroutine vertical_diffusion_ts_init( pbuf2d, state ) + !-------------------------------------------------------------- ! + ! Timestep dependent setting, ! + ! At present only invokes upper bc code ! + !-------------------------------------------------------------- ! + use upper_bc, only : ubc_timestep_init + use physics_types , only : physics_state + use ppgrid , only : begchunk, endchunk - !-------------------------------------------------------------- ! - ! Timestep dependent setting, ! - ! At present only invokes upper bc code ! - !-------------------------------------------------------------- ! - use upper_bc, only : ubc_timestep_init - use physics_types , only : physics_state - use ppgrid , only : begchunk, endchunk + use physics_buffer, only : physics_buffer_desc - use physics_buffer, only : physics_buffer_desc + type(physics_state), intent(in) :: state(begchunk:endchunk) + type(physics_buffer_desc), pointer :: pbuf2d(:,:) - type(physics_state), intent(in) :: state(begchunk:endchunk) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) + call ubc_timestep_init( pbuf2d, state) - call ubc_timestep_init( pbuf2d, state) +end subroutine vertical_diffusion_ts_init - end subroutine vertical_diffusion_ts_init +! =============================================================================== ! +! ! +! =============================================================================== ! - ! =============================================================================== ! - subroutine vertical_diffusion_tend( & - ztodt , state , cam_in, & - ustar , obklen , ptend , & - cldn , pbuf) - !---------------------------------------------------- ! - ! This is an interface routine for vertical diffusion ! - !---------------------------------------------------- ! - use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field - use physics_types, only : physics_state, physics_ptend, physics_ptend_init - use camsrfexch, only : cam_in_t - use cam_history, only : outfld - - use trb_mtn_stress_cam, only : trb_mtn_stress_tend - use beljaars_drag_cam, only : beljaars_drag_tend - use eddy_diff_cam, only : eddy_diff_tend - use hb_diff, only : compute_hb_diff - use wv_saturation, only : qsat - use molec_diff, only : compute_molec_diff, vd_lu_qdecomp - use constituents, only : qmincg, qmin - use diffusion_solver, only : compute_vdiff, any, operator(.not.) - use physconst, only : cpairv, rairv !Needed for calculation of upward H flux - use time_manager, only : get_nstep - use constituents, only : cnst_get_type_byind, cnst_name, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx - use physconst, only : pi - use pbl_utils, only : virtem, calc_obklen, calc_ustar - use upper_bc, only : ubc_get_vals - use coords_1d, only : Coords1D - - ! --------------- ! - ! Input Arguments ! - ! --------------- ! - - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), intent(in) :: cam_in ! Surface inputs - - real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] - real(r8), intent(in) :: cldn(pcols,pver) ! New stratus fraction [ fraction ] - - ! ---------------------- ! - ! Input-Output Arguments ! - ! ---------------------- ! - - type(physics_ptend), intent(out) :: ptend ! Individual parameterization tendencies - type(physics_buffer_desc), pointer :: pbuf(:) - - ! ---------------- ! - ! Output Arguments ! - ! ---------------- ! - - real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] - real(r8), intent(out) :: obklen(pcols) ! Obukhov length [ m ] - - ! --------------- ! - ! Local Variables ! - ! --------------- ! - - character(128) :: errstring ! Error status for compute_vdiff - - integer :: lchnk ! Chunk identifier - integer :: ncol ! Number of atmospheric columns - integer :: i, k, l, m ! column, level, constituent indices - - real(r8) :: dtk(pcols,pver) ! T tendency from KE dissipation - real(r8), pointer :: tke(:,:) ! Turbulent kinetic energy [ m2/s2 ] - integer(i4),pointer :: turbtype(:,:) ! Turbulent interface types [ no unit ] - real(r8), pointer :: smaw(:,:) ! Normalized Galperin instability function - ! ( 0<= <=4.964 and 1 at neutral ) - - real(r8), pointer :: qtl_flx(:,:) ! overbar(w'qtl') where qtl = qv + ql - real(r8), pointer :: qti_flx(:,:) ! overbar(w'qti') where qti = qv + qi - - real(r8) :: cgs(pcols,pverp) ! Counter-gradient star [ cg/flux ] - real(r8) :: cgh(pcols,pverp) ! Counter-gradient term for heat - real(r8) :: rztodt ! 1./ztodt [ 1/s ] - real(r8), pointer :: ksrftms(:) ! Turbulent mountain stress surface drag coefficient [ kg/s/m2 ] - real(r8), pointer :: tautmsx(:) ! U component of turbulent mountain stress [ N/m2 ] - real(r8), pointer :: tautmsy(:) ! V component of turbulent mountain stress [ N/m2 ] - real(r8) :: tautotx(pcols) ! U component of total surface stress [ N/m2 ] - real(r8) :: tautoty(pcols) ! V component of total surface stress [ N/m2 ] - - real(r8), pointer :: dragblj(:,:) ! Beljaars SGO form drag profile [ 1/s ] - real(r8), pointer :: taubljx(:) ! U component of turbulent mountain stress [ N/m2 ] - real(r8), pointer :: taubljy(:) ! V component of turbulent mountain stress [ N/m2 ] - - real(r8), pointer :: kvh_in(:,:) ! kvh from previous timestep [ m2/s ] - real(r8), pointer :: kvm_in(:,:) ! kvm from previous timestep [ m2/s ] - real(r8), pointer :: kvt(:,:) ! Molecular kinematic conductivity for temperature [ ] - real(r8) :: kvq(pcols,pverp) ! Eddy diffusivity for constituents [ m2/s ] - real(r8) :: kvh(pcols,pverp) ! Eddy diffusivity for heat [ m2/s ] - real(r8) :: kvm(pcols,pverp) ! Eddy diffusivity for momentum [ m2/s ] - real(r8) :: kvm_temp(pcols,pverp) ! Dummy eddy diffusivity for momentum (unused) [ m2/s ] - real(r8) :: dtk_temp(pcols,pverp) ! Unused output from second compute_vdiff call - real(r8) :: tautmsx_temp(pcols) ! Unused output from second compute_vdiff call - real(r8) :: tautmsy_temp(pcols) ! Unused output from second compute_vdiff call - real(r8) :: topflx_temp(pcols) ! Unused output from second compute_vdiff call - real(r8) :: sprod(pcols,pverp) ! Shear production of tke [ m2/s3 ] - real(r8) :: sfi(pcols,pverp) ! Saturation fraction at interfaces [ fraction ] - real(r8) :: sl(pcols,pver) - real(r8) :: qt(pcols,pver) - real(r8) :: slv(pcols,pver) - real(r8) :: sl_prePBL(pcols,pver) - real(r8) :: qt_prePBL(pcols,pver) - real(r8) :: slv_prePBL(pcols,pver) - real(r8) :: slten(pcols,pver) - real(r8) :: qtten(pcols,pver) - real(r8) :: slflx(pcols,pverp) - real(r8) :: qtflx(pcols,pverp) - real(r8) :: uflx(pcols,pverp) - real(r8) :: vflx(pcols,pverp) - real(r8) :: slflx_cg(pcols,pverp) - real(r8) :: qtflx_cg(pcols,pverp) - real(r8) :: uflx_cg(pcols,pverp) - real(r8) :: vflx_cg(pcols,pverp) - real(r8) :: th(pcols,pver) ! Potential temperature - real(r8) :: topflx(pcols) ! Molecular heat flux at top interface - real(r8) :: rhoair - - real(r8) :: ri(pcols,pver) ! richardson number (HB output) - - ! for obklen calculation outside HB - real(r8) :: thvs(pcols) ! Virtual potential temperature at surface - real(r8) :: rrho(pcols) ! Reciprocal of density at surface - real(r8) :: khfs(pcols) ! sfc kinematic heat flux [mK/s] - real(r8) :: kqfs(pcols) ! sfc kinematic water vapor flux [m/s] - real(r8) :: kbfs(pcols) ! sfc kinematic buoyancy flux [m^2/s^3] - - real(r8) :: ftem(pcols,pver) ! Saturation vapor pressure before PBL - real(r8) :: ftem_prePBL(pcols,pver) ! Saturation vapor pressure before PBL - real(r8) :: ftem_aftPBL(pcols,pver) ! Saturation vapor pressure after PBL - real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH - real(r8) :: t_aftPBL(pcols,pver) ! Temperature after PBL diffusion - real(r8) :: tten(pcols,pver) ! Temperature tendency by PBL diffusion - real(r8) :: rhten(pcols,pver) ! RH tendency by PBL diffusion - real(r8) :: qv_aft_PBL(pcols,pver) ! qv after PBL diffusion - real(r8) :: ql_aft_PBL(pcols,pver) ! ql after PBL diffusion - real(r8) :: qi_aft_PBL(pcols,pver) ! qi after PBL diffusion - real(r8) :: s_aft_PBL(pcols,pver) ! s after PBL diffusion - real(r8) :: u_aft_PBL(pcols,pver) ! u after PBL diffusion - real(r8) :: v_aft_PBL(pcols,pver) ! v after PBL diffusion - real(r8) :: qv_pro(pcols,pver) - real(r8) :: ql_pro(pcols,pver) - real(r8) :: qi_pro(pcols,pver) - real(r8) :: s_pro(pcols,pver) - real(r8) :: t_pro(pcols,pver) - real(r8), pointer :: tauresx(:) ! Residual stress to be added in vdiff to correct - real(r8), pointer :: tauresy(:) ! for turb stress mismatch between sfc and atm accumulated. - - ! Interpolated interface values. - real(r8) :: tint(pcols,pver+1) ! Temperature [ K ] - real(r8) :: rairi(pcols,pver+1) ! Gas constant [ J/K/kg ] - real(r8) :: rhoi(pcols,pver+1) ! Density of air [ kg/m^3 ] - real(r8) :: rhoi_dry(pcols,pver+1) ! Density of air based on dry air pressure [ kg/m^3 ] - - ! Upper boundary conditions - real(r8) :: ubc_t(pcols) ! Temperature [ K ] - real(r8) :: ubc_mmr(pcols,pcnst) ! Mixing ratios [ kg/kg ] - real(r8) :: ubc_flux(pcols,pcnst) ! Constituent upper boundary flux (kg/s/m^2) - - ! Pressure coordinates used by the solver. - type(Coords1D) :: p - type(Coords1D) :: p_dry - - real(r8), pointer :: tpert(:) - real(r8), pointer :: qpert(:) - real(r8), pointer :: pblh(:) - - real(r8) :: tmp1(pcols) ! Temporary storage - - integer :: nstep - real(r8) :: sum1, sum2, sum3, pdelx - real(r8) :: sflx - - ! Copy state so we can pass to intent(inout) routines that return - ! new state instead of a tendency. - real(r8) :: s_tmp(pcols,pver) - real(r8) :: u_tmp(pcols,pver) - real(r8) :: v_tmp(pcols,pver) - real(r8) :: q_tmp(pcols,pver,pcnst) - - ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity - real(r8) :: kq_scal(pcols,pver+1) - ! composition dependent mw_fac on interface level - real(r8) :: mw_fac(pcols,pver+1,pcnst) - - ! Dry static energy top boundary condition. - real(r8) :: dse_top(pcols) - - ! Copies of flux arrays used to zero out any parts that are applied - ! elsewhere (e.g. by CLUBB). - real(r8) :: taux(pcols) - real(r8) :: tauy(pcols) - real(r8) :: shflux(pcols) - real(r8) :: cflux(pcols,pcnst) - - logical :: lq(pcnst) - - ! ----------------------- ! - ! Main Computation Begins ! - ! ----------------------- ! - - rztodt = 1._r8 / ztodt - lchnk = state%lchnk - ncol = state%ncol - - call pbuf_get_field(pbuf, tauresx_idx, tauresx) - call pbuf_get_field(pbuf, tauresy_idx, tauresy) - call pbuf_get_field(pbuf, tpert_idx, tpert) - call pbuf_get_field(pbuf, qpert_idx, qpert) - call pbuf_get_field(pbuf, pblh_idx, pblh) - call pbuf_get_field(pbuf, turbtype_idx, turbtype) - - ! Interpolate temperature to interfaces. - do k = 2, pver - do i = 1, ncol - tint(i,k) = 0.5_r8 * ( state%t(i,k) + state%t(i,k-1) ) - end do - end do - tint(:ncol,pver+1) = state%t(:ncol,pver) - - ! Get upper boundary values - call ubc_get_vals( state%lchnk, ncol, state%pint, state%zi, state%t, state%q, state%omega, state%phis, & - ubc_t, ubc_mmr, ubc_flux ) - - ! Always have a fixed upper boundary T if molecular diffusion is active. Why ? - ! For WACCM-X, set ubc temperature to extrapolate from next two lower interface level temperatures - if (do_molec_diff) then - if (waccmx_mode) then - tint(:ncol,1) = 1.5_r8*tint(:ncol,2)-.5_r8*tint(:ncol,3) - else - tint (:ncol,1) = ubc_t(:ncol) - endif - else - tint(:ncol,1) = state%t(:ncol,1) - end if - - ! Set up pressure coordinates for solver calls. - p = Coords1D(state%pint(:ncol,:)) - p_dry = Coords1D(state%pintdry(:ncol,:)) - - !------------------------------------------------------------------------ - ! Check to see if constituent dependent gas constant needed (WACCM-X) - !------------------------------------------------------------------------ - if (waccmx_mode) then - rairi(:ncol,1) = rairv(:ncol,1,lchnk) - do k = 2, pver - do i = 1, ncol - rairi(i,k) = 0.5_r8 * (rairv(i,k,lchnk)+rairv(i,k-1,lchnk)) - end do - end do - rairi(:ncol,pver+1) = rairv(:ncol,pver,lchnk) - else - rairi(:ncol,:pver+1) = rair - endif - - ! Compute rho at interfaces. - do k = 1, pver+1 - do i = 1, ncol - rhoi(i,k) = p%ifc(i,k) / (rairi(i,k)*tint(i,k)) - end do - end do - - ! Compute rho_dry at interfaces. - do k = 1, pver+1 - do i = 1, ncol - rhoi_dry(i,k) = p_dry%ifc(i,k) / (rairi(i,k)*tint(i,k)) - end do - end do - - ! ---------------------------------------- ! - ! Computation of turbulent mountain stress ! - ! ---------------------------------------- ! - - ! Consistent with the computation of 'normal' drag coefficient, we are using - ! the raw input (u,v) to compute 'ksrftms', not the provisionally-marched 'u,v' - ! within the iteration loop of the PBL scheme. - - call trb_mtn_stress_tend(state, pbuf, cam_in) - - call pbuf_get_field(pbuf, ksrftms_idx, ksrftms) - call pbuf_get_field(pbuf, tautmsx_idx, tautmsx) - call pbuf_get_field(pbuf, tautmsy_idx, tautmsy) - - tautotx(:ncol) = cam_in%wsx(:ncol) + tautmsx(:ncol) - tautoty(:ncol) = cam_in%wsy(:ncol) + tautmsy(:ncol) - - ! ------------------------------------- ! - ! Computation of Beljaars SGO form drag ! - ! ------------------------------------- ! - - call beljaars_drag_tend(state, pbuf, cam_in) - - call pbuf_get_field(pbuf, dragblj_idx, dragblj) - call pbuf_get_field(pbuf, taubljx_idx, taubljx) - call pbuf_get_field(pbuf, taubljy_idx, taubljy) - - ! Add Beljaars integrated drag - - tautotx(:ncol) = tautotx(:ncol) + taubljx(:ncol) - tautoty(:ncol) = tautoty(:ncol) + taubljy(:ncol) - - !----------------------------------------------------------------------- ! - ! Computation of eddy diffusivities - Select appropriate PBL scheme ! - !----------------------------------------------------------------------- ! - call pbuf_get_field(pbuf, kvm_idx, kvm_in) - call pbuf_get_field(pbuf, kvh_idx, kvh_in) - call pbuf_get_field(pbuf, smaw_idx, smaw) - call pbuf_get_field(pbuf, tke_idx, tke) - - ! Get potential temperature. - th(:ncol,:pver) = state%t(:ncol,:pver) * state%exner(:ncol,:pver) - - select case (eddy_scheme) - case ( 'diag_TKE', 'SPCAM_m2005' ) - - call eddy_diff_tend(state, pbuf, cam_in, & - ztodt, p, tint, rhoi, cldn, wstarent, & - kvm_in, kvh_in, ksrftms, dragblj, tauresx, tauresy, & - rrho, ustar, pblh, kvm, kvh, kvq, cgh, cgs, tpert, qpert, & - tke, sprod, sfi, turbtype, smaw) - - ! The diag_TKE scheme does not calculate the Monin-Obukhov length, which is used in dry deposition calculations. - ! Use the routines from pbl_utils to accomplish this. Assumes ustar and rrho have been set. - call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) - call calc_obklen(ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & - cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & - khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) - - - case ( 'HB', 'HBR', 'SPCAM_sam1mom' ) - - ! Modification : We may need to use 'taux' instead of 'tautotx' here, for - ! consistency with the previous HB scheme. - - call compute_hb_diff( lchnk , ncol , & - th , state%t , state%q , state%zm , state%zi, & - state%pmid, state%u , state%v , tautotx , tautoty , & - cam_in%shf, cam_in%cflx(:,1), obklen , ustar , pblh , & - kvm , kvh , kvq , cgh , cgs , & - tpert , qpert , cldn , cam_in%ocnfrac , tke , & - ri , & - eddy_scheme ) - - call outfld( 'HB_ri', ri, pcols, lchnk ) - - case ( 'CLUBB_SGS' ) - - ! CLUBB has only a bare-bones placeholder here. If using CLUBB, the - ! PBL diffusion will happen before coupling, so vertical_diffusion - ! is only handling other things, e.g. some boundary conditions, tms, - ! and molecular diffusion. - - call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) - - call calc_ustar( ncol, state%t(:ncol,pver), state%pmid(:ncol,pver), & - cam_in%wsx(:ncol), cam_in%wsy(:ncol), rrho(:ncol), ustar(:ncol)) - ! Use actual qflux, not lhf/latvap as was done previously - call calc_obklen( ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & - cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & - khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) - - ! These tendencies all applied elsewhere. - kvm = 0._r8 - kvh = 0._r8 - kvq = 0._r8 - - ! Not defined since PBL is not actually running here. - cgh = 0._r8 - cgs = 0._r8 - - end select - - call outfld( 'ustar', ustar(:), pcols, lchnk ) - call outfld( 'obklen', obklen(:), pcols, lchnk ) - - ! kvh (in pbuf) is used by other physics parameterizations, and as an initial guess in compute_eddy_diff - ! on the next timestep. It is not updated by the compute_vdiff call below. - call pbuf_set_field(pbuf, kvh_idx, kvh) - - ! kvm (in pbuf) is only used as an initial guess in compute_eddy_diff on the next timestep. - ! The contributions for molecular diffusion made to kvm by the call to compute_vdiff below - ! are not included in the pbuf as these are not needed in the initial guess by compute_eddy_diff. - call pbuf_set_field(pbuf, kvm_idx, kvm) - - !------------------------------------ ! - ! Application of diffusivities ! - !------------------------------------ ! - - ! Set arrays from input state. - q_tmp(:ncol,:,:) = state%q(:ncol,:,:) - s_tmp(:ncol,:) = state%s(:ncol,:) - u_tmp(:ncol,:) = state%u(:ncol,:) - v_tmp(:ncol,:) = state%v(:ncol,:) - - !------------------------------------------------------ ! - ! Write profile output before applying diffusion scheme ! - !------------------------------------------------------ ! - - if (.not. do_pbl_diags) then - sl_prePBL(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & - - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) - qt_prePBL(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & - + q_tmp(:ncol,:,ixcldice) - slv_prePBL(:ncol,:pver) = sl_prePBL(:ncol,:pver) * ( 1._r8 + zvir*qt_prePBL(:ncol,:pver) ) - - call qsat(state%t(:ncol,:), state%pmid(:ncol,:), & - tem2(:ncol,:), ftem(:ncol,:)) - ftem_prePBL(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 - - call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) - call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) - call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) - call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) - call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) - call outfld( 'qv_pre_PBL ', state%q(:ncol,:,1), pcols, lchnk ) - call outfld( 'ql_pre_PBL ', state%q(:ncol,:,ixcldliq), pcols, lchnk ) - call outfld( 'qi_pre_PBL ', state%q(:ncol,:,ixcldice), pcols, lchnk ) - call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) - call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) - - end if - - ! --------------------------------------------------------------------------------- ! - ! Call the diffusivity solver and solve diffusion equation ! - ! The final two arguments are optional function references to ! - ! constituent-independent and constituent-dependent moleculuar diffusivity routines ! - ! --------------------------------------------------------------------------------- ! - - ! Modification : We may need to output 'tautotx_im,tautoty_im' from below 'compute_vdiff' and - ! separately print out as diagnostic output, because these are different from - ! the explicit 'tautotx, tautoty' computed above. - ! Note that the output 'tauresx,tauresy' from below subroutines are fully implicit ones. - - call pbuf_get_field(pbuf, kvt_idx, kvt) - - if (do_molec_diff .and. .not. waccmx_mode) then - ! Top boundary condition for dry static energy - dse_top(:ncol) = cpairv(:ncol,1,lchnk) * tint(:ncol,1) + & - gravit * state%zi(:ncol,1) - else - dse_top(:ncol) = 0._r8 - end if - - select case (eddy_scheme) - case ('CLUBB_SGS') - ! CLUBB applies some fluxes itself, but we still want constituent - ! fluxes applied here (except water vapor). - taux = 0._r8 - tauy = 0._r8 - shflux = 0._r8 - cflux(:,1) = 0._r8 - cflux(:,2:) = cam_in%cflx(:,2:) - case default - taux = cam_in%wsx - tauy = cam_in%wsy - shflux = cam_in%shf - cflux = cam_in%cflx - end select - - if( any(fieldlist_wet) ) then - - if (do_molec_diff) then - call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & - kvm, kvt, tint, rhoi, kq_scal, cnst_mw, & - mw_fac, nbot_molec) - end if - - call compute_vdiff( state%lchnk , & - pcols , pver , pcnst , ncol , tint , & - p , state%t , rhoi, ztodt , taux , & - tauy , shflux , cflux , & - kvh , kvm , kvq , cgs , cgh , & - state%zi , ksrftms , dragblj , & - qmincg , fieldlist_wet , fieldlist_molec,& - u_tmp , v_tmp , q_tmp , s_tmp , & - tautmsx , tautmsy , dtk , topflx , errstring , & - tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & - do_molec_diff, waccmx_mode, & - vd_lu_qdecomp, & - ubc_mmr, ubc_flux, kvt, state%pmid, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & - kq_scal, mw_fac) - - call handle_errmsg(errstring, subname="compute_vdiff", & - extra_msg="Error in fieldlist_wet call from vertical_diffusion.") - - end if - - if( any( fieldlist_dry ) ) then - - if( do_molec_diff ) then - ! kvm is unused in the output here (since it was assigned - ! above), so we use a temp kvm for the inout argument, and - ! ignore the value output by compute_molec_diff. - kvm_temp = kvm - call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & - kvm_temp, kvt, tint, rhoi_dry, kq_scal, cnst_mw, & - mw_fac, nbot_molec) - end if - - call compute_vdiff( state%lchnk , & - pcols , pver , pcnst , ncol , tint , & - p_dry , state%t , rhoi_dry, ztodt , taux , & - tauy , shflux , cflux , & - kvh , kvm , kvq , cgs , cgh , & - state%zi , ksrftms , dragblj , & - qmincg , fieldlist_dry , fieldlist_molec,& - u_tmp , v_tmp , q_tmp , s_tmp , & - tautmsx_temp , tautmsy_temp , dtk_temp , topflx_temp , errstring , & - tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & - do_molec_diff , waccmx_mode, & - vd_lu_qdecomp, & - ubc_mmr, ubc_flux, kvt, state%pmiddry, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & - kq_scal, mw_fac) - - call handle_errmsg(errstring, subname="compute_vdiff", & - extra_msg="Error in fieldlist_dry call from vertical_diffusion.") - - end if - - ! -------------------------------------------------------- ! - ! Diagnostics and output writing after applying PBL scheme ! - ! -------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - sl(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & - - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) - qt(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & - + q_tmp(:ncol,:,ixcldice) - slv(:ncol,:pver) = sl(:ncol,:pver) * ( 1._r8 + zvir*qt(:ncol,:pver) ) - - slflx(:ncol,1) = 0._r8 - qtflx(:ncol,1) = 0._r8 - uflx(:ncol,1) = 0._r8 - vflx(:ncol,1) = 0._r8 - - slflx_cg(:ncol,1) = 0._r8 - qtflx_cg(:ncol,1) = 0._r8 - uflx_cg(:ncol,1) = 0._r8 - vflx_cg(:ncol,1) = 0._r8 - - do k = 2, pver - do i = 1, ncol - rhoair = state%pint(i,k) / ( rair * ( ( 0.5_r8*(slv(i,k)+slv(i,k-1)) - gravit*state%zi(i,k))/cpair ) ) - slflx(i,k) = kvh(i,k) * & - ( - rhoair*(sl(i,k-1)-sl(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & - + cgh(i,k) ) - qtflx(i,k) = kvh(i,k) * & - ( - rhoair*(qt(i,k-1)-qt(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & - + rhoair*(cam_in%cflx(i,1)+cam_in%cflx(i,ixcldliq)+cam_in%cflx(i,ixcldice))*cgs(i,k) ) - uflx(i,k) = kvm(i,k) * & - ( - rhoair*(u_tmp(i,k-1)-u_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) - vflx(i,k) = kvm(i,k) * & - ( - rhoair*(v_tmp(i,k-1)-v_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) - slflx_cg(i,k) = kvh(i,k) * cgh(i,k) - qtflx_cg(i,k) = kvh(i,k) * rhoair * ( cam_in%cflx(i,1) + & - cam_in%cflx(i,ixcldliq) + cam_in%cflx(i,ixcldice) ) * cgs(i,k) - uflx_cg(i,k) = 0._r8 - vflx_cg(i,k) = 0._r8 - end do - end do - - ! Modification : I should check whether slflx(:ncol,pverp) is correctly computed. - ! Note also that 'tautotx' is explicit total stress, different from - ! the ones that have been actually added into the atmosphere. - - slflx(:ncol,pverp) = cam_in%shf(:ncol) - qtflx(:ncol,pverp) = cam_in%cflx(:ncol,1) - uflx(:ncol,pverp) = tautotx(:ncol) - vflx(:ncol,pverp) = tautoty(:ncol) - - slflx_cg(:ncol,pverp) = 0._r8 - qtflx_cg(:ncol,pverp) = 0._r8 - uflx_cg(:ncol,pverp) = 0._r8 - vflx_cg(:ncol,pverp) = 0._r8 - - if (trim(shallow_scheme) == 'UNICON') then - call pbuf_get_field(pbuf, qtl_flx_idx, qtl_flx) - call pbuf_get_field(pbuf, qti_flx_idx, qti_flx) - qtl_flx(:ncol,1) = 0._r8 - qti_flx(:ncol,1) = 0._r8 - do k = 2, pver - do i = 1, ncol - ! For use in the cloud macrophysics - ! Note that density is not added here. Also, only consider local transport term. - qtl_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldliq)-q_tmp(i,k,ixcldliq))/& - (state%zm(i,k-1)-state%zm(i,k)) - qti_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldice)-q_tmp(i,k,ixcldice))/& - (state%zm(i,k-1)-state%zm(i,k)) - end do - end do - do i = 1, ncol - rhoair = state%pint(i,pverp)/(rair*((slv(i,pver)-gravit*state%zi(i,pverp))/cpair)) - qtl_flx(i,pverp) = cam_in%cflx(i,1)/rhoair - qti_flx(i,pverp) = cam_in%cflx(i,1)/rhoair - end do - end if - - end if - - ! --------------------------------------------------------------- ! - ! Convert the new profiles into vertical diffusion tendencies. ! - ! Convert KE dissipative heat change into "temperature" tendency. ! - ! --------------------------------------------------------------- ! - - ! All variables are modified by vertical diffusion - - lq(:) = .TRUE. - call physics_ptend_init(ptend,state%psetcols, "vertical diffusion", & - ls=.true., lu=.true., lv=.true., lq=lq) - - ptend%s(:ncol,:) = ( s_tmp(:ncol,:) - state%s(:ncol,:) ) * rztodt - ptend%u(:ncol,:) = ( u_tmp(:ncol,:) - state%u(:ncol,:) ) * rztodt - ptend%v(:ncol,:) = ( v_tmp(:ncol,:) - state%v(:ncol,:) ) * rztodt - ptend%q(:ncol,:pver,:) = ( q_tmp(:ncol,:pver,:) - state%q(:ncol,:pver,:) ) * rztodt - if (.not. do_pbl_diags) then - slten(:ncol,:) = ( sl(:ncol,:) - sl_prePBL(:ncol,:) ) * rztodt - qtten(:ncol,:) = ( qt(:ncol,:) - qt_prePBL(:ncol,:) ) * rztodt - end if - - ! ------------------------------------------------------------ ! - ! In order to perform 'pseudo-conservative variable diffusion' ! - ! perform the following two stages: ! - ! ! - ! I. Re-set (1) 'qvten' by 'qtten', and 'qlten = qiten = 0' ! - ! (2) 'sten' by 'slten', and ! - ! (3) 'qlten = qiten = 0' ! - ! ! - ! II. Apply 'positive_moisture' ! - ! ! - ! ------------------------------------------------------------ ! +subroutine vertical_diffusion_tend( & + ztodt , state , cam_in, & + ustar , obklen , ptend , & + cldn , pbuf) + !---------------------------------------------------- ! + ! This is an interface routine for vertical diffusion ! + !---------------------------------------------------- ! + use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field + use physics_types, only : physics_state, physics_ptend, physics_ptend_init + use camsrfexch, only : cam_in_t + use cam_history, only : outfld + + use trb_mtn_stress_cam, only : trb_mtn_stress_tend + use beljaars_drag_cam, only : beljaars_drag_tend + use eddy_diff_cam, only : eddy_diff_tend + use hb_diff, only : compute_hb_diff + use wv_saturation, only : qsat + use molec_diff, only : compute_molec_diff, vd_lu_qdecomp + use constituents, only : qmincg, qmin + use diffusion_solver, only : compute_vdiff, any, operator(.not.) + use physconst, only : cpairv, rairv !Needed for calculation of upward H flux + use time_manager, only : get_nstep + use constituents, only : cnst_get_type_byind, cnst_name, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx + use physconst, only : pi + use pbl_utils, only : virtem, calc_obklen, calc_ustar + use upper_bc, only : ubc_get_vals + use coords_1d, only : Coords1D + + ! --------------- ! + ! Input Arguments ! + ! --------------- ! + + type(physics_state), intent(in) :: state ! Physics state variables + type(cam_in_t), intent(in) :: cam_in ! Surface inputs + + real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] + real(r8), intent(in) :: cldn(pcols,pver) ! New stratus fraction [ fraction ] + + ! ---------------------- ! + ! Input-Output Arguments ! + ! ---------------------- ! + + type(physics_ptend), intent(out) :: ptend ! Individual parameterization tendencies + type(physics_buffer_desc), pointer :: pbuf(:) + + ! ---------------- ! + ! Output Arguments ! + ! ---------------- ! + + real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] + real(r8), intent(out) :: obklen(pcols) ! Obukhov length [ m ] + + ! --------------- ! + ! Local Variables ! + ! --------------- ! + + character(128) :: errstring ! Error status for compute_vdiff + + integer :: lchnk ! Chunk identifier + integer :: ncol ! Number of atmospheric columns + integer :: i, k, l, m ! column, level, constituent indices + + real(r8) :: dtk(pcols,pver) ! T tendency from KE dissipation + real(r8), pointer :: tke(:,:) ! Turbulent kinetic energy [ m2/s2 ] + integer(i4),pointer :: turbtype(:,:) ! Turbulent interface types [ no unit ] + real(r8), pointer :: smaw(:,:) ! Normalized Galperin instability function + ! ( 0<= <=4.964 and 1 at neutral ) + + real(r8), pointer :: qtl_flx(:,:) ! overbar(w'qtl') where qtl = qv + ql + real(r8), pointer :: qti_flx(:,:) ! overbar(w'qti') where qti = qv + qi + + real(r8) :: cgs(pcols,pverp) ! Counter-gradient star [ cg/flux ] + real(r8) :: cgh(pcols,pverp) ! Counter-gradient term for heat + real(r8) :: rztodt ! 1./ztodt [ 1/s ] + real(r8), pointer :: ksrftms(:) ! Turbulent mountain stress surface drag coefficient [ kg/s/m2 ] + real(r8), pointer :: tautmsx(:) ! U component of turbulent mountain stress [ N/m2 ] + real(r8), pointer :: tautmsy(:) ! V component of turbulent mountain stress [ N/m2 ] + real(r8) :: tautotx(pcols) ! U component of total surface stress [ N/m2 ] + real(r8) :: tautoty(pcols) ! V component of total surface stress [ N/m2 ] + + real(r8), pointer :: dragblj(:,:) ! Beljaars SGO form drag profile [ 1/s ] + real(r8), pointer :: taubljx(:) ! U component of turbulent mountain stress [ N/m2 ] + real(r8), pointer :: taubljy(:) ! V component of turbulent mountain stress [ N/m2 ] + + real(r8), pointer :: kvh_in(:,:) ! kvh from previous timestep [ m2/s ] + real(r8), pointer :: kvm_in(:,:) ! kvm from previous timestep [ m2/s ] + real(r8), pointer :: kvt(:,:) ! Molecular kinematic conductivity for temperature [ ] + real(r8) :: kvq(pcols,pverp) ! Eddy diffusivity for constituents [ m2/s ] + real(r8) :: kvh(pcols,pverp) ! Eddy diffusivity for heat [ m2/s ] + real(r8) :: kvm(pcols,pverp) ! Eddy diffusivity for momentum [ m2/s ] + real(r8) :: kvm_temp(pcols,pverp) ! Dummy eddy diffusivity for momentum (unused) [ m2/s ] + real(r8) :: dtk_temp(pcols,pverp) ! Unused output from second compute_vdiff call + real(r8) :: tautmsx_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: tautmsy_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: topflx_temp(pcols) ! Unused output from second compute_vdiff call + real(r8) :: sprod(pcols,pverp) ! Shear production of tke [ m2/s3 ] + real(r8) :: sfi(pcols,pverp) ! Saturation fraction at interfaces [ fraction ] + real(r8) :: sl(pcols,pver) + real(r8) :: qt(pcols,pver) + real(r8) :: slv(pcols,pver) + real(r8) :: sl_prePBL(pcols,pver) + real(r8) :: qt_prePBL(pcols,pver) + real(r8) :: slv_prePBL(pcols,pver) + real(r8) :: slten(pcols,pver) + real(r8) :: qtten(pcols,pver) + real(r8) :: slflx(pcols,pverp) + real(r8) :: qtflx(pcols,pverp) + real(r8) :: uflx(pcols,pverp) + real(r8) :: vflx(pcols,pverp) + real(r8) :: slflx_cg(pcols,pverp) + real(r8) :: qtflx_cg(pcols,pverp) + real(r8) :: uflx_cg(pcols,pverp) + real(r8) :: vflx_cg(pcols,pverp) + real(r8) :: th(pcols,pver) ! Potential temperature + real(r8) :: topflx(pcols) ! Molecular heat flux at top interface + real(r8) :: rhoair + + real(r8) :: ri(pcols,pver) ! richardson number (HB output) + + ! for obklen calculation outside HB + real(r8) :: thvs(pcols) ! Virtual potential temperature at surface + real(r8) :: rrho(pcols) ! Reciprocal of density at surface + real(r8) :: khfs(pcols) ! sfc kinematic heat flux [mK/s] + real(r8) :: kqfs(pcols) ! sfc kinematic water vapor flux [m/s] + real(r8) :: kbfs(pcols) ! sfc kinematic buoyancy flux [m^2/s^3] + + real(r8) :: ftem(pcols,pver) ! Saturation vapor pressure before PBL + real(r8) :: ftem_prePBL(pcols,pver) ! Saturation vapor pressure before PBL + real(r8) :: ftem_aftPBL(pcols,pver) ! Saturation vapor pressure after PBL + real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH + real(r8) :: t_aftPBL(pcols,pver) ! Temperature after PBL diffusion + real(r8) :: tten(pcols,pver) ! Temperature tendency by PBL diffusion + real(r8) :: rhten(pcols,pver) ! RH tendency by PBL diffusion + real(r8) :: qv_aft_PBL(pcols,pver) ! qv after PBL diffusion + real(r8) :: ql_aft_PBL(pcols,pver) ! ql after PBL diffusion + real(r8) :: qi_aft_PBL(pcols,pver) ! qi after PBL diffusion + real(r8) :: s_aft_PBL(pcols,pver) ! s after PBL diffusion + real(r8) :: u_aft_PBL(pcols,pver) ! u after PBL diffusion + real(r8) :: v_aft_PBL(pcols,pver) ! v after PBL diffusion + real(r8) :: qv_pro(pcols,pver) + real(r8) :: ql_pro(pcols,pver) + real(r8) :: qi_pro(pcols,pver) + real(r8) :: s_pro(pcols,pver) + real(r8) :: t_pro(pcols,pver) + real(r8), pointer :: tauresx(:) ! Residual stress to be added in vdiff to correct + real(r8), pointer :: tauresy(:) ! for turb stress mismatch between sfc and atm accumulated. + + ! Interpolated interface values. + real(r8) :: tint(pcols,pver+1) ! Temperature [ K ] + real(r8) :: rairi(pcols,pver+1) ! Gas constant [ J/K/kg ] + real(r8) :: rhoi(pcols,pver+1) ! Density of air [ kg/m^3 ] + real(r8) :: rhoi_dry(pcols,pver+1) ! Density of air based on dry air pressure [ kg/m^3 ] + + ! Upper boundary conditions + real(r8) :: ubc_t(pcols) ! Temperature [ K ] + real(r8) :: ubc_mmr(pcols,pcnst) ! Mixing ratios [ kg/kg ] + real(r8) :: ubc_flux(pcols,pcnst) ! Constituent upper boundary flux (kg/s/m^2) + + ! Pressure coordinates used by the solver. + type(Coords1D) :: p + type(Coords1D) :: p_dry + + real(r8), pointer :: tpert(:) + real(r8), pointer :: qpert(:) + real(r8), pointer :: pblh(:) + + real(r8) :: tmp1(pcols) ! Temporary storage + + integer :: nstep + real(r8) :: sum1, sum2, sum3, pdelx + real(r8) :: sflx + + ! Copy state so we can pass to intent(inout) routines that return + ! new state instead of a tendency. + real(r8) :: s_tmp(pcols,pver) + real(r8) :: u_tmp(pcols,pver) + real(r8) :: v_tmp(pcols,pver) + real(r8) :: q_tmp(pcols,pver,pcnst) + + ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity + real(r8) :: kq_scal(pcols,pver+1) + ! composition dependent mw_fac on interface level + real(r8) :: mw_fac(pcols,pver+1,pcnst) + + ! Dry static energy top boundary condition. + real(r8) :: dse_top(pcols) + + ! Copies of flux arrays used to zero out any parts that are applied + ! elsewhere (e.g. by CLUBB). + real(r8) :: taux(pcols) + real(r8) :: tauy(pcols) + real(r8) :: shflux(pcols) + real(r8) :: cflux(pcols,pcnst) + + logical :: lq(pcnst) + + ! ----------------------- ! + ! Main Computation Begins ! + ! ----------------------- ! + + rztodt = 1._r8 / ztodt + lchnk = state%lchnk + ncol = state%ncol + + call pbuf_get_field(pbuf, tauresx_idx, tauresx) + call pbuf_get_field(pbuf, tauresy_idx, tauresy) + call pbuf_get_field(pbuf, tpert_idx, tpert) + call pbuf_get_field(pbuf, qpert_idx, qpert) + call pbuf_get_field(pbuf, pblh_idx, pblh) + call pbuf_get_field(pbuf, turbtype_idx, turbtype) + + ! Interpolate temperature to interfaces. + do k = 2, pver + do i = 1, ncol + tint(i,k) = 0.5_r8 * ( state%t(i,k) + state%t(i,k-1) ) + end do + end do + tint(:ncol,pver+1) = state%t(:ncol,pver) + + ! Get upper boundary values + call ubc_get_vals( state%lchnk, ncol, state%pint, state%zi, state%t, state%q, state%omega, state%phis, & + ubc_t, ubc_mmr, ubc_flux ) + + ! Always have a fixed upper boundary T if molecular diffusion is active. Why ? + ! For WACCM-X, set ubc temperature to extrapolate from next two lower interface level temperatures + if (do_molec_diff) then + if (waccmx_mode) then + tint(:ncol,1) = 1.5_r8*tint(:ncol,2)-.5_r8*tint(:ncol,3) + else + tint (:ncol,1) = ubc_t(:ncol) + endif + else + tint(:ncol,1) = state%t(:ncol,1) + end if + + ! Set up pressure coordinates for solver calls. + p = Coords1D(state%pint(:ncol,:)) + p_dry = Coords1D(state%pintdry(:ncol,:)) + + !------------------------------------------------------------------------ + ! Check to see if constituent dependent gas constant needed (WACCM-X) + !------------------------------------------------------------------------ + if (waccmx_mode) then + rairi(:ncol,1) = rairv(:ncol,1,lchnk) + do k = 2, pver + do i = 1, ncol + rairi(i,k) = 0.5_r8 * (rairv(i,k,lchnk)+rairv(i,k-1,lchnk)) + end do + end do + rairi(:ncol,pver+1) = rairv(:ncol,pver,lchnk) + else + rairi(:ncol,:pver+1) = rair + endif + + ! Compute rho at interfaces. + do k = 1, pver+1 + do i = 1, ncol + rhoi(i,k) = p%ifc(i,k) / (rairi(i,k)*tint(i,k)) + end do + end do + + ! Compute rho_dry at interfaces. + do k = 1, pver+1 + do i = 1, ncol + rhoi_dry(i,k) = p_dry%ifc(i,k) / (rairi(i,k)*tint(i,k)) + end do + end do + + ! ---------------------------------------- ! + ! Computation of turbulent mountain stress ! + ! ---------------------------------------- ! + + ! Consistent with the computation of 'normal' drag coefficient, we are using + ! the raw input (u,v) to compute 'ksrftms', not the provisionally-marched 'u,v' + ! within the iteration loop of the PBL scheme. + + call trb_mtn_stress_tend(state, pbuf, cam_in) + + call pbuf_get_field(pbuf, ksrftms_idx, ksrftms) + call pbuf_get_field(pbuf, tautmsx_idx, tautmsx) + call pbuf_get_field(pbuf, tautmsy_idx, tautmsy) + + tautotx(:ncol) = cam_in%wsx(:ncol) + tautmsx(:ncol) + tautoty(:ncol) = cam_in%wsy(:ncol) + tautmsy(:ncol) + + ! ------------------------------------- ! + ! Computation of Beljaars SGO form drag ! + ! ------------------------------------- ! + + call beljaars_drag_tend(state, pbuf, cam_in) + + call pbuf_get_field(pbuf, dragblj_idx, dragblj) + call pbuf_get_field(pbuf, taubljx_idx, taubljx) + call pbuf_get_field(pbuf, taubljy_idx, taubljy) + + ! Add Beljaars integrated drag + + tautotx(:ncol) = tautotx(:ncol) + taubljx(:ncol) + tautoty(:ncol) = tautoty(:ncol) + taubljy(:ncol) + + !----------------------------------------------------------------------- ! + ! Computation of eddy diffusivities - Select appropriate PBL scheme ! + !----------------------------------------------------------------------- ! + call pbuf_get_field(pbuf, kvm_idx, kvm_in) + call pbuf_get_field(pbuf, kvh_idx, kvh_in) + call pbuf_get_field(pbuf, smaw_idx, smaw) + call pbuf_get_field(pbuf, tke_idx, tke) + + ! Get potential temperature. + th(:ncol,:pver) = state%t(:ncol,:pver) * state%exner(:ncol,:pver) + + select case (eddy_scheme) + case ( 'diag_TKE', 'SPCAM_m2005' ) + + call eddy_diff_tend(state, pbuf, cam_in, & + ztodt, p, tint, rhoi, cldn, wstarent, & + kvm_in, kvh_in, ksrftms, dragblj, tauresx, tauresy, & + rrho, ustar, pblh, kvm, kvh, kvq, cgh, cgs, tpert, qpert, & + tke, sprod, sfi, turbtype, smaw) + + ! The diag_TKE scheme does not calculate the Monin-Obukhov length, which is used in dry deposition calculations. + ! Use the routines from pbl_utils to accomplish this. Assumes ustar and rrho have been set. + call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) + call calc_obklen(ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & + cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & + khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) + + + case ( 'HB', 'HBR', 'SPCAM_sam1mom' ) + + ! Modification : We may need to use 'taux' instead of 'tautotx' here, for + ! consistency with the previous HB scheme. + + call compute_hb_diff( lchnk , ncol , & + th , state%t , state%q , state%zm , state%zi, & + state%pmid, state%u , state%v , tautotx , tautoty , & + cam_in%shf, cam_in%cflx(:,1), obklen , ustar , pblh , & + kvm , kvh , kvq , cgh , cgs , & + tpert , qpert , cldn , cam_in%ocnfrac , tke , & + ri , & + eddy_scheme ) + + call outfld( 'HB_ri', ri, pcols, lchnk ) + + case ( 'CLUBB_SGS' ) + + ! CLUBB has only a bare-bones placeholder here. If using CLUBB, the + ! PBL diffusion will happen before coupling, so vertical_diffusion + ! is only handling other things, e.g. some boundary conditions, tms, + ! and molecular diffusion. + + call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) + + call calc_ustar( ncol, state%t(:ncol,pver), state%pmid(:ncol,pver), & + cam_in%wsx(:ncol), cam_in%wsy(:ncol), rrho(:ncol), ustar(:ncol)) + ! Use actual qflux, not lhf/latvap as was done previously + call calc_obklen( ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & + cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & + khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) + + ! These tendencies all applied elsewhere. + kvm = 0._r8 + kvh = 0._r8 + kvq = 0._r8 + + ! Not defined since PBL is not actually running here. + cgh = 0._r8 + cgs = 0._r8 + + end select + + call outfld( 'ustar', ustar(:), pcols, lchnk ) + call outfld( 'obklen', obklen(:), pcols, lchnk ) + + ! kvh (in pbuf) is used by other physics parameterizations, and as an initial guess in compute_eddy_diff + ! on the next timestep. It is not updated by the compute_vdiff call below. + call pbuf_set_field(pbuf, kvh_idx, kvh) + + ! kvm (in pbuf) is only used as an initial guess in compute_eddy_diff on the next timestep. + ! The contributions for molecular diffusion made to kvm by the call to compute_vdiff below + ! are not included in the pbuf as these are not needed in the initial guess by compute_eddy_diff. + call pbuf_set_field(pbuf, kvm_idx, kvm) + + !------------------------------------ ! + ! Application of diffusivities ! + !------------------------------------ ! + + ! Set arrays from input state. + q_tmp(:ncol,:,:) = state%q(:ncol,:,:) + s_tmp(:ncol,:) = state%s(:ncol,:) + u_tmp(:ncol,:) = state%u(:ncol,:) + v_tmp(:ncol,:) = state%v(:ncol,:) + + !------------------------------------------------------ ! + ! Write profile output before applying diffusion scheme ! + !------------------------------------------------------ ! + + if (.not. do_pbl_diags) then + sl_prePBL(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & + - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) + qt_prePBL(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & + + q_tmp(:ncol,:,ixcldice) + slv_prePBL(:ncol,:pver) = sl_prePBL(:ncol,:pver) * ( 1._r8 + zvir*qt_prePBL(:ncol,:pver) ) + + call qsat(state%t(:ncol,:), state%pmid(:ncol,:), & + tem2(:ncol,:), ftem(:ncol,:)) + ftem_prePBL(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 + + call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) + call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) + call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) + call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) + call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) + call outfld( 'qv_pre_PBL ', state%q(:ncol,:,1), pcols, lchnk ) + call outfld( 'ql_pre_PBL ', state%q(:ncol,:,ixcldliq), pcols, lchnk ) + call outfld( 'qi_pre_PBL ', state%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) + call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) + + end if + + ! --------------------------------------------------------------------------------- ! + ! Call the diffusivity solver and solve diffusion equation ! + ! The final two arguments are optional function references to ! + ! constituent-independent and constituent-dependent moleculuar diffusivity routines ! + ! --------------------------------------------------------------------------------- ! + + ! Modification : We may need to output 'tautotx_im,tautoty_im' from below 'compute_vdiff' and + ! separately print out as diagnostic output, because these are different from + ! the explicit 'tautotx, tautoty' computed above. + ! Note that the output 'tauresx,tauresy' from below subroutines are fully implicit ones. + + call pbuf_get_field(pbuf, kvt_idx, kvt) + + if (do_molec_diff .and. .not. waccmx_mode) then + ! Top boundary condition for dry static energy + dse_top(:ncol) = cpairv(:ncol,1,lchnk) * tint(:ncol,1) + & + gravit * state%zi(:ncol,1) + else + dse_top(:ncol) = 0._r8 + end if + + select case (eddy_scheme) + case ('CLUBB_SGS') + ! CLUBB applies some fluxes itself, but we still want constituent + ! fluxes applied here (except water vapor). + taux = 0._r8 + tauy = 0._r8 + shflux = 0._r8 + cflux(:,1) = 0._r8 + cflux(:,2:) = cam_in%cflx(:,2:) + case default + taux = cam_in%wsx + tauy = cam_in%wsy + shflux = cam_in%shf + cflux = cam_in%cflx + end select + + if( any(fieldlist_wet) ) then + + if (do_molec_diff) then + call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & + kvm, kvt, tint, rhoi, kq_scal, cnst_mw, & + mw_fac, nbot_molec) + end if + + call compute_vdiff( state%lchnk , & + pcols , pver , pcnst , ncol , tint , & + p , state%t , rhoi, ztodt , taux , & + tauy , shflux , cflux , & + kvh , kvm , kvq , cgs , cgh , & + state%zi , ksrftms , dragblj , & + qmincg , fieldlist_wet , fieldlist_molec,& + u_tmp , v_tmp , q_tmp , s_tmp , & + tautmsx , tautmsy , dtk , topflx , errstring , & + tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & + do_molec_diff, waccmx_mode, & + vd_lu_qdecomp, & + ubc_mmr, ubc_flux, kvt, state%pmid, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & + kq_scal, mw_fac) + + call handle_errmsg(errstring, subname="compute_vdiff", & + extra_msg="Error in fieldlist_wet call from vertical_diffusion.") + + end if + + if( any( fieldlist_dry ) ) then + + if( do_molec_diff ) then + ! kvm is unused in the output here (since it was assigned + ! above), so we use a temp kvm for the inout argument, and + ! ignore the value output by compute_molec_diff. + kvm_temp = kvm + call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & + kvm_temp, kvt, tint, rhoi_dry, kq_scal, cnst_mw, & + mw_fac, nbot_molec) + end if + + call compute_vdiff( state%lchnk , & + pcols , pver , pcnst , ncol , tint , & + p_dry , state%t , rhoi_dry, ztodt , taux , & + tauy , shflux , cflux , & + kvh , kvm , kvq , cgs , cgh , & + state%zi , ksrftms , dragblj , & + qmincg , fieldlist_dry , fieldlist_molec,& + u_tmp , v_tmp , q_tmp , s_tmp , & + tautmsx_temp , tautmsy_temp , dtk_temp , topflx_temp , errstring , & + tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & + do_molec_diff , waccmx_mode, & + vd_lu_qdecomp, & + ubc_mmr, ubc_flux, kvt, state%pmiddry, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & + kq_scal, mw_fac) + + call handle_errmsg(errstring, subname="compute_vdiff", & + extra_msg="Error in fieldlist_dry call from vertical_diffusion.") + + end if + + if (prog_modal_aero) then + + ! Modal aerosol species not diffused, so just add the explicit surface fluxes to the + ! lowest layer + + ! NOTE: Oslo aero adds emissions together with dry deposition +#ifndef OSLO_AERO + tmp1(:ncol) = ztodt * gravit * state%rpdel(:ncol,pver) + do m = 1, pmam_ncnst + l = pmam_cnst_idx(m) + q_tmp(:ncol,pver,l) = q_tmp(:ncol,pver,l) + tmp1(:ncol) * cam_in%cflx(:ncol,l) + enddo +#endif + end if + + ! -------------------------------------------------------- ! + ! Diagnostics and output writing after applying PBL scheme ! + ! -------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + sl(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & + - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) + qt(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & + + q_tmp(:ncol,:,ixcldice) + slv(:ncol,:pver) = sl(:ncol,:pver) * ( 1._r8 + zvir*qt(:ncol,:pver) ) + + slflx(:ncol,1) = 0._r8 + qtflx(:ncol,1) = 0._r8 + uflx(:ncol,1) = 0._r8 + vflx(:ncol,1) = 0._r8 + + slflx_cg(:ncol,1) = 0._r8 + qtflx_cg(:ncol,1) = 0._r8 + uflx_cg(:ncol,1) = 0._r8 + vflx_cg(:ncol,1) = 0._r8 + + do k = 2, pver + do i = 1, ncol + rhoair = state%pint(i,k) / ( rair * ( ( 0.5_r8*(slv(i,k)+slv(i,k-1)) - gravit*state%zi(i,k))/cpair ) ) + slflx(i,k) = kvh(i,k) * & + ( - rhoair*(sl(i,k-1)-sl(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & + + cgh(i,k) ) + qtflx(i,k) = kvh(i,k) * & + ( - rhoair*(qt(i,k-1)-qt(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & + + rhoair*(cam_in%cflx(i,1)+cam_in%cflx(i,ixcldliq)+cam_in%cflx(i,ixcldice))*cgs(i,k) ) + uflx(i,k) = kvm(i,k) * & + ( - rhoair*(u_tmp(i,k-1)-u_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) + vflx(i,k) = kvm(i,k) * & + ( - rhoair*(v_tmp(i,k-1)-v_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) + slflx_cg(i,k) = kvh(i,k) * cgh(i,k) + qtflx_cg(i,k) = kvh(i,k) * rhoair * ( cam_in%cflx(i,1) + & + cam_in%cflx(i,ixcldliq) + cam_in%cflx(i,ixcldice) ) * cgs(i,k) + uflx_cg(i,k) = 0._r8 + vflx_cg(i,k) = 0._r8 + end do + end do + + ! Modification : I should check whether slflx(:ncol,pverp) is correctly computed. + ! Note also that 'tautotx' is explicit total stress, different from + ! the ones that have been actually added into the atmosphere. + + slflx(:ncol,pverp) = cam_in%shf(:ncol) + qtflx(:ncol,pverp) = cam_in%cflx(:ncol,1) + uflx(:ncol,pverp) = tautotx(:ncol) + vflx(:ncol,pverp) = tautoty(:ncol) + + slflx_cg(:ncol,pverp) = 0._r8 + qtflx_cg(:ncol,pverp) = 0._r8 + uflx_cg(:ncol,pverp) = 0._r8 + vflx_cg(:ncol,pverp) = 0._r8 + + if (trim(shallow_scheme) == 'UNICON') then + call pbuf_get_field(pbuf, qtl_flx_idx, qtl_flx) + call pbuf_get_field(pbuf, qti_flx_idx, qti_flx) + qtl_flx(:ncol,1) = 0._r8 + qti_flx(:ncol,1) = 0._r8 + do k = 2, pver + do i = 1, ncol + ! For use in the cloud macrophysics + ! Note that density is not added here. Also, only consider local transport term. + qtl_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldliq)-q_tmp(i,k,ixcldliq))/& + (state%zm(i,k-1)-state%zm(i,k)) + qti_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldice)-q_tmp(i,k,ixcldice))/& + (state%zm(i,k-1)-state%zm(i,k)) + end do + end do + do i = 1, ncol + rhoair = state%pint(i,pverp)/(rair*((slv(i,pver)-gravit*state%zi(i,pverp))/cpair)) + qtl_flx(i,pverp) = cam_in%cflx(i,1)/rhoair + qti_flx(i,pverp) = cam_in%cflx(i,1)/rhoair + end do + end if + + end if + + ! --------------------------------------------------------------- ! + ! Convert the new profiles into vertical diffusion tendencies. ! + ! Convert KE dissipative heat change into "temperature" tendency. ! + ! --------------------------------------------------------------- ! + + ! All variables are modified by vertical diffusion + + lq(:) = .TRUE. + call physics_ptend_init(ptend,state%psetcols, "vertical diffusion", & + ls=.true., lu=.true., lv=.true., lq=lq) + + ptend%s(:ncol,:) = ( s_tmp(:ncol,:) - state%s(:ncol,:) ) * rztodt + ptend%u(:ncol,:) = ( u_tmp(:ncol,:) - state%u(:ncol,:) ) * rztodt + ptend%v(:ncol,:) = ( v_tmp(:ncol,:) - state%v(:ncol,:) ) * rztodt + ptend%q(:ncol,:pver,:) = ( q_tmp(:ncol,:pver,:) - state%q(:ncol,:pver,:) ) * rztodt + if (.not. do_pbl_diags) then + slten(:ncol,:) = ( sl(:ncol,:) - sl_prePBL(:ncol,:) ) * rztodt + qtten(:ncol,:) = ( qt(:ncol,:) - qt_prePBL(:ncol,:) ) * rztodt + end if + + ! ------------------------------------------------------------ ! + ! In order to perform 'pseudo-conservative variable diffusion' ! + ! perform the following two stages: ! + ! ! + ! I. Re-set (1) 'qvten' by 'qtten', and 'qlten = qiten = 0' ! + ! (2) 'sten' by 'slten', and ! + ! (3) 'qlten = qiten = 0' ! + ! ! + ! II. Apply 'positive_moisture' ! + ! ! + ! ------------------------------------------------------------ ! if( (eddy_scheme .eq. 'diag_TKE' .or. eddy_scheme .eq. 'SPCAM_m2005') .and. do_pseudocon_diff ) then - ptend%q(:ncol,:pver,1) = qtten(:ncol,:pver) - ptend%s(:ncol,:pver) = slten(:ncol,:pver) - ptend%q(:ncol,:pver,ixcldliq) = 0._r8 - ptend%q(:ncol,:pver,ixcldice) = 0._r8 - if (ixnumliq > 0) ptend%q(:ncol,:pver,ixnumliq) = 0._r8 - if (ixnumice > 0) ptend%q(:ncol,:pver,ixnumice) = 0._r8 - - do i = 1, ncol - do k = 1, pver - qv_pro(i,k) = state%q(i,k,1) + ptend%q(i,k,1) * ztodt - ql_pro(i,k) = state%q(i,k,ixcldliq) + ptend%q(i,k,ixcldliq) * ztodt - qi_pro(i,k) = state%q(i,k,ixcldice) + ptend%q(i,k,ixcldice) * ztodt - s_pro(i,k) = state%s(i,k) + ptend%s(i,k) * ztodt - t_pro(i,k) = state%t(i,k) + (1._r8/cpair)*ptend%s(i,k) * ztodt - end do - end do - - call positive_moisture( cpair, latvap, latvap+latice, ncol, pver, ztodt, qmin(1), qmin(ixcldliq), qmin(ixcldice), & - state%pdel(:ncol,pver:1:-1), qv_pro(:ncol,pver:1:-1), ql_pro(:ncol,pver:1:-1), & - qi_pro(:ncol,pver:1:-1), t_pro(:ncol,pver:1:-1), s_pro(:ncol,pver:1:-1), & - ptend%q(:ncol,pver:1:-1,1), ptend%q(:ncol,pver:1:-1,ixcldliq), & - ptend%q(:ncol,pver:1:-1,ixcldice), ptend%s(:ncol,pver:1:-1) ) - - end if - - ! ----------------------------------------------------------------- ! - ! Re-calculate diagnostic output variables after vertical diffusion ! - ! ----------------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - qv_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,1) + ptend%q(:ncol,:pver,1) * ztodt - ql_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + ptend%q(:ncol,:pver,ixcldliq) * ztodt - qi_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + ptend%q(:ncol,:pver,ixcldice) * ztodt - s_aft_PBL(:ncol,:pver) = state%s(:ncol,:pver) + ptend%s(:ncol,:pver) * ztodt - t_aftPBL(:ncol,:pver) = ( s_aft_PBL(:ncol,:pver) - gravit*state%zm(:ncol,:pver) ) / cpair - - u_aft_PBL(:ncol,:pver) = state%u(:ncol,:pver) + ptend%u(:ncol,:pver) * ztodt - v_aft_PBL(:ncol,:pver) = state%v(:ncol,:pver) + ptend%v(:ncol,:pver) * ztodt - - call qsat(t_aftPBL(:ncol,:pver), state%pmid(:ncol,:pver), & - tem2(:ncol,:pver), ftem(:ncol,:pver)) - ftem_aftPBL(:ncol,:pver) = qv_aft_PBL(:ncol,:pver) / ftem(:ncol,:pver) * 100._r8 - - tten(:ncol,:pver) = ( t_aftPBL(:ncol,:pver) - state%t(:ncol,:pver) ) * rztodt - rhten(:ncol,:pver) = ( ftem_aftPBL(:ncol,:pver) - ftem_prePBL(:ncol,:pver) ) * rztodt - - end if - - ! -------------------------------------------------------------- ! - ! mass conservation check......... - ! -------------------------------------------------------------- ! - if (diff_cnsrv_mass_check) then - - ! Conservation check - do m = 1, pcnst - fixed_ubc: if ((.not.cnst_fixed_ubc(m)).and.(.not.cnst_fixed_ubflx(m))) then - col_loop: do i = 1, ncol - sum1 = 0._r8 - sum2 = 0._r8 - sum3 = 0._r8 - do k = 1, pver - if(cnst_get_type_byind(m).eq.'wet') then - pdelx = state%pdel(i,k) - else - pdelx = state%pdeldry(i,k) - endif - sum1 = sum1 + state%q(i,k,m)*pdelx/gravit ! total column - sum2 = sum2 +(state%q(i,k,m)+ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! total column after tendancy is applied - sum3 = sum3 +( ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! rate of change in column - enddo - sum1 = sum1 + (cam_in%cflx(i,m) * ztodt) ! add in surface flux (kg/m2) - sflx = (cam_in%cflx(i,m) * ztodt) - if (sum1>1.e-36_r8) then - if( abs((sum2-sum1)/sum1) .gt. 1.e-12_r8 ) then - nstep = get_nstep() - write(iulog,'(a,a8,a,I4,2f8.3,5e25.16)') & - 'MASSCHECK vert diff : nstep,lon,lat,mass1,mass2,sum3,sflx,rel-diff : ', & - trim(cnst_name(m)), ' : ', nstep, state%lon(i)*180._r8/pi, state%lat(i)*180._r8/pi, & - sum1, sum2, sum3, sflx, abs(sum2-sum1)/sum1 - call endrun('vertical_diffusion_tend : mass not conserved' ) - endif - endif - enddo col_loop - endif fixed_ubc - enddo - endif - - ! -------------------------------------------------------------- ! - ! Writing state variables after PBL scheme for detailed analysis ! - ! -------------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - call outfld( 'sl_aft_PBL' , sl, pcols, lchnk ) - call outfld( 'qt_aft_PBL' , qt, pcols, lchnk ) - call outfld( 'slv_aft_PBL' , slv, pcols, lchnk ) - call outfld( 'u_aft_PBL' , u_aft_PBL, pcols, lchnk ) - call outfld( 'v_aft_PBL' , v_aft_PBL, pcols, lchnk ) - call outfld( 'qv_aft_PBL' , qv_aft_PBL, pcols, lchnk ) - call outfld( 'ql_aft_PBL' , ql_aft_PBL, pcols, lchnk ) - call outfld( 'qi_aft_PBL' , qi_aft_PBL, pcols, lchnk ) - call outfld( 't_aft_PBL ' , t_aftPBL, pcols, lchnk ) - call outfld( 'rh_aft_PBL' , ftem_aftPBL, pcols, lchnk ) - call outfld( 'slflx_PBL' , slflx, pcols, lchnk ) - call outfld( 'qtflx_PBL' , qtflx, pcols, lchnk ) - call outfld( 'uflx_PBL' , uflx, pcols, lchnk ) - call outfld( 'vflx_PBL' , vflx, pcols, lchnk ) - call outfld( 'slflx_cg_PBL' , slflx_cg, pcols, lchnk ) - call outfld( 'qtflx_cg_PBL' , qtflx_cg, pcols, lchnk ) - call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) - call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) - call outfld( 'slten_PBL' , slten, pcols, lchnk ) - call outfld( 'qtten_PBL' , qtten, pcols, lchnk ) - call outfld( 'uten_PBL' , ptend%u(:ncol,:), pcols, lchnk ) - call outfld( 'vten_PBL' , ptend%v(:ncol,:), pcols, lchnk ) - call outfld( 'qvten_PBL' , ptend%q(:ncol,:,1), pcols, lchnk ) - call outfld( 'qlten_PBL' , ptend%q(:ncol,:,ixcldliq), pcols, lchnk ) - call outfld( 'qiten_PBL' , ptend%q(:ncol,:,ixcldice), pcols, lchnk ) - call outfld( 'tten_PBL' , tten, pcols, lchnk ) - call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) - - end if - - ! ------------------------------------------- ! - ! Writing the other standard output variables ! - ! ------------------------------------------- ! - - if (.not. do_pbl_diags) then - call outfld( 'QT' , qt, pcols, lchnk ) - call outfld( 'SL' , sl, pcols, lchnk ) - call outfld( 'SLV' , slv, pcols, lchnk ) - call outfld( 'SLFLX' , slflx, pcols, lchnk ) - call outfld( 'QTFLX' , qtflx, pcols, lchnk ) - call outfld( 'UFLX' , uflx, pcols, lchnk ) - call outfld( 'VFLX' , vflx, pcols, lchnk ) - call outfld( 'TKE' , tke, pcols, lchnk ) - - call outfld( 'PBLH' , pblh, pcols, lchnk ) - call outfld( 'TPERT' , tpert, pcols, lchnk ) - call outfld( 'QPERT' , qpert, pcols, lchnk ) - end if - call outfld( 'USTAR' , ustar, pcols, lchnk ) - call outfld( 'KVH' , kvh, pcols, lchnk ) - call outfld( 'KVT' , kvt, pcols, lchnk ) - call outfld( 'KVM' , kvm, pcols, lchnk ) - call outfld( 'CGS' , cgs, pcols, lchnk ) - dtk(:ncol,:) = dtk(:ncol,:) / cpair ! Normalize heating for history - call outfld( 'DTVKE' , dtk, pcols, lchnk ) - dtk(:ncol,:) = ptend%s(:ncol,:) / cpair ! Normalize heating for history using dtk - call outfld( 'DTV' , dtk, pcols, lchnk ) - call outfld( 'DUV' , ptend%u, pcols, lchnk ) - call outfld( 'DVV' , ptend%v, pcols, lchnk ) - do m = 1, pcnst - call outfld( vdiffnam(m) , ptend%q(1,1,m), pcols, lchnk ) - end do - if( do_molec_diff ) then - call outfld( 'TTPXMLC' , topflx, pcols, lchnk ) - end if - - call p%finalize() - call p_dry%finalize() - - end subroutine vertical_diffusion_tend + ptend%q(:ncol,:pver,1) = qtten(:ncol,:pver) + ptend%s(:ncol,:pver) = slten(:ncol,:pver) + ptend%q(:ncol,:pver,ixcldliq) = 0._r8 + ptend%q(:ncol,:pver,ixcldice) = 0._r8 + if (ixnumliq > 0) ptend%q(:ncol,:pver,ixnumliq) = 0._r8 + if (ixnumice > 0) ptend%q(:ncol,:pver,ixnumice) = 0._r8 + + do i = 1, ncol + do k = 1, pver + qv_pro(i,k) = state%q(i,k,1) + ptend%q(i,k,1) * ztodt + ql_pro(i,k) = state%q(i,k,ixcldliq) + ptend%q(i,k,ixcldliq) * ztodt + qi_pro(i,k) = state%q(i,k,ixcldice) + ptend%q(i,k,ixcldice) * ztodt + s_pro(i,k) = state%s(i,k) + ptend%s(i,k) * ztodt + t_pro(i,k) = state%t(i,k) + (1._r8/cpair)*ptend%s(i,k) * ztodt + end do + end do + + call positive_moisture( cpair, latvap, latvap+latice, ncol, pver, ztodt, qmin(1), qmin(ixcldliq), qmin(ixcldice), & + state%pdel(:ncol,pver:1:-1), qv_pro(:ncol,pver:1:-1), ql_pro(:ncol,pver:1:-1), & + qi_pro(:ncol,pver:1:-1), t_pro(:ncol,pver:1:-1), s_pro(:ncol,pver:1:-1), & + ptend%q(:ncol,pver:1:-1,1), ptend%q(:ncol,pver:1:-1,ixcldliq), & + ptend%q(:ncol,pver:1:-1,ixcldice), ptend%s(:ncol,pver:1:-1) ) + + end if + + ! ----------------------------------------------------------------- ! + ! Re-calculate diagnostic output variables after vertical diffusion ! + ! ----------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + qv_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,1) + ptend%q(:ncol,:pver,1) * ztodt + ql_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + ptend%q(:ncol,:pver,ixcldliq) * ztodt + qi_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + ptend%q(:ncol,:pver,ixcldice) * ztodt + s_aft_PBL(:ncol,:pver) = state%s(:ncol,:pver) + ptend%s(:ncol,:pver) * ztodt + t_aftPBL(:ncol,:pver) = ( s_aft_PBL(:ncol,:pver) - gravit*state%zm(:ncol,:pver) ) / cpair + + u_aft_PBL(:ncol,:pver) = state%u(:ncol,:pver) + ptend%u(:ncol,:pver) * ztodt + v_aft_PBL(:ncol,:pver) = state%v(:ncol,:pver) + ptend%v(:ncol,:pver) * ztodt + + call qsat(t_aftPBL(:ncol,:pver), state%pmid(:ncol,:pver), & + tem2(:ncol,:pver), ftem(:ncol,:pver)) + ftem_aftPBL(:ncol,:pver) = qv_aft_PBL(:ncol,:pver) / ftem(:ncol,:pver) * 100._r8 + + tten(:ncol,:pver) = ( t_aftPBL(:ncol,:pver) - state%t(:ncol,:pver) ) * rztodt + rhten(:ncol,:pver) = ( ftem_aftPBL(:ncol,:pver) - ftem_prePBL(:ncol,:pver) ) * rztodt + + end if + + ! -------------------------------------------------------------- ! + ! mass conservation check......... + ! -------------------------------------------------------------- ! + if (diff_cnsrv_mass_check) then + + ! Conservation check + do m = 1, pcnst + fixed_ubc: if ((.not.cnst_fixed_ubc(m)).and.(.not.cnst_fixed_ubflx(m))) then + col_loop: do i = 1, ncol + sum1 = 0._r8 + sum2 = 0._r8 + sum3 = 0._r8 + do k = 1, pver + if(cnst_get_type_byind(m).eq.'wet') then + pdelx = state%pdel(i,k) + else + pdelx = state%pdeldry(i,k) + endif + sum1 = sum1 + state%q(i,k,m)*pdelx/gravit ! total column + sum2 = sum2 +(state%q(i,k,m)+ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! total column after tendancy is applied + sum3 = sum3 +( ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! rate of change in column + enddo + sum1 = sum1 + (cam_in%cflx(i,m) * ztodt) ! add in surface flux (kg/m2) + sflx = (cam_in%cflx(i,m) * ztodt) + if (sum1>1.e-36_r8) then + if( abs((sum2-sum1)/sum1) .gt. 1.e-12_r8 ) then + nstep = get_nstep() + write(iulog,'(a,a8,a,I4,2f8.3,5e25.16)') & + 'MASSCHECK vert diff : nstep,lon,lat,mass1,mass2,sum3,sflx,rel-diff : ', & + trim(cnst_name(m)), ' : ', nstep, state%lon(i)*180._r8/pi, state%lat(i)*180._r8/pi, & + sum1, sum2, sum3, sflx, abs(sum2-sum1)/sum1 + call endrun('vertical_diffusion_tend : mass not conserved' ) + endif + endif + enddo col_loop + endif fixed_ubc + enddo + endif + + ! -------------------------------------------------------------- ! + ! Writing state variables after PBL scheme for detailed analysis ! + ! -------------------------------------------------------------- ! + + if (.not. do_pbl_diags) then + + call outfld( 'sl_aft_PBL' , sl, pcols, lchnk ) + call outfld( 'qt_aft_PBL' , qt, pcols, lchnk ) + call outfld( 'slv_aft_PBL' , slv, pcols, lchnk ) + call outfld( 'u_aft_PBL' , u_aft_PBL, pcols, lchnk ) + call outfld( 'v_aft_PBL' , v_aft_PBL, pcols, lchnk ) + call outfld( 'qv_aft_PBL' , qv_aft_PBL, pcols, lchnk ) + call outfld( 'ql_aft_PBL' , ql_aft_PBL, pcols, lchnk ) + call outfld( 'qi_aft_PBL' , qi_aft_PBL, pcols, lchnk ) + call outfld( 't_aft_PBL ' , t_aftPBL, pcols, lchnk ) + call outfld( 'rh_aft_PBL' , ftem_aftPBL, pcols, lchnk ) + call outfld( 'slflx_PBL' , slflx, pcols, lchnk ) + call outfld( 'qtflx_PBL' , qtflx, pcols, lchnk ) + call outfld( 'uflx_PBL' , uflx, pcols, lchnk ) + call outfld( 'vflx_PBL' , vflx, pcols, lchnk ) + call outfld( 'slflx_cg_PBL' , slflx_cg, pcols, lchnk ) + call outfld( 'qtflx_cg_PBL' , qtflx_cg, pcols, lchnk ) + call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) + call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) + call outfld( 'slten_PBL' , slten, pcols, lchnk ) + call outfld( 'qtten_PBL' , qtten, pcols, lchnk ) + call outfld( 'uten_PBL' , ptend%u(:ncol,:), pcols, lchnk ) + call outfld( 'vten_PBL' , ptend%v(:ncol,:), pcols, lchnk ) + call outfld( 'qvten_PBL' , ptend%q(:ncol,:,1), pcols, lchnk ) + call outfld( 'qlten_PBL' , ptend%q(:ncol,:,ixcldliq), pcols, lchnk ) + call outfld( 'qiten_PBL' , ptend%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 'tten_PBL' , tten, pcols, lchnk ) + call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) + + end if + + ! ------------------------------------------- ! + ! Writing the other standard output variables ! + ! ------------------------------------------- ! + + if (.not. do_pbl_diags) then + call outfld( 'QT' , qt, pcols, lchnk ) + call outfld( 'SL' , sl, pcols, lchnk ) + call outfld( 'SLV' , slv, pcols, lchnk ) + call outfld( 'SLFLX' , slflx, pcols, lchnk ) + call outfld( 'QTFLX' , qtflx, pcols, lchnk ) + call outfld( 'UFLX' , uflx, pcols, lchnk ) + call outfld( 'VFLX' , vflx, pcols, lchnk ) + call outfld( 'TKE' , tke, pcols, lchnk ) + + call outfld( 'PBLH' , pblh, pcols, lchnk ) + call outfld( 'TPERT' , tpert, pcols, lchnk ) + call outfld( 'QPERT' , qpert, pcols, lchnk ) + end if + call outfld( 'USTAR' , ustar, pcols, lchnk ) + call outfld( 'KVH' , kvh, pcols, lchnk ) + call outfld( 'KVT' , kvt, pcols, lchnk ) + call outfld( 'KVM' , kvm, pcols, lchnk ) + call outfld( 'CGS' , cgs, pcols, lchnk ) + dtk(:ncol,:) = dtk(:ncol,:) / cpair ! Normalize heating for history + call outfld( 'DTVKE' , dtk, pcols, lchnk ) + dtk(:ncol,:) = ptend%s(:ncol,:) / cpair ! Normalize heating for history using dtk + call outfld( 'DTV' , dtk, pcols, lchnk ) + call outfld( 'DUV' , ptend%u, pcols, lchnk ) + call outfld( 'DVV' , ptend%v, pcols, lchnk ) + do m = 1, pcnst + call outfld( vdiffnam(m) , ptend%q(1,1,m), pcols, lchnk ) + end do + if( do_molec_diff ) then + call outfld( 'TTPXMLC' , topflx, pcols, lchnk ) + end if + + call p%finalize() + call p_dry%finalize() + +end subroutine vertical_diffusion_tend - ! =============================================================================== ! - subroutine positive_moisture( cp, xlv, xls, ncol, mkx, dt, qvmin, qlmin, qimin, & - dp, qv, ql, qi, t, s, qvten, qlten, qiten, sten ) - ! ------------------------------------------------------------------------------- ! - ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! - ! force them to be larger than minimum value by (1) condensating water vapor ! - ! into liquid or ice, and (2) by transporting water vapor from the very lower ! - ! layer. '2._r8' is multiplied to the minimum values for safety. ! - ! Update final state variables and tendencies associated with this correction. ! - ! If any condensation happens, update (s,t) too. ! - ! Note that (qv,ql,qi,t,s) are final state variables after applying corresponding ! - ! input tendencies. ! - ! Be careful the order of k : '1': near-surface layer, 'mkx' : top layer ! - ! ------------------------------------------------------------------------------- ! - implicit none - integer, intent(in) :: ncol, mkx - real(r8), intent(in) :: cp, xlv, xls - real(r8), intent(in) :: dt, qvmin, qlmin, qimin - real(r8), intent(in) :: dp(ncol,mkx) - real(r8), intent(inout) :: qv(ncol,mkx), ql(ncol,mkx), qi(ncol,mkx), t(ncol,mkx), s(ncol,mkx) - real(r8), intent(inout) :: qvten(ncol,mkx), qlten(ncol,mkx), qiten(ncol,mkx), sten(ncol,mkx) - integer i, k - real(r8) dql, dqi, dqv, sum, aa, dum - - ! Modification : I should check whether this is exactly same as the one used in - ! shallow convection and cloud macrophysics. - - do i = 1, ncol - do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface - dql = max(0._r8,1._r8*qlmin-ql(i,k)) - dqi = max(0._r8,1._r8*qimin-qi(i,k)) - qlten(i,k) = qlten(i,k) + dql/dt - qiten(i,k) = qiten(i,k) + dqi/dt - qvten(i,k) = qvten(i,k) - (dql+dqi)/dt - sten(i,k) = sten(i,k) + xlv * (dql/dt) + xls * (dqi/dt) - ql(i,k) = ql(i,k) + dql - qi(i,k) = qi(i,k) + dqi - qv(i,k) = qv(i,k) - dql - dqi - s(i,k) = s(i,k) + xlv * dql + xls * dqi - t(i,k) = t(i,k) + (xlv * dql + xls * dqi)/cp - dqv = max(0._r8,1._r8*qvmin-qv(i,k)) - qvten(i,k) = qvten(i,k) + dqv/dt - qv(i,k) = qv(i,k) + dqv - if( k .ne. 1 ) then - qv(i,k-1) = qv(i,k-1) - dqv*dp(i,k)/dp(i,k-1) - qvten(i,k-1) = qvten(i,k-1) - dqv*dp(i,k)/dp(i,k-1)/dt - endif - qv(i,k) = max(qv(i,k),qvmin) - ql(i,k) = max(ql(i,k),qlmin) - qi(i,k) = max(qi(i,k),qimin) - end do - ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally - ! extracted from all the layers that has 'qv > 2*qvmin'. This fully - ! preserves column moisture. - if( dqv .gt. 1.e-20_r8 ) then - sum = 0._r8 - do k = 1, mkx - if( qv(i,k) .gt. 2._r8*qvmin ) sum = sum + qv(i,k)*dp(i,k) - enddo - aa = dqv*dp(i,1)/max(1.e-20_r8,sum) - if( aa .lt. 0.5_r8 ) then - do k = 1, mkx - if( qv(i,k) .gt. 2._r8*qvmin ) then - dum = aa*qv(i,k) - qv(i,k) = qv(i,k) - dum - qvten(i,k) = qvten(i,k) - dum/dt - endif - enddo - else - write(iulog,*) 'Full positive_moisture is impossible in vertical_diffusion' - endif - endif - end do - return - - end subroutine positive_moisture +! =============================================================================== ! +! ! +! =============================================================================== ! + +subroutine positive_moisture( cp, xlv, xls, ncol, mkx, dt, qvmin, qlmin, qimin, & + dp, qv, ql, qi, t, s, qvten, qlten, qiten, sten ) + ! ------------------------------------------------------------------------------- ! + ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! + ! force them to be larger than minimum value by (1) condensating water vapor ! + ! into liquid or ice, and (2) by transporting water vapor from the very lower ! + ! layer. '2._r8' is multiplied to the minimum values for safety. ! + ! Update final state variables and tendencies associated with this correction. ! + ! If any condensation happens, update (s,t) too. ! + ! Note that (qv,ql,qi,t,s) are final state variables after applying corresponding ! + ! input tendencies. ! + ! Be careful the order of k : '1': near-surface layer, 'mkx' : top layer ! + ! ------------------------------------------------------------------------------- ! + implicit none + integer, intent(in) :: ncol, mkx + real(r8), intent(in) :: cp, xlv, xls + real(r8), intent(in) :: dt, qvmin, qlmin, qimin + real(r8), intent(in) :: dp(ncol,mkx) + real(r8), intent(inout) :: qv(ncol,mkx), ql(ncol,mkx), qi(ncol,mkx), t(ncol,mkx), s(ncol,mkx) + real(r8), intent(inout) :: qvten(ncol,mkx), qlten(ncol,mkx), qiten(ncol,mkx), sten(ncol,mkx) + integer i, k + real(r8) dql, dqi, dqv, sum, aa, dum + + ! Modification : I should check whether this is exactly same as the one used in + ! shallow convection and cloud macrophysics. + + do i = 1, ncol + do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface + dql = max(0._r8,1._r8*qlmin-ql(i,k)) + dqi = max(0._r8,1._r8*qimin-qi(i,k)) + qlten(i,k) = qlten(i,k) + dql/dt + qiten(i,k) = qiten(i,k) + dqi/dt + qvten(i,k) = qvten(i,k) - (dql+dqi)/dt + sten(i,k) = sten(i,k) + xlv * (dql/dt) + xls * (dqi/dt) + ql(i,k) = ql(i,k) + dql + qi(i,k) = qi(i,k) + dqi + qv(i,k) = qv(i,k) - dql - dqi + s(i,k) = s(i,k) + xlv * dql + xls * dqi + t(i,k) = t(i,k) + (xlv * dql + xls * dqi)/cp + dqv = max(0._r8,1._r8*qvmin-qv(i,k)) + qvten(i,k) = qvten(i,k) + dqv/dt + qv(i,k) = qv(i,k) + dqv + if( k .ne. 1 ) then + qv(i,k-1) = qv(i,k-1) - dqv*dp(i,k)/dp(i,k-1) + qvten(i,k-1) = qvten(i,k-1) - dqv*dp(i,k)/dp(i,k-1)/dt + endif + qv(i,k) = max(qv(i,k),qvmin) + ql(i,k) = max(ql(i,k),qlmin) + qi(i,k) = max(qi(i,k),qimin) + end do + ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally + ! extracted from all the layers that has 'qv > 2*qvmin'. This fully + ! preserves column moisture. + if( dqv .gt. 1.e-20_r8 ) then + sum = 0._r8 + do k = 1, mkx + if( qv(i,k) .gt. 2._r8*qvmin ) sum = sum + qv(i,k)*dp(i,k) + enddo + aa = dqv*dp(i,1)/max(1.e-20_r8,sum) + if( aa .lt. 0.5_r8 ) then + do k = 1, mkx + if( qv(i,k) .gt. 2._r8*qvmin ) then + dum = aa*qv(i,k) + qv(i,k) = qv(i,k) - dum + qvten(i,k) = qvten(i,k) - dum/dt + endif + enddo + else + write(iulog,*) 'Full positive_moisture is impossible in vertical_diffusion' + endif + endif + end do + return + +end subroutine positive_moisture end module vertical_diffusion From 9553e23a3e32e3efee11c7a09d65a655d37d8ea8 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 4 Sep 2023 12:33:37 +0200 Subject: [PATCH 53/71] moved vertical diffusion to physics/cam and removed cam_oslo directory --- bld/configure | 11 +- src/physics/cam/vertical_diffusion.F90 | 27 +- src/physics/cam_oslo/vertical_diffusion.F90 | 1551 ------------------- 3 files changed, 24 insertions(+), 1565 deletions(-) delete mode 100644 src/physics/cam_oslo/vertical_diffusion.F90 diff --git a/bld/configure b/bld/configure index cdea30d292..4e996ef4bc 100755 --- a/bld/configure +++ b/bld/configure @@ -2753,11 +2753,11 @@ sub write_filepath print $fh "$CASEROOT/SourceMods/src.cam\n"; } - #NorESM-specific: - #Any files in "NorESM"-folder go before the original CAM-files - #These files MUST give back standard CAM5.3 if a standard CAM5.3 compset is chosen - #Un-commenting this line will give back standard CAM 5.3 (unmodified). - #This is used for testing. + # NorESM-specific: + # Any files in "NorESM"-folder go before the original CAM-files + # These files MUST give back standard CAM5.3 if a standard CAM5.3 compset is chosen + # Un-commenting this line will give back standard CAM 5.3 (unmodified). + # This is used for testing. #++djlo (should be switched off when pure NCAR version is desired) print $fh "$camsrcdir/cam/src/NorESM\n"; print $fh "$camsrcdir/cam/src/NorESM/$dyn\n"; @@ -2789,7 +2789,6 @@ sub write_filepath } if ($chem =~/_oslo/) { print $fh "$camsrcdir/cam/src/chemistry/oslo_aero\n"; - print $fh "$camsrcdir/cam/src/physics/cam_oslo\n"; } else{ if ($chem =~ /_mam/) { diff --git a/src/physics/cam/vertical_diffusion.F90 b/src/physics/cam/vertical_diffusion.F90 index d74a16a512..ec48a4cb6e 100644 --- a/src/physics/cam/vertical_diffusion.F90 +++ b/src/physics/cam/vertical_diffusion.F90 @@ -72,6 +72,9 @@ module vertical_diffusion use ref_pres, only : do_molec_diff, nbot_molec use phys_control, only : phys_getopts use time_manager, only : is_first_step +#ifdef OSLO_AERO + use oslo_aero_share, only: getNumberOfAerosolTracers, fillAerosolTracerList +#endif implicit none private @@ -318,15 +321,15 @@ subroutine vertical_diffusion_init(pbuf2d) ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. call phys_getopts(prog_modal_aero_out=prog_modal_aero) - if (prog_modal_aero) then - - ! Get the constituent indices of the number and mass mixing ratios of the modal - ! aerosols. - ! - ! N.B. - This implementation assumes that the prognostic modal aerosols are - ! impacting the climate calculation (i.e., can get info from list 0). - ! +#ifdef OSLO_AERO + prog_modal_aero = .TRUE. + pmam_ncnst = getNumberOfAerosolTracers() + allocate(pmam_cnst_idx(pmam_ncnst)) + call fillAerosolTracerList(pmam_cnst_idx) +#else + !NOTE THAT THIS BREAKS THE CONCEPT OF KEEPEING MAM-AEROSOLS OUT OF + !DIFFUSION, BUT IF YOU ARE USING MAM, YOU SHOULD NOT BEE HERE ANYWAY!! ! First need total number of mam constituents call rad_cnst_get_info(0, nmodes=nmodes) do m = 1, nmodes @@ -348,6 +351,7 @@ subroutine vertical_diffusion_init(pbuf2d) end do end do end if +#endif ! Initialize upper boundary condition module @@ -574,6 +578,10 @@ subroutine vertical_diffusion_init(pbuf2d) if( history_budget ) then call add_default( vdiffnam(ixcldliq), history_budget_histfile_num, ' ' ) call add_default( vdiffnam(ixcldice), history_budget_histfile_num, ' ' ) +#ifdef OSLO_AERO + call add_default( vdiffnam(ixnumliq), history_budget_histfile_num, ' ' ) + call add_default( vdiffnam(ixnumice), history_budget_histfile_num, ' ' ) +#endif if( history_budget_histfile_num > 1 ) then call add_default( vdiffnam(1), history_budget_histfile_num, ' ' ) call add_default( 'DTV' , history_budget_histfile_num, ' ' ) @@ -1170,11 +1178,14 @@ subroutine vertical_diffusion_tend( & ! Modal aerosol species not diffused, so just add the explicit surface fluxes to the ! lowest layer + ! NOTE: Oslo aero adds emissions together with dry deposition +#ifndef OSLO_AERO tmp1(:ncol) = ztodt * gravit * state%rpdel(:ncol,pver) do m = 1, pmam_ncnst l = pmam_cnst_idx(m) q_tmp(:ncol,pver,l) = q_tmp(:ncol,pver,l) + tmp1(:ncol) * cam_in%cflx(:ncol,l) enddo +#endif end if ! -------------------------------------------------------- ! diff --git a/src/physics/cam_oslo/vertical_diffusion.F90 b/src/physics/cam_oslo/vertical_diffusion.F90 deleted file mode 100644 index ec48a4cb6e..0000000000 --- a/src/physics/cam_oslo/vertical_diffusion.F90 +++ /dev/null @@ -1,1551 +0,0 @@ -module vertical_diffusion - -!----------------------------------------------------------------------------------------------------- ! -! Module to compute vertical diffusion of momentum, moisture, trace constituents ! -! and static energy. Separate modules compute ! -! 1. stresses associated with turbulent flow over orography ! -! ( turbulent mountain stress ) ! -! 2. eddy diffusivities, including nonlocal tranport terms ! -! 3. molecular diffusivities ! -! Lastly, a implicit diffusion solver is called, and tendencies retrieved by ! -! differencing the diffused and initial states. ! -! ! -! Calling sequence: ! -! ! -! vertical_diffusion_init Initializes vertical diffustion constants and modules ! -! init_molec_diff Initializes molecular diffusivity module ! -! init_eddy_diff Initializes eddy diffusivity module (includes PBL) ! -! init_tms Initializes turbulent mountain stress module ! -! init_vdiff Initializes diffusion solver module ! -! vertical_diffusion_ts_init Time step initialization (only used for upper boundary condition) ! -! vertical_diffusion_tend Computes vertical diffusion tendencies ! -! compute_tms Computes turbulent mountain stresses ! -! compute_eddy_diff Computes eddy diffusivities and countergradient terms ! -! compute_vdiff Solves vertical diffusion equations, including molecular diffusivities ! -! ! -!----------------------------------------------------------------------------------------------------- ! -! Some notes on refactoring changes made in 2015, which were not quite finished. ! -! ! -! - eddy_diff_tend should really only have state, pbuf, and cam_in as inputs. The process of ! -! removing these arguments, and referring to pbuf fields instead, is not complete. ! -! ! -! - compute_vdiff was intended to be split up into three components: ! -! ! -! 1. Diffusion of winds and heat ("U", "V", and "S" in the fieldlist object). ! -! ! -! 2. Turbulent diffusion of a single constituent ! -! ! -! 3. Molecular diffusion of a single constituent ! -! ! -! This reorganization would allow the three resulting functions to each use a simpler interface ! -! than the current combined version, and possibly also remove the need to use the fieldlist ! -! object at all. ! -! ! -! - The conditionals controlled by "do_pbl_diags" are somewhat scattered. It might be better to ! -! pull out these diagnostic calculations and outfld calls into separate functions. ! -! ! -!---------------------------Code history-------------------------------------------------------------- ! -! J. Rosinski : Jun. 1992 ! -! J. McCaa : Sep. 2004 ! -! S. Park : Aug. 2006, Dec. 2008. Jan. 2010 ! -!----------------------------------------------------------------------------------------------------- ! - -use shr_kind_mod, only : r8 => shr_kind_r8, i4=> shr_kind_i4 -use ppgrid, only : pcols, pver, pverp -use constituents, only : pcnst -use diffusion_solver, only : vdiff_selector -use cam_abortutils, only : endrun -use error_messages, only : handle_errmsg -use physconst, only : & - cpair , & ! Specific heat of dry air - gravit , & ! Acceleration due to gravity - rair , & ! Gas constant for dry air - zvir , & ! rh2o/rair - 1 - latvap , & ! Latent heat of vaporization - latice , & ! Latent heat of fusion - karman , & ! von Karman constant - mwdry , & ! Molecular weight of dry air - avogad ! Avogadro's number -use cam_history, only : fieldname_len -use perf_mod -use cam_logfile, only : iulog -use ref_pres, only : do_molec_diff, nbot_molec -use phys_control, only : phys_getopts -use time_manager, only : is_first_step -#ifdef OSLO_AERO - use oslo_aero_share, only: getNumberOfAerosolTracers, fillAerosolTracerList -#endif - -implicit none -private -save - -! ----------------- ! -! Public interfaces ! -! ----------------- ! - -public vd_readnl -public vd_register ! Register multi-time-level variables with physics buffer -public vertical_diffusion_init ! Initialization -public vertical_diffusion_ts_init ! Time step initialization (only used for upper boundary condition) -public vertical_diffusion_tend ! Full vertical diffusion routine - -! ------------ ! -! Private data ! -! ------------ ! - -character(len=16) :: eddy_scheme ! Default set in phys_control.F90, use namelist to change -! 'HB' = Holtslag and Boville (default) -! 'HBR' = Holtslag and Boville and Rash -! 'diag_TKE' = Bretherton and Park ( UW Moist Turbulence Scheme ) -logical, parameter :: wstarent = .true. ! Use wstar (.true.) or TKE (.false.) entrainment closure -! ( when 'diag_TKE' scheme is selected ) -logical :: do_pseudocon_diff = .false. ! If .true., do pseudo-conservative variables diffusion - -character(len=16) :: shallow_scheme ! Shallow convection scheme - -type(vdiff_selector) :: fieldlist_wet ! Logical switches for moist mixing ratio diffusion -type(vdiff_selector) :: fieldlist_dry ! Logical switches for dry mixing ratio diffusion -type(vdiff_selector) :: fieldlist_molec ! Logical switches for molecular diffusion -integer :: tke_idx, kvh_idx, kvm_idx ! TKE and eddy diffusivity indices for fields in the physics buffer -integer :: kvt_idx ! Index for kinematic molecular conductivity -integer :: turbtype_idx, smaw_idx ! Turbulence type and instability functions -integer :: tauresx_idx, tauresy_idx ! Redisual stress for implicit surface stress - -character(len=fieldname_len) :: vdiffnam(pcnst) ! Names of vertical diffusion tendencies -integer :: ixcldice, ixcldliq ! Constituent indices for cloud liquid and ice water -integer :: ixnumice, ixnumliq - -integer :: pblh_idx, tpert_idx, qpert_idx - -! pbuf fields for unicon -integer :: qtl_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on -integer :: qti_flx_idx = -1 ! for use in cloud macrophysics when UNICON is on - -! pbuf fields for tms -integer :: ksrftms_idx = -1 -integer :: tautmsx_idx = -1 -integer :: tautmsy_idx = -1 - -! pbuf fields for blj (Beljaars) -integer :: dragblj_idx = -1 -integer :: taubljx_idx = -1 -integer :: taubljy_idx = -1 - -logical :: diff_cnsrv_mass_check ! do mass conservation check -logical :: do_iss ! switch for implicit turbulent surface stress -logical :: prog_modal_aero = .false. ! set true if prognostic modal aerosols are present -integer :: pmam_ncnst = 0 ! number of prognostic modal aerosol constituents -integer, allocatable :: pmam_cnst_idx(:) ! constituent indices of prognostic modal aerosols - -logical :: do_pbl_diags = .false. -logical :: waccmx_mode = .false. - -contains - - ! =============================================================================== ! - ! ! - ! =============================================================================== ! -subroutine vd_readnl(nlfile) - - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: masterproc, masterprocid, mpi_logical, mpicom - use shr_log_mod, only: errMsg => shr_log_errMsg - use trb_mtn_stress_cam, only: trb_mtn_stress_readnl - use beljaars_drag_cam, only: beljaars_drag_readnl - use eddy_diff_cam, only: eddy_diff_readnl - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'vd_readnl' - - namelist /vert_diff_nl/ diff_cnsrv_mass_check, do_iss - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'vert_diff_nl', status=ierr) - if (ierr == 0) then - read(unitn, vert_diff_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if - - call mpi_bcast(diff_cnsrv_mass_check, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") - call mpi_bcast(do_iss, 1, mpi_logical, masterprocid, mpicom, ierr) - if (ierr /= 0) call endrun(errMsg(__FILE__, __LINE__)//" mpi_bcast error") - - ! Get eddy_scheme setting from phys_control. - call phys_getopts( eddy_scheme_out = eddy_scheme, & - shallow_scheme_out = shallow_scheme ) - - ! TMS reads its own namelist. - call trb_mtn_stress_readnl(nlfile) - - ! Beljaars reads its own namelist. - call beljaars_drag_readnl(nlfile) - - if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005' ) call eddy_diff_readnl(nlfile) - -end subroutine vd_readnl - -! =============================================================================== ! -! ! -! =============================================================================== ! - -subroutine vd_register() - - !------------------------------------------------ ! - ! Register physics buffer fields and constituents ! - !------------------------------------------------ ! - - use physics_buffer, only : pbuf_add_field, dtype_r8, dtype_i4 - use trb_mtn_stress_cam, only : trb_mtn_stress_register - use beljaars_drag_cam, only : beljaars_drag_register - use eddy_diff_cam, only : eddy_diff_register - - ! Add fields to physics buffer - - ! kvt is used by gw_drag. only needs physpkg scope. - call pbuf_add_field('kvt', 'physpkg', dtype_r8, (/pcols,pverp/), kvt_idx) - - - if (eddy_scheme /= 'CLUBB_SGS') then - call pbuf_add_field('kvh', 'global', dtype_r8, (/pcols, pverp/), kvh_idx) - end if - - call pbuf_add_field('kvm', 'global', dtype_r8, (/pcols, pverp/), kvm_idx ) - call pbuf_add_field('pblh', 'global', dtype_r8, (/pcols/), pblh_idx) - call pbuf_add_field('tke', 'global', dtype_r8, (/pcols, pverp/), tke_idx) - call pbuf_add_field('turbtype', 'global', dtype_i4, (/pcols, pverp/), turbtype_idx) - call pbuf_add_field('smaw', 'global', dtype_r8, (/pcols, pverp/), smaw_idx) - - call pbuf_add_field('tauresx', 'global', dtype_r8, (/pcols/), tauresx_idx) - call pbuf_add_field('tauresy', 'global', dtype_r8, (/pcols/), tauresy_idx) - - call pbuf_add_field('tpert', 'global', dtype_r8, (/pcols/), tpert_idx) - call pbuf_add_field('qpert', 'global', dtype_r8, (/pcols,pcnst/), qpert_idx) - - if (trim(shallow_scheme) == 'UNICON') then - call pbuf_add_field('qtl_flx', 'global', dtype_r8, (/pcols, pverp/), qtl_flx_idx) - call pbuf_add_field('qti_flx', 'global', dtype_r8, (/pcols, pverp/), qti_flx_idx) - end if - - ! diag_TKE fields - if (eddy_scheme == 'diag_TKE' .or. eddy_scheme == 'SPCAM_m2005') then - call eddy_diff_register() - end if - - ! TMS fields - call trb_mtn_stress_register() - - ! Beljaars fields - call beljaars_drag_register() - -end subroutine vd_register - -! =============================================================================== ! -! ! -! =============================================================================== ! - -subroutine vertical_diffusion_init(pbuf2d) - - !------------------------------------------------------------------! - ! Initialization of time independent fields for vertical diffusion ! - ! Calls initialization routines for subsidiary modules ! - !----------------------------------------------------------------- ! - - use cam_history, only : addfld, add_default, horiz_only - use cam_history, only : register_vector_field - use eddy_diff_cam, only : eddy_diff_init - use hb_diff, only : init_hb_diff - use molec_diff, only : init_molec_diff - use diffusion_solver, only : init_vdiff, new_fieldlist_vdiff, vdiff_select - use constituents, only : cnst_get_ind, cnst_get_type_byind, cnst_name, cnst_get_molec_byind - use spmd_utils, only : masterproc - use ref_pres, only : press_lim_idx, pref_mid - use physics_buffer, only : pbuf_set_field, pbuf_get_index, physics_buffer_desc - use rad_constituents, only : rad_cnst_get_info, rad_cnst_get_mode_num_idx, & - rad_cnst_get_mam_mmr_idx - use trb_mtn_stress_cam,only : trb_mtn_stress_init - use beljaars_drag_cam, only : beljaars_drag_init - use upper_bc, only : ubc_init - use phys_control, only : waccmx_is, fv_am_correction - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - character(128) :: errstring ! Error status for init_vdiff - integer :: ntop_eddy ! Top interface level to which eddy vertical diffusion is applied ( = 1 ) - integer :: nbot_eddy ! Bottom interface level to which eddy vertical diffusion is applied ( = pver ) - integer :: k ! Vertical loop index - - real(r8), parameter :: ntop_eddy_pres = 1.e-5_r8 ! Pressure below which eddy diffusion is not done in WACCM-X. (Pa) - - integer :: im, l, m, nmodes, nspec - - logical :: history_amwg ! output the variables used by the AMWG diag package - logical :: history_eddy ! output the eddy variables - logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi - integer :: history_budget_histfile_num ! output history file number for budget fields - logical :: history_waccm ! output variables of interest for WACCM runs - - ! ----------------------------------------------------------------- ! - - if (masterproc) then - write(iulog,*)'Initializing vertical diffusion (vertical_diffusion_init)' - end if - - ! Check to see if WACCM-X is on (currently we don't care whether the - ! ionosphere is on or not, since this neutral diffusion code is the - ! same either way). - waccmx_mode = waccmx_is('ionosphere') .or. waccmx_is('neutral') - - ! ----------------------------------------------------------------- ! - ! Get indices of cloud liquid and ice within the constituents array ! - ! ----------------------------------------------------------------- ! - - call cnst_get_ind( 'CLDLIQ', ixcldliq ) - call cnst_get_ind( 'CLDICE', ixcldice ) - ! These are optional; with the CAM4 microphysics, there are no number - ! constituents. - call cnst_get_ind( 'NUMLIQ', ixnumliq, abort=.false. ) - call cnst_get_ind( 'NUMICE', ixnumice, abort=.false. ) - - ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. - call phys_getopts(prog_modal_aero_out=prog_modal_aero) - -#ifdef OSLO_AERO - prog_modal_aero = .TRUE. - pmam_ncnst = getNumberOfAerosolTracers() - allocate(pmam_cnst_idx(pmam_ncnst)) - call fillAerosolTracerList(pmam_cnst_idx) -#else - !NOTE THAT THIS BREAKS THE CONCEPT OF KEEPEING MAM-AEROSOLS OUT OF - !DIFFUSION, BUT IF YOU ARE USING MAM, YOU SHOULD NOT BEE HERE ANYWAY!! - ! First need total number of mam constituents - call rad_cnst_get_info(0, nmodes=nmodes) - do m = 1, nmodes - call rad_cnst_get_info(0, m, nspec=nspec) - pmam_ncnst = pmam_ncnst + 1 + nspec - end do - - allocate(pmam_cnst_idx(pmam_ncnst)) - - ! Get the constituent indicies - im = 1 - do m = 1, nmodes - call rad_cnst_get_mode_num_idx(m, pmam_cnst_idx(im)) - im = im + 1 - call rad_cnst_get_info(0, m, nspec=nspec) - do l = 1, nspec - call rad_cnst_get_mam_mmr_idx(m, l, pmam_cnst_idx(im)) - im = im + 1 - end do - end do - end if -#endif - - ! Initialize upper boundary condition module - - call ubc_init() - - ! ---------------------------------------------------------------------------------------- ! - ! Initialize molecular diffusivity module ! - ! Note that computing molecular diffusivities is a trivial expense, but constituent ! - ! diffusivities depend on their molecular weights. Decomposing the diffusion matrix ! - ! for each constituent is a needless expense unless the diffusivity is significant. ! - ! ---------------------------------------------------------------------------------------- ! - - !---------------------------------------------------------------------------------------- - ! Initialize molecular diffusion and get top and bottom molecular diffusion limits - !---------------------------------------------------------------------------------------- - - if( do_molec_diff ) then - call init_molec_diff( r8, pcnst, mwdry, avogad, & - errstring) - - call handle_errmsg(errstring, subname="init_molec_diff") - - call addfld( 'TTPXMLC', horiz_only, 'A', 'K/S', 'Top interf. temp. flux: molec. viscosity' ) - if( masterproc ) write(iulog,fmt='(a,i3,5x,a,i3)') 'NBOT_MOLEC =', nbot_molec - end if - - ! ---------------------------------- ! - ! Initialize eddy diffusivity module ! - ! ---------------------------------- ! - - ! ntop_eddy must be 1 or <= nbot_molec - ! Currently, it is always 1 except for WACCM-X. - if ( waccmx_mode ) then - ntop_eddy = press_lim_idx(ntop_eddy_pres, top=.true.) - else - ntop_eddy = 1 - end if - nbot_eddy = pver - - if (masterproc) write(iulog, fmt='(a,i3,5x,a,i3)') 'NTOP_EDDY =', ntop_eddy, 'NBOT_EDDY =', nbot_eddy - - select case ( eddy_scheme ) - case ( 'diag_TKE', 'SPCAM_m2005' ) - if( masterproc ) write(iulog,*) & - 'vertical_diffusion_init: eddy_diffusivity scheme: UW Moist Turbulence Scheme by Bretherton and Park' - call eddy_diff_init(pbuf2d, ntop_eddy, nbot_eddy) - case ( 'HB', 'HBR', 'SPCAM_sam1mom') - if( masterproc ) write(iulog,*) 'vertical_diffusion_init: eddy_diffusivity scheme: Holtslag and Boville' - call init_hb_diff(gravit, cpair, ntop_eddy, nbot_eddy, pref_mid, & - karman, eddy_scheme) - call addfld('HB_ri', (/ 'lev' /), 'A', 'no', 'Richardson Number (HB Scheme), I' ) - case ( 'CLUBB_SGS' ) - do_pbl_diags = .true. - end select - - ! ------------------------------------------- ! - ! Initialize turbulent mountain stress module ! - ! ------------------------------------------- ! - - call trb_mtn_stress_init() - - ! ----------------------------------- ! - ! Initialize Beljaars SGO drag module ! - ! ----------------------------------- ! - - call beljaars_drag_init() - - ! ---------------------------------- ! - ! Initialize diffusion solver module ! - ! ---------------------------------- ! - - call init_vdiff(r8, iulog, rair, cpair, gravit, do_iss, fv_am_correction, errstring) - call handle_errmsg(errstring, subname="init_vdiff") - - ! Use fieldlist_wet to select the fields which will be diffused using moist mixing ratios ( all by default ) - ! Use fieldlist_dry to select the fields which will be diffused using dry mixing ratios. - - fieldlist_wet = new_fieldlist_vdiff( pcnst) - fieldlist_dry = new_fieldlist_vdiff( pcnst) - fieldlist_molec = new_fieldlist_vdiff( pcnst) - - if( vdiff_select( fieldlist_wet, 'u' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'u' ) ) - if( vdiff_select( fieldlist_wet, 'v' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'v' ) ) - if( vdiff_select( fieldlist_wet, 's' ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 's' ) ) - - constit_loop: do k = 1, pcnst - - if (prog_modal_aero) then - ! Do not diffuse droplet number - treated in dropmixnuc - if (k == ixnumliq) cycle constit_loop - ! Don't diffuse modal aerosol - treated in dropmixnuc - do m = 1, pmam_ncnst - if (k == pmam_cnst_idx(m)) cycle constit_loop - enddo - end if - - if( cnst_get_type_byind(k) .eq. 'wet' ) then - if( vdiff_select( fieldlist_wet, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_wet, 'q', k ) ) - else - if( vdiff_select( fieldlist_dry, 'q', k ) .ne. '' ) call endrun( vdiff_select( fieldlist_dry, 'q', k ) ) - endif - - ! ----------------------------------------------- ! - ! Select constituents for molecular diffusion ! - ! ----------------------------------------------- ! - if ( cnst_get_molec_byind(k) .eq. 'minor' ) then - if( vdiff_select(fieldlist_molec,'q',k) .ne. '' ) call endrun( vdiff_select( fieldlist_molec,'q',k ) ) - endif - - end do constit_loop - - ! ------------------------ ! - ! Diagnostic output fields ! - ! ------------------------ ! - - do k = 1, pcnst - vdiffnam(k) = 'VD'//cnst_name(k) - if( k == 1 ) vdiffnam(k) = 'VD01' !**** compatibility with old code **** - call addfld( vdiffnam(k), (/ 'lev' /), 'A', 'kg/kg/s', 'Vertical diffusion of '//cnst_name(k) ) - end do - - if (.not. do_pbl_diags) then - call addfld( 'PBLH' , horiz_only , 'A', 'm' , 'PBL height' ) - call addfld( 'QT' , (/ 'lev' /) , 'A', 'kg/kg' , 'Total water mixing ratio' ) - call addfld( 'SL' , (/ 'lev' /) , 'A', 'J/kg' , 'Liquid water static energy' ) - call addfld( 'SLV' , (/ 'lev' /) , 'A', 'J/kg' , 'Liq wat virtual static energy' ) - call addfld( 'SLFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Liquid static energy flux' ) - call addfld( 'QTFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Total water flux' ) - call addfld( 'TKE' , (/ 'ilev' /) , 'A', 'm2/s2' , 'Turbulent Kinetic Energy' ) - call addfld( 'TPERT' , horiz_only , 'A', 'K' , 'Perturbation temperature (eddies in PBL)' ) - call addfld( 'QPERT' , horiz_only , 'A', 'kg/kg' , 'Perturbation specific humidity (eddies in PBL)' ) - - call addfld( 'UFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Zonal momentum flux' ) - call addfld( 'VFLX' , (/ 'ilev' /) , 'A', 'W/m2' , 'Meridional momentm flux' ) - call register_vector_field('UFLX', 'VFLX') - end if - - call addfld( 'USTAR' , horiz_only , 'A', 'm/s' , 'Surface friction velocity' ) - call addfld( 'KVH' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (heat/moisture)' ) - call addfld( 'KVM' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion diffusivities (momentum)' ) - call addfld( 'KVT' , (/ 'ilev' /) , 'A', 'm2/s' , 'Vertical diffusion kinematic molecular conductivity') - call addfld( 'CGS' , (/ 'ilev' /) , 'A', 's/m2' , 'Counter-gradient coeff on surface kinematic fluxes' ) - call addfld( 'DTVKE' , (/ 'lev' /) , 'A', 'K/s' , 'dT/dt vertical diffusion KE dissipation' ) - call addfld( 'DTV' , (/ 'lev' /) , 'A', 'K/s' , 'T vertical diffusion' ) - call addfld( 'DUV' , (/ 'lev' /) , 'A', 'm/s2' , 'U vertical diffusion' ) - call addfld( 'DVV' , (/ 'lev' /) , 'A', 'm/s2' , 'V vertical diffusion' ) - - ! ---------------------------------------------------------------------------- ! - ! Below ( with '_PBL') are for detailed analysis of UW Moist Turbulence Scheme ! - ! ---------------------------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - call addfld( 'qt_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_prePBL' ) - call addfld( 'sl_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_prePBL' ) - call addfld( 'slv_pre_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_prePBL' ) - call addfld( 'u_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_prePBL' ) - call addfld( 'v_pre_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_prePBL' ) - call addfld( 'qv_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_prePBL' ) - call addfld( 'ql_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_prePBL' ) - call addfld( 'qi_pre_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_prePBL' ) - call addfld( 't_pre_PBL', (/ 'lev' /) , 'A', 'K' , 't_prePBL' ) - call addfld( 'rh_pre_PBL', (/ 'lev' /) , 'A', '%' , 'rh_prePBL' ) - - call addfld( 'qt_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qt_afterPBL' ) - call addfld( 'sl_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'sl_afterPBL' ) - call addfld( 'slv_aft_PBL', (/ 'lev' /) , 'A', 'J/kg' , 'slv_afterPBL' ) - call addfld( 'u_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'u_afterPBL' ) - call addfld( 'v_aft_PBL', (/ 'lev' /) , 'A', 'm/s' , 'v_afterPBL' ) - call addfld( 'qv_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qv_afterPBL' ) - call addfld( 'ql_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'ql_afterPBL' ) - call addfld( 'qi_aft_PBL', (/ 'lev' /) , 'A', 'kg/kg' , 'qi_afterPBL' ) - call addfld( 't_aft_PBL', (/ 'lev' /) , 'A', 'K' , 't_afterPBL' ) - call addfld( 'rh_aft_PBL', (/ 'lev' /) , 'A', '%' , 'rh_afterPBL' ) - - call addfld( 'slflx_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl flux by PBL' ) - call addfld( 'qtflx_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt flux by PBL' ) - call addfld( 'uflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u flux by PBL' ) - call addfld( 'vflx_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v flux by PBL' ) - - call addfld( 'slflx_cg_PBL', (/ 'ilev' /) , 'A', 'J/m2/s' , 'sl_cg flux by PBL' ) - call addfld( 'qtflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m2/s', 'qt_cg flux by PBL' ) - call addfld( 'uflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'u_cg flux by PBL' ) - call addfld( 'vflx_cg_PBL', (/ 'ilev' /) , 'A', 'kg/m/s2', 'v_cg flux by PBL' ) - - call addfld( 'qtten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qt tendency by PBL' ) - call addfld( 'slten_PBL', (/ 'lev' /) , 'A', 'J/kg/s' , 'sl tendency by PBL' ) - call addfld( 'uten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'u tendency by PBL' ) - call addfld( 'vten_PBL', (/ 'lev' /) , 'A', 'm/s2' , 'v tendency by PBL' ) - call addfld( 'qvten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qv tendency by PBL' ) - call addfld( 'qlten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'ql tendency by PBL' ) - call addfld( 'qiten_PBL', (/ 'lev' /) , 'A', 'kg/kg/s', 'qi tendency by PBL' ) - call addfld( 'tten_PBL', (/ 'lev' /) , 'A', 'K/s' , 'T tendency by PBL' ) - call addfld( 'rhten_PBL', (/ 'lev' /) , 'A', '%/s' , 'RH tendency by PBL' ) - - end if - - call addfld ('ustar',horiz_only, 'A', ' ',' ') - call addfld ('obklen',horiz_only, 'A', ' ',' ') - - ! ---------------------------- - ! determine default variables - ! ---------------------------- - - call phys_getopts( history_amwg_out = history_amwg, & - history_eddy_out = history_eddy, & - history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num, & - history_waccm_out = history_waccm) - - if (history_amwg) then - call add_default( vdiffnam(1), 1, ' ' ) - call add_default( 'DTV' , 1, ' ' ) - if (.not. do_pbl_diags) then - call add_default( 'PBLH' , 1, ' ' ) - end if - endif - - if (history_eddy) then - call add_default( 'UFLX ', 1, ' ' ) - call add_default( 'VFLX ', 1, ' ' ) - endif - - if( history_budget ) then - call add_default( vdiffnam(ixcldliq), history_budget_histfile_num, ' ' ) - call add_default( vdiffnam(ixcldice), history_budget_histfile_num, ' ' ) -#ifdef OSLO_AERO - call add_default( vdiffnam(ixnumliq), history_budget_histfile_num, ' ' ) - call add_default( vdiffnam(ixnumice), history_budget_histfile_num, ' ' ) -#endif - if( history_budget_histfile_num > 1 ) then - call add_default( vdiffnam(1), history_budget_histfile_num, ' ' ) - call add_default( 'DTV' , history_budget_histfile_num, ' ' ) - end if - end if - - if ( history_waccm ) then - if (do_molec_diff) then - call add_default ( 'TTPXMLC', 1, ' ' ) - end if - call add_default( 'DUV' , 1, ' ' ) - call add_default( 'DVV' , 1, ' ' ) - end if - ! ---------------------------- - - - ksrftms_idx = pbuf_get_index('ksrftms') - tautmsx_idx = pbuf_get_index('tautmsx') - tautmsy_idx = pbuf_get_index('tautmsy') - - dragblj_idx = pbuf_get_index('dragblj') - taubljx_idx = pbuf_get_index('taubljx') - taubljy_idx = pbuf_get_index('taubljy') - - if (eddy_scheme == 'CLUBB_SGS') then - kvh_idx = pbuf_get_index('kvh') - end if - - ! Initialization of some pbuf fields - if (is_first_step()) then - ! Initialization of pbuf fields tke, kvh, kvm are done in phys_inidat - call pbuf_set_field(pbuf2d, turbtype_idx, 0 ) - call pbuf_set_field(pbuf2d, smaw_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, tauresx_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, tauresy_idx, 0.0_r8) - if (trim(shallow_scheme) == 'UNICON') then - call pbuf_set_field(pbuf2d, qtl_flx_idx, 0.0_r8) - call pbuf_set_field(pbuf2d, qti_flx_idx, 0.0_r8) - end if - end if - -end subroutine vertical_diffusion_init - -! =============================================================================== ! -! ! -! =============================================================================== ! - -subroutine vertical_diffusion_ts_init( pbuf2d, state ) - - !-------------------------------------------------------------- ! - ! Timestep dependent setting, ! - ! At present only invokes upper bc code ! - !-------------------------------------------------------------- ! - use upper_bc, only : ubc_timestep_init - use physics_types , only : physics_state - use ppgrid , only : begchunk, endchunk - - use physics_buffer, only : physics_buffer_desc - - type(physics_state), intent(in) :: state(begchunk:endchunk) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - call ubc_timestep_init( pbuf2d, state) - -end subroutine vertical_diffusion_ts_init - -! =============================================================================== ! -! ! -! =============================================================================== ! - -subroutine vertical_diffusion_tend( & - ztodt , state , cam_in, & - ustar , obklen , ptend , & - cldn , pbuf) - !---------------------------------------------------- ! - ! This is an interface routine for vertical diffusion ! - !---------------------------------------------------- ! - use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field - use physics_types, only : physics_state, physics_ptend, physics_ptend_init - use camsrfexch, only : cam_in_t - use cam_history, only : outfld - - use trb_mtn_stress_cam, only : trb_mtn_stress_tend - use beljaars_drag_cam, only : beljaars_drag_tend - use eddy_diff_cam, only : eddy_diff_tend - use hb_diff, only : compute_hb_diff - use wv_saturation, only : qsat - use molec_diff, only : compute_molec_diff, vd_lu_qdecomp - use constituents, only : qmincg, qmin - use diffusion_solver, only : compute_vdiff, any, operator(.not.) - use physconst, only : cpairv, rairv !Needed for calculation of upward H flux - use time_manager, only : get_nstep - use constituents, only : cnst_get_type_byind, cnst_name, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx - use physconst, only : pi - use pbl_utils, only : virtem, calc_obklen, calc_ustar - use upper_bc, only : ubc_get_vals - use coords_1d, only : Coords1D - - ! --------------- ! - ! Input Arguments ! - ! --------------- ! - - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), intent(in) :: cam_in ! Surface inputs - - real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] - real(r8), intent(in) :: cldn(pcols,pver) ! New stratus fraction [ fraction ] - - ! ---------------------- ! - ! Input-Output Arguments ! - ! ---------------------- ! - - type(physics_ptend), intent(out) :: ptend ! Individual parameterization tendencies - type(physics_buffer_desc), pointer :: pbuf(:) - - ! ---------------- ! - ! Output Arguments ! - ! ---------------- ! - - real(r8), intent(out) :: ustar(pcols) ! Surface friction velocity [ m/s ] - real(r8), intent(out) :: obklen(pcols) ! Obukhov length [ m ] - - ! --------------- ! - ! Local Variables ! - ! --------------- ! - - character(128) :: errstring ! Error status for compute_vdiff - - integer :: lchnk ! Chunk identifier - integer :: ncol ! Number of atmospheric columns - integer :: i, k, l, m ! column, level, constituent indices - - real(r8) :: dtk(pcols,pver) ! T tendency from KE dissipation - real(r8), pointer :: tke(:,:) ! Turbulent kinetic energy [ m2/s2 ] - integer(i4),pointer :: turbtype(:,:) ! Turbulent interface types [ no unit ] - real(r8), pointer :: smaw(:,:) ! Normalized Galperin instability function - ! ( 0<= <=4.964 and 1 at neutral ) - - real(r8), pointer :: qtl_flx(:,:) ! overbar(w'qtl') where qtl = qv + ql - real(r8), pointer :: qti_flx(:,:) ! overbar(w'qti') where qti = qv + qi - - real(r8) :: cgs(pcols,pverp) ! Counter-gradient star [ cg/flux ] - real(r8) :: cgh(pcols,pverp) ! Counter-gradient term for heat - real(r8) :: rztodt ! 1./ztodt [ 1/s ] - real(r8), pointer :: ksrftms(:) ! Turbulent mountain stress surface drag coefficient [ kg/s/m2 ] - real(r8), pointer :: tautmsx(:) ! U component of turbulent mountain stress [ N/m2 ] - real(r8), pointer :: tautmsy(:) ! V component of turbulent mountain stress [ N/m2 ] - real(r8) :: tautotx(pcols) ! U component of total surface stress [ N/m2 ] - real(r8) :: tautoty(pcols) ! V component of total surface stress [ N/m2 ] - - real(r8), pointer :: dragblj(:,:) ! Beljaars SGO form drag profile [ 1/s ] - real(r8), pointer :: taubljx(:) ! U component of turbulent mountain stress [ N/m2 ] - real(r8), pointer :: taubljy(:) ! V component of turbulent mountain stress [ N/m2 ] - - real(r8), pointer :: kvh_in(:,:) ! kvh from previous timestep [ m2/s ] - real(r8), pointer :: kvm_in(:,:) ! kvm from previous timestep [ m2/s ] - real(r8), pointer :: kvt(:,:) ! Molecular kinematic conductivity for temperature [ ] - real(r8) :: kvq(pcols,pverp) ! Eddy diffusivity for constituents [ m2/s ] - real(r8) :: kvh(pcols,pverp) ! Eddy diffusivity for heat [ m2/s ] - real(r8) :: kvm(pcols,pverp) ! Eddy diffusivity for momentum [ m2/s ] - real(r8) :: kvm_temp(pcols,pverp) ! Dummy eddy diffusivity for momentum (unused) [ m2/s ] - real(r8) :: dtk_temp(pcols,pverp) ! Unused output from second compute_vdiff call - real(r8) :: tautmsx_temp(pcols) ! Unused output from second compute_vdiff call - real(r8) :: tautmsy_temp(pcols) ! Unused output from second compute_vdiff call - real(r8) :: topflx_temp(pcols) ! Unused output from second compute_vdiff call - real(r8) :: sprod(pcols,pverp) ! Shear production of tke [ m2/s3 ] - real(r8) :: sfi(pcols,pverp) ! Saturation fraction at interfaces [ fraction ] - real(r8) :: sl(pcols,pver) - real(r8) :: qt(pcols,pver) - real(r8) :: slv(pcols,pver) - real(r8) :: sl_prePBL(pcols,pver) - real(r8) :: qt_prePBL(pcols,pver) - real(r8) :: slv_prePBL(pcols,pver) - real(r8) :: slten(pcols,pver) - real(r8) :: qtten(pcols,pver) - real(r8) :: slflx(pcols,pverp) - real(r8) :: qtflx(pcols,pverp) - real(r8) :: uflx(pcols,pverp) - real(r8) :: vflx(pcols,pverp) - real(r8) :: slflx_cg(pcols,pverp) - real(r8) :: qtflx_cg(pcols,pverp) - real(r8) :: uflx_cg(pcols,pverp) - real(r8) :: vflx_cg(pcols,pverp) - real(r8) :: th(pcols,pver) ! Potential temperature - real(r8) :: topflx(pcols) ! Molecular heat flux at top interface - real(r8) :: rhoair - - real(r8) :: ri(pcols,pver) ! richardson number (HB output) - - ! for obklen calculation outside HB - real(r8) :: thvs(pcols) ! Virtual potential temperature at surface - real(r8) :: rrho(pcols) ! Reciprocal of density at surface - real(r8) :: khfs(pcols) ! sfc kinematic heat flux [mK/s] - real(r8) :: kqfs(pcols) ! sfc kinematic water vapor flux [m/s] - real(r8) :: kbfs(pcols) ! sfc kinematic buoyancy flux [m^2/s^3] - - real(r8) :: ftem(pcols,pver) ! Saturation vapor pressure before PBL - real(r8) :: ftem_prePBL(pcols,pver) ! Saturation vapor pressure before PBL - real(r8) :: ftem_aftPBL(pcols,pver) ! Saturation vapor pressure after PBL - real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH - real(r8) :: t_aftPBL(pcols,pver) ! Temperature after PBL diffusion - real(r8) :: tten(pcols,pver) ! Temperature tendency by PBL diffusion - real(r8) :: rhten(pcols,pver) ! RH tendency by PBL diffusion - real(r8) :: qv_aft_PBL(pcols,pver) ! qv after PBL diffusion - real(r8) :: ql_aft_PBL(pcols,pver) ! ql after PBL diffusion - real(r8) :: qi_aft_PBL(pcols,pver) ! qi after PBL diffusion - real(r8) :: s_aft_PBL(pcols,pver) ! s after PBL diffusion - real(r8) :: u_aft_PBL(pcols,pver) ! u after PBL diffusion - real(r8) :: v_aft_PBL(pcols,pver) ! v after PBL diffusion - real(r8) :: qv_pro(pcols,pver) - real(r8) :: ql_pro(pcols,pver) - real(r8) :: qi_pro(pcols,pver) - real(r8) :: s_pro(pcols,pver) - real(r8) :: t_pro(pcols,pver) - real(r8), pointer :: tauresx(:) ! Residual stress to be added in vdiff to correct - real(r8), pointer :: tauresy(:) ! for turb stress mismatch between sfc and atm accumulated. - - ! Interpolated interface values. - real(r8) :: tint(pcols,pver+1) ! Temperature [ K ] - real(r8) :: rairi(pcols,pver+1) ! Gas constant [ J/K/kg ] - real(r8) :: rhoi(pcols,pver+1) ! Density of air [ kg/m^3 ] - real(r8) :: rhoi_dry(pcols,pver+1) ! Density of air based on dry air pressure [ kg/m^3 ] - - ! Upper boundary conditions - real(r8) :: ubc_t(pcols) ! Temperature [ K ] - real(r8) :: ubc_mmr(pcols,pcnst) ! Mixing ratios [ kg/kg ] - real(r8) :: ubc_flux(pcols,pcnst) ! Constituent upper boundary flux (kg/s/m^2) - - ! Pressure coordinates used by the solver. - type(Coords1D) :: p - type(Coords1D) :: p_dry - - real(r8), pointer :: tpert(:) - real(r8), pointer :: qpert(:) - real(r8), pointer :: pblh(:) - - real(r8) :: tmp1(pcols) ! Temporary storage - - integer :: nstep - real(r8) :: sum1, sum2, sum3, pdelx - real(r8) :: sflx - - ! Copy state so we can pass to intent(inout) routines that return - ! new state instead of a tendency. - real(r8) :: s_tmp(pcols,pver) - real(r8) :: u_tmp(pcols,pver) - real(r8) :: v_tmp(pcols,pver) - real(r8) :: q_tmp(pcols,pver,pcnst) - - ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity - real(r8) :: kq_scal(pcols,pver+1) - ! composition dependent mw_fac on interface level - real(r8) :: mw_fac(pcols,pver+1,pcnst) - - ! Dry static energy top boundary condition. - real(r8) :: dse_top(pcols) - - ! Copies of flux arrays used to zero out any parts that are applied - ! elsewhere (e.g. by CLUBB). - real(r8) :: taux(pcols) - real(r8) :: tauy(pcols) - real(r8) :: shflux(pcols) - real(r8) :: cflux(pcols,pcnst) - - logical :: lq(pcnst) - - ! ----------------------- ! - ! Main Computation Begins ! - ! ----------------------- ! - - rztodt = 1._r8 / ztodt - lchnk = state%lchnk - ncol = state%ncol - - call pbuf_get_field(pbuf, tauresx_idx, tauresx) - call pbuf_get_field(pbuf, tauresy_idx, tauresy) - call pbuf_get_field(pbuf, tpert_idx, tpert) - call pbuf_get_field(pbuf, qpert_idx, qpert) - call pbuf_get_field(pbuf, pblh_idx, pblh) - call pbuf_get_field(pbuf, turbtype_idx, turbtype) - - ! Interpolate temperature to interfaces. - do k = 2, pver - do i = 1, ncol - tint(i,k) = 0.5_r8 * ( state%t(i,k) + state%t(i,k-1) ) - end do - end do - tint(:ncol,pver+1) = state%t(:ncol,pver) - - ! Get upper boundary values - call ubc_get_vals( state%lchnk, ncol, state%pint, state%zi, state%t, state%q, state%omega, state%phis, & - ubc_t, ubc_mmr, ubc_flux ) - - ! Always have a fixed upper boundary T if molecular diffusion is active. Why ? - ! For WACCM-X, set ubc temperature to extrapolate from next two lower interface level temperatures - if (do_molec_diff) then - if (waccmx_mode) then - tint(:ncol,1) = 1.5_r8*tint(:ncol,2)-.5_r8*tint(:ncol,3) - else - tint (:ncol,1) = ubc_t(:ncol) - endif - else - tint(:ncol,1) = state%t(:ncol,1) - end if - - ! Set up pressure coordinates for solver calls. - p = Coords1D(state%pint(:ncol,:)) - p_dry = Coords1D(state%pintdry(:ncol,:)) - - !------------------------------------------------------------------------ - ! Check to see if constituent dependent gas constant needed (WACCM-X) - !------------------------------------------------------------------------ - if (waccmx_mode) then - rairi(:ncol,1) = rairv(:ncol,1,lchnk) - do k = 2, pver - do i = 1, ncol - rairi(i,k) = 0.5_r8 * (rairv(i,k,lchnk)+rairv(i,k-1,lchnk)) - end do - end do - rairi(:ncol,pver+1) = rairv(:ncol,pver,lchnk) - else - rairi(:ncol,:pver+1) = rair - endif - - ! Compute rho at interfaces. - do k = 1, pver+1 - do i = 1, ncol - rhoi(i,k) = p%ifc(i,k) / (rairi(i,k)*tint(i,k)) - end do - end do - - ! Compute rho_dry at interfaces. - do k = 1, pver+1 - do i = 1, ncol - rhoi_dry(i,k) = p_dry%ifc(i,k) / (rairi(i,k)*tint(i,k)) - end do - end do - - ! ---------------------------------------- ! - ! Computation of turbulent mountain stress ! - ! ---------------------------------------- ! - - ! Consistent with the computation of 'normal' drag coefficient, we are using - ! the raw input (u,v) to compute 'ksrftms', not the provisionally-marched 'u,v' - ! within the iteration loop of the PBL scheme. - - call trb_mtn_stress_tend(state, pbuf, cam_in) - - call pbuf_get_field(pbuf, ksrftms_idx, ksrftms) - call pbuf_get_field(pbuf, tautmsx_idx, tautmsx) - call pbuf_get_field(pbuf, tautmsy_idx, tautmsy) - - tautotx(:ncol) = cam_in%wsx(:ncol) + tautmsx(:ncol) - tautoty(:ncol) = cam_in%wsy(:ncol) + tautmsy(:ncol) - - ! ------------------------------------- ! - ! Computation of Beljaars SGO form drag ! - ! ------------------------------------- ! - - call beljaars_drag_tend(state, pbuf, cam_in) - - call pbuf_get_field(pbuf, dragblj_idx, dragblj) - call pbuf_get_field(pbuf, taubljx_idx, taubljx) - call pbuf_get_field(pbuf, taubljy_idx, taubljy) - - ! Add Beljaars integrated drag - - tautotx(:ncol) = tautotx(:ncol) + taubljx(:ncol) - tautoty(:ncol) = tautoty(:ncol) + taubljy(:ncol) - - !----------------------------------------------------------------------- ! - ! Computation of eddy diffusivities - Select appropriate PBL scheme ! - !----------------------------------------------------------------------- ! - call pbuf_get_field(pbuf, kvm_idx, kvm_in) - call pbuf_get_field(pbuf, kvh_idx, kvh_in) - call pbuf_get_field(pbuf, smaw_idx, smaw) - call pbuf_get_field(pbuf, tke_idx, tke) - - ! Get potential temperature. - th(:ncol,:pver) = state%t(:ncol,:pver) * state%exner(:ncol,:pver) - - select case (eddy_scheme) - case ( 'diag_TKE', 'SPCAM_m2005' ) - - call eddy_diff_tend(state, pbuf, cam_in, & - ztodt, p, tint, rhoi, cldn, wstarent, & - kvm_in, kvh_in, ksrftms, dragblj, tauresx, tauresy, & - rrho, ustar, pblh, kvm, kvh, kvq, cgh, cgs, tpert, qpert, & - tke, sprod, sfi, turbtype, smaw) - - ! The diag_TKE scheme does not calculate the Monin-Obukhov length, which is used in dry deposition calculations. - ! Use the routines from pbl_utils to accomplish this. Assumes ustar and rrho have been set. - call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) - call calc_obklen(ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & - cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & - khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) - - - case ( 'HB', 'HBR', 'SPCAM_sam1mom' ) - - ! Modification : We may need to use 'taux' instead of 'tautotx' here, for - ! consistency with the previous HB scheme. - - call compute_hb_diff( lchnk , ncol , & - th , state%t , state%q , state%zm , state%zi, & - state%pmid, state%u , state%v , tautotx , tautoty , & - cam_in%shf, cam_in%cflx(:,1), obklen , ustar , pblh , & - kvm , kvh , kvq , cgh , cgs , & - tpert , qpert , cldn , cam_in%ocnfrac , tke , & - ri , & - eddy_scheme ) - - call outfld( 'HB_ri', ri, pcols, lchnk ) - - case ( 'CLUBB_SGS' ) - - ! CLUBB has only a bare-bones placeholder here. If using CLUBB, the - ! PBL diffusion will happen before coupling, so vertical_diffusion - ! is only handling other things, e.g. some boundary conditions, tms, - ! and molecular diffusion. - - call virtem(ncol, th(:ncol,pver),state%q(:ncol,pver,1), thvs(:ncol)) - - call calc_ustar( ncol, state%t(:ncol,pver), state%pmid(:ncol,pver), & - cam_in%wsx(:ncol), cam_in%wsy(:ncol), rrho(:ncol), ustar(:ncol)) - ! Use actual qflux, not lhf/latvap as was done previously - call calc_obklen( ncol, th(:ncol,pver), thvs(:ncol), cam_in%cflx(:ncol,1), & - cam_in%shf(:ncol), rrho(:ncol), ustar(:ncol), & - khfs(:ncol), kqfs(:ncol), kbfs(:ncol), obklen(:ncol)) - - ! These tendencies all applied elsewhere. - kvm = 0._r8 - kvh = 0._r8 - kvq = 0._r8 - - ! Not defined since PBL is not actually running here. - cgh = 0._r8 - cgs = 0._r8 - - end select - - call outfld( 'ustar', ustar(:), pcols, lchnk ) - call outfld( 'obklen', obklen(:), pcols, lchnk ) - - ! kvh (in pbuf) is used by other physics parameterizations, and as an initial guess in compute_eddy_diff - ! on the next timestep. It is not updated by the compute_vdiff call below. - call pbuf_set_field(pbuf, kvh_idx, kvh) - - ! kvm (in pbuf) is only used as an initial guess in compute_eddy_diff on the next timestep. - ! The contributions for molecular diffusion made to kvm by the call to compute_vdiff below - ! are not included in the pbuf as these are not needed in the initial guess by compute_eddy_diff. - call pbuf_set_field(pbuf, kvm_idx, kvm) - - !------------------------------------ ! - ! Application of diffusivities ! - !------------------------------------ ! - - ! Set arrays from input state. - q_tmp(:ncol,:,:) = state%q(:ncol,:,:) - s_tmp(:ncol,:) = state%s(:ncol,:) - u_tmp(:ncol,:) = state%u(:ncol,:) - v_tmp(:ncol,:) = state%v(:ncol,:) - - !------------------------------------------------------ ! - ! Write profile output before applying diffusion scheme ! - !------------------------------------------------------ ! - - if (.not. do_pbl_diags) then - sl_prePBL(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & - - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) - qt_prePBL(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & - + q_tmp(:ncol,:,ixcldice) - slv_prePBL(:ncol,:pver) = sl_prePBL(:ncol,:pver) * ( 1._r8 + zvir*qt_prePBL(:ncol,:pver) ) - - call qsat(state%t(:ncol,:), state%pmid(:ncol,:), & - tem2(:ncol,:), ftem(:ncol,:)) - ftem_prePBL(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 - - call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) - call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) - call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) - call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) - call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) - call outfld( 'qv_pre_PBL ', state%q(:ncol,:,1), pcols, lchnk ) - call outfld( 'ql_pre_PBL ', state%q(:ncol,:,ixcldliq), pcols, lchnk ) - call outfld( 'qi_pre_PBL ', state%q(:ncol,:,ixcldice), pcols, lchnk ) - call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) - call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) - - end if - - ! --------------------------------------------------------------------------------- ! - ! Call the diffusivity solver and solve diffusion equation ! - ! The final two arguments are optional function references to ! - ! constituent-independent and constituent-dependent moleculuar diffusivity routines ! - ! --------------------------------------------------------------------------------- ! - - ! Modification : We may need to output 'tautotx_im,tautoty_im' from below 'compute_vdiff' and - ! separately print out as diagnostic output, because these are different from - ! the explicit 'tautotx, tautoty' computed above. - ! Note that the output 'tauresx,tauresy' from below subroutines are fully implicit ones. - - call pbuf_get_field(pbuf, kvt_idx, kvt) - - if (do_molec_diff .and. .not. waccmx_mode) then - ! Top boundary condition for dry static energy - dse_top(:ncol) = cpairv(:ncol,1,lchnk) * tint(:ncol,1) + & - gravit * state%zi(:ncol,1) - else - dse_top(:ncol) = 0._r8 - end if - - select case (eddy_scheme) - case ('CLUBB_SGS') - ! CLUBB applies some fluxes itself, but we still want constituent - ! fluxes applied here (except water vapor). - taux = 0._r8 - tauy = 0._r8 - shflux = 0._r8 - cflux(:,1) = 0._r8 - cflux(:,2:) = cam_in%cflx(:,2:) - case default - taux = cam_in%wsx - tauy = cam_in%wsy - shflux = cam_in%shf - cflux = cam_in%cflx - end select - - if( any(fieldlist_wet) ) then - - if (do_molec_diff) then - call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & - kvm, kvt, tint, rhoi, kq_scal, cnst_mw, & - mw_fac, nbot_molec) - end if - - call compute_vdiff( state%lchnk , & - pcols , pver , pcnst , ncol , tint , & - p , state%t , rhoi, ztodt , taux , & - tauy , shflux , cflux , & - kvh , kvm , kvq , cgs , cgh , & - state%zi , ksrftms , dragblj , & - qmincg , fieldlist_wet , fieldlist_molec,& - u_tmp , v_tmp , q_tmp , s_tmp , & - tautmsx , tautmsy , dtk , topflx , errstring , & - tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & - do_molec_diff, waccmx_mode, & - vd_lu_qdecomp, & - ubc_mmr, ubc_flux, kvt, state%pmid, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & - kq_scal, mw_fac) - - call handle_errmsg(errstring, subname="compute_vdiff", & - extra_msg="Error in fieldlist_wet call from vertical_diffusion.") - - end if - - if( any( fieldlist_dry ) ) then - - if( do_molec_diff ) then - ! kvm is unused in the output here (since it was assigned - ! above), so we use a temp kvm for the inout argument, and - ! ignore the value output by compute_molec_diff. - kvm_temp = kvm - call compute_molec_diff(state%lchnk, pcols, pver, pcnst, ncol, & - kvm_temp, kvt, tint, rhoi_dry, kq_scal, cnst_mw, & - mw_fac, nbot_molec) - end if - - call compute_vdiff( state%lchnk , & - pcols , pver , pcnst , ncol , tint , & - p_dry , state%t , rhoi_dry, ztodt , taux , & - tauy , shflux , cflux , & - kvh , kvm , kvq , cgs , cgh , & - state%zi , ksrftms , dragblj , & - qmincg , fieldlist_dry , fieldlist_molec,& - u_tmp , v_tmp , q_tmp , s_tmp , & - tautmsx_temp , tautmsy_temp , dtk_temp , topflx_temp , errstring , & - tauresx , tauresy , 1 , cpairv(:,:,state%lchnk), dse_top, & - do_molec_diff , waccmx_mode, & - vd_lu_qdecomp, & - ubc_mmr, ubc_flux, kvt, state%pmiddry, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & - kq_scal, mw_fac) - - call handle_errmsg(errstring, subname="compute_vdiff", & - extra_msg="Error in fieldlist_dry call from vertical_diffusion.") - - end if - - if (prog_modal_aero) then - - ! Modal aerosol species not diffused, so just add the explicit surface fluxes to the - ! lowest layer - - ! NOTE: Oslo aero adds emissions together with dry deposition -#ifndef OSLO_AERO - tmp1(:ncol) = ztodt * gravit * state%rpdel(:ncol,pver) - do m = 1, pmam_ncnst - l = pmam_cnst_idx(m) - q_tmp(:ncol,pver,l) = q_tmp(:ncol,pver,l) + tmp1(:ncol) * cam_in%cflx(:ncol,l) - enddo -#endif - end if - - ! -------------------------------------------------------- ! - ! Diagnostics and output writing after applying PBL scheme ! - ! -------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - sl(:ncol,:pver) = s_tmp(:ncol,:) - latvap * q_tmp(:ncol,:,ixcldliq) & - - ( latvap + latice) * q_tmp(:ncol,:,ixcldice) - qt(:ncol,:pver) = q_tmp(:ncol,:,1) + q_tmp(:ncol,:,ixcldliq) & - + q_tmp(:ncol,:,ixcldice) - slv(:ncol,:pver) = sl(:ncol,:pver) * ( 1._r8 + zvir*qt(:ncol,:pver) ) - - slflx(:ncol,1) = 0._r8 - qtflx(:ncol,1) = 0._r8 - uflx(:ncol,1) = 0._r8 - vflx(:ncol,1) = 0._r8 - - slflx_cg(:ncol,1) = 0._r8 - qtflx_cg(:ncol,1) = 0._r8 - uflx_cg(:ncol,1) = 0._r8 - vflx_cg(:ncol,1) = 0._r8 - - do k = 2, pver - do i = 1, ncol - rhoair = state%pint(i,k) / ( rair * ( ( 0.5_r8*(slv(i,k)+slv(i,k-1)) - gravit*state%zi(i,k))/cpair ) ) - slflx(i,k) = kvh(i,k) * & - ( - rhoair*(sl(i,k-1)-sl(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & - + cgh(i,k) ) - qtflx(i,k) = kvh(i,k) * & - ( - rhoair*(qt(i,k-1)-qt(i,k))/(state%zm(i,k-1)-state%zm(i,k)) & - + rhoair*(cam_in%cflx(i,1)+cam_in%cflx(i,ixcldliq)+cam_in%cflx(i,ixcldice))*cgs(i,k) ) - uflx(i,k) = kvm(i,k) * & - ( - rhoair*(u_tmp(i,k-1)-u_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) - vflx(i,k) = kvm(i,k) * & - ( - rhoair*(v_tmp(i,k-1)-v_tmp(i,k))/(state%zm(i,k-1)-state%zm(i,k))) - slflx_cg(i,k) = kvh(i,k) * cgh(i,k) - qtflx_cg(i,k) = kvh(i,k) * rhoair * ( cam_in%cflx(i,1) + & - cam_in%cflx(i,ixcldliq) + cam_in%cflx(i,ixcldice) ) * cgs(i,k) - uflx_cg(i,k) = 0._r8 - vflx_cg(i,k) = 0._r8 - end do - end do - - ! Modification : I should check whether slflx(:ncol,pverp) is correctly computed. - ! Note also that 'tautotx' is explicit total stress, different from - ! the ones that have been actually added into the atmosphere. - - slflx(:ncol,pverp) = cam_in%shf(:ncol) - qtflx(:ncol,pverp) = cam_in%cflx(:ncol,1) - uflx(:ncol,pverp) = tautotx(:ncol) - vflx(:ncol,pverp) = tautoty(:ncol) - - slflx_cg(:ncol,pverp) = 0._r8 - qtflx_cg(:ncol,pverp) = 0._r8 - uflx_cg(:ncol,pverp) = 0._r8 - vflx_cg(:ncol,pverp) = 0._r8 - - if (trim(shallow_scheme) == 'UNICON') then - call pbuf_get_field(pbuf, qtl_flx_idx, qtl_flx) - call pbuf_get_field(pbuf, qti_flx_idx, qti_flx) - qtl_flx(:ncol,1) = 0._r8 - qti_flx(:ncol,1) = 0._r8 - do k = 2, pver - do i = 1, ncol - ! For use in the cloud macrophysics - ! Note that density is not added here. Also, only consider local transport term. - qtl_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldliq)-q_tmp(i,k,ixcldliq))/& - (state%zm(i,k-1)-state%zm(i,k)) - qti_flx(i,k) = - kvh(i,k)*(q_tmp(i,k-1,1)-q_tmp(i,k,1)+q_tmp(i,k-1,ixcldice)-q_tmp(i,k,ixcldice))/& - (state%zm(i,k-1)-state%zm(i,k)) - end do - end do - do i = 1, ncol - rhoair = state%pint(i,pverp)/(rair*((slv(i,pver)-gravit*state%zi(i,pverp))/cpair)) - qtl_flx(i,pverp) = cam_in%cflx(i,1)/rhoair - qti_flx(i,pverp) = cam_in%cflx(i,1)/rhoair - end do - end if - - end if - - ! --------------------------------------------------------------- ! - ! Convert the new profiles into vertical diffusion tendencies. ! - ! Convert KE dissipative heat change into "temperature" tendency. ! - ! --------------------------------------------------------------- ! - - ! All variables are modified by vertical diffusion - - lq(:) = .TRUE. - call physics_ptend_init(ptend,state%psetcols, "vertical diffusion", & - ls=.true., lu=.true., lv=.true., lq=lq) - - ptend%s(:ncol,:) = ( s_tmp(:ncol,:) - state%s(:ncol,:) ) * rztodt - ptend%u(:ncol,:) = ( u_tmp(:ncol,:) - state%u(:ncol,:) ) * rztodt - ptend%v(:ncol,:) = ( v_tmp(:ncol,:) - state%v(:ncol,:) ) * rztodt - ptend%q(:ncol,:pver,:) = ( q_tmp(:ncol,:pver,:) - state%q(:ncol,:pver,:) ) * rztodt - if (.not. do_pbl_diags) then - slten(:ncol,:) = ( sl(:ncol,:) - sl_prePBL(:ncol,:) ) * rztodt - qtten(:ncol,:) = ( qt(:ncol,:) - qt_prePBL(:ncol,:) ) * rztodt - end if - - ! ------------------------------------------------------------ ! - ! In order to perform 'pseudo-conservative variable diffusion' ! - ! perform the following two stages: ! - ! ! - ! I. Re-set (1) 'qvten' by 'qtten', and 'qlten = qiten = 0' ! - ! (2) 'sten' by 'slten', and ! - ! (3) 'qlten = qiten = 0' ! - ! ! - ! II. Apply 'positive_moisture' ! - ! ! - ! ------------------------------------------------------------ ! - - if( (eddy_scheme .eq. 'diag_TKE' .or. eddy_scheme .eq. 'SPCAM_m2005') .and. do_pseudocon_diff ) then - - ptend%q(:ncol,:pver,1) = qtten(:ncol,:pver) - ptend%s(:ncol,:pver) = slten(:ncol,:pver) - ptend%q(:ncol,:pver,ixcldliq) = 0._r8 - ptend%q(:ncol,:pver,ixcldice) = 0._r8 - if (ixnumliq > 0) ptend%q(:ncol,:pver,ixnumliq) = 0._r8 - if (ixnumice > 0) ptend%q(:ncol,:pver,ixnumice) = 0._r8 - - do i = 1, ncol - do k = 1, pver - qv_pro(i,k) = state%q(i,k,1) + ptend%q(i,k,1) * ztodt - ql_pro(i,k) = state%q(i,k,ixcldliq) + ptend%q(i,k,ixcldliq) * ztodt - qi_pro(i,k) = state%q(i,k,ixcldice) + ptend%q(i,k,ixcldice) * ztodt - s_pro(i,k) = state%s(i,k) + ptend%s(i,k) * ztodt - t_pro(i,k) = state%t(i,k) + (1._r8/cpair)*ptend%s(i,k) * ztodt - end do - end do - - call positive_moisture( cpair, latvap, latvap+latice, ncol, pver, ztodt, qmin(1), qmin(ixcldliq), qmin(ixcldice), & - state%pdel(:ncol,pver:1:-1), qv_pro(:ncol,pver:1:-1), ql_pro(:ncol,pver:1:-1), & - qi_pro(:ncol,pver:1:-1), t_pro(:ncol,pver:1:-1), s_pro(:ncol,pver:1:-1), & - ptend%q(:ncol,pver:1:-1,1), ptend%q(:ncol,pver:1:-1,ixcldliq), & - ptend%q(:ncol,pver:1:-1,ixcldice), ptend%s(:ncol,pver:1:-1) ) - - end if - - ! ----------------------------------------------------------------- ! - ! Re-calculate diagnostic output variables after vertical diffusion ! - ! ----------------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - qv_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,1) + ptend%q(:ncol,:pver,1) * ztodt - ql_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) + ptend%q(:ncol,:pver,ixcldliq) * ztodt - qi_aft_PBL(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) + ptend%q(:ncol,:pver,ixcldice) * ztodt - s_aft_PBL(:ncol,:pver) = state%s(:ncol,:pver) + ptend%s(:ncol,:pver) * ztodt - t_aftPBL(:ncol,:pver) = ( s_aft_PBL(:ncol,:pver) - gravit*state%zm(:ncol,:pver) ) / cpair - - u_aft_PBL(:ncol,:pver) = state%u(:ncol,:pver) + ptend%u(:ncol,:pver) * ztodt - v_aft_PBL(:ncol,:pver) = state%v(:ncol,:pver) + ptend%v(:ncol,:pver) * ztodt - - call qsat(t_aftPBL(:ncol,:pver), state%pmid(:ncol,:pver), & - tem2(:ncol,:pver), ftem(:ncol,:pver)) - ftem_aftPBL(:ncol,:pver) = qv_aft_PBL(:ncol,:pver) / ftem(:ncol,:pver) * 100._r8 - - tten(:ncol,:pver) = ( t_aftPBL(:ncol,:pver) - state%t(:ncol,:pver) ) * rztodt - rhten(:ncol,:pver) = ( ftem_aftPBL(:ncol,:pver) - ftem_prePBL(:ncol,:pver) ) * rztodt - - end if - - ! -------------------------------------------------------------- ! - ! mass conservation check......... - ! -------------------------------------------------------------- ! - if (diff_cnsrv_mass_check) then - - ! Conservation check - do m = 1, pcnst - fixed_ubc: if ((.not.cnst_fixed_ubc(m)).and.(.not.cnst_fixed_ubflx(m))) then - col_loop: do i = 1, ncol - sum1 = 0._r8 - sum2 = 0._r8 - sum3 = 0._r8 - do k = 1, pver - if(cnst_get_type_byind(m).eq.'wet') then - pdelx = state%pdel(i,k) - else - pdelx = state%pdeldry(i,k) - endif - sum1 = sum1 + state%q(i,k,m)*pdelx/gravit ! total column - sum2 = sum2 +(state%q(i,k,m)+ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! total column after tendancy is applied - sum3 = sum3 +( ptend%q(i,k,m)*ztodt)*pdelx/ gravit ! rate of change in column - enddo - sum1 = sum1 + (cam_in%cflx(i,m) * ztodt) ! add in surface flux (kg/m2) - sflx = (cam_in%cflx(i,m) * ztodt) - if (sum1>1.e-36_r8) then - if( abs((sum2-sum1)/sum1) .gt. 1.e-12_r8 ) then - nstep = get_nstep() - write(iulog,'(a,a8,a,I4,2f8.3,5e25.16)') & - 'MASSCHECK vert diff : nstep,lon,lat,mass1,mass2,sum3,sflx,rel-diff : ', & - trim(cnst_name(m)), ' : ', nstep, state%lon(i)*180._r8/pi, state%lat(i)*180._r8/pi, & - sum1, sum2, sum3, sflx, abs(sum2-sum1)/sum1 - call endrun('vertical_diffusion_tend : mass not conserved' ) - endif - endif - enddo col_loop - endif fixed_ubc - enddo - endif - - ! -------------------------------------------------------------- ! - ! Writing state variables after PBL scheme for detailed analysis ! - ! -------------------------------------------------------------- ! - - if (.not. do_pbl_diags) then - - call outfld( 'sl_aft_PBL' , sl, pcols, lchnk ) - call outfld( 'qt_aft_PBL' , qt, pcols, lchnk ) - call outfld( 'slv_aft_PBL' , slv, pcols, lchnk ) - call outfld( 'u_aft_PBL' , u_aft_PBL, pcols, lchnk ) - call outfld( 'v_aft_PBL' , v_aft_PBL, pcols, lchnk ) - call outfld( 'qv_aft_PBL' , qv_aft_PBL, pcols, lchnk ) - call outfld( 'ql_aft_PBL' , ql_aft_PBL, pcols, lchnk ) - call outfld( 'qi_aft_PBL' , qi_aft_PBL, pcols, lchnk ) - call outfld( 't_aft_PBL ' , t_aftPBL, pcols, lchnk ) - call outfld( 'rh_aft_PBL' , ftem_aftPBL, pcols, lchnk ) - call outfld( 'slflx_PBL' , slflx, pcols, lchnk ) - call outfld( 'qtflx_PBL' , qtflx, pcols, lchnk ) - call outfld( 'uflx_PBL' , uflx, pcols, lchnk ) - call outfld( 'vflx_PBL' , vflx, pcols, lchnk ) - call outfld( 'slflx_cg_PBL' , slflx_cg, pcols, lchnk ) - call outfld( 'qtflx_cg_PBL' , qtflx_cg, pcols, lchnk ) - call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) - call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) - call outfld( 'slten_PBL' , slten, pcols, lchnk ) - call outfld( 'qtten_PBL' , qtten, pcols, lchnk ) - call outfld( 'uten_PBL' , ptend%u(:ncol,:), pcols, lchnk ) - call outfld( 'vten_PBL' , ptend%v(:ncol,:), pcols, lchnk ) - call outfld( 'qvten_PBL' , ptend%q(:ncol,:,1), pcols, lchnk ) - call outfld( 'qlten_PBL' , ptend%q(:ncol,:,ixcldliq), pcols, lchnk ) - call outfld( 'qiten_PBL' , ptend%q(:ncol,:,ixcldice), pcols, lchnk ) - call outfld( 'tten_PBL' , tten, pcols, lchnk ) - call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) - - end if - - ! ------------------------------------------- ! - ! Writing the other standard output variables ! - ! ------------------------------------------- ! - - if (.not. do_pbl_diags) then - call outfld( 'QT' , qt, pcols, lchnk ) - call outfld( 'SL' , sl, pcols, lchnk ) - call outfld( 'SLV' , slv, pcols, lchnk ) - call outfld( 'SLFLX' , slflx, pcols, lchnk ) - call outfld( 'QTFLX' , qtflx, pcols, lchnk ) - call outfld( 'UFLX' , uflx, pcols, lchnk ) - call outfld( 'VFLX' , vflx, pcols, lchnk ) - call outfld( 'TKE' , tke, pcols, lchnk ) - - call outfld( 'PBLH' , pblh, pcols, lchnk ) - call outfld( 'TPERT' , tpert, pcols, lchnk ) - call outfld( 'QPERT' , qpert, pcols, lchnk ) - end if - call outfld( 'USTAR' , ustar, pcols, lchnk ) - call outfld( 'KVH' , kvh, pcols, lchnk ) - call outfld( 'KVT' , kvt, pcols, lchnk ) - call outfld( 'KVM' , kvm, pcols, lchnk ) - call outfld( 'CGS' , cgs, pcols, lchnk ) - dtk(:ncol,:) = dtk(:ncol,:) / cpair ! Normalize heating for history - call outfld( 'DTVKE' , dtk, pcols, lchnk ) - dtk(:ncol,:) = ptend%s(:ncol,:) / cpair ! Normalize heating for history using dtk - call outfld( 'DTV' , dtk, pcols, lchnk ) - call outfld( 'DUV' , ptend%u, pcols, lchnk ) - call outfld( 'DVV' , ptend%v, pcols, lchnk ) - do m = 1, pcnst - call outfld( vdiffnam(m) , ptend%q(1,1,m), pcols, lchnk ) - end do - if( do_molec_diff ) then - call outfld( 'TTPXMLC' , topflx, pcols, lchnk ) - end if - - call p%finalize() - call p_dry%finalize() - -end subroutine vertical_diffusion_tend - -! =============================================================================== ! -! ! -! =============================================================================== ! - -subroutine positive_moisture( cp, xlv, xls, ncol, mkx, dt, qvmin, qlmin, qimin, & - dp, qv, ql, qi, t, s, qvten, qlten, qiten, sten ) - ! ------------------------------------------------------------------------------- ! - ! If any 'ql < qlmin, qi < qimin, qv < qvmin' are developed in any layer, ! - ! force them to be larger than minimum value by (1) condensating water vapor ! - ! into liquid or ice, and (2) by transporting water vapor from the very lower ! - ! layer. '2._r8' is multiplied to the minimum values for safety. ! - ! Update final state variables and tendencies associated with this correction. ! - ! If any condensation happens, update (s,t) too. ! - ! Note that (qv,ql,qi,t,s) are final state variables after applying corresponding ! - ! input tendencies. ! - ! Be careful the order of k : '1': near-surface layer, 'mkx' : top layer ! - ! ------------------------------------------------------------------------------- ! - implicit none - integer, intent(in) :: ncol, mkx - real(r8), intent(in) :: cp, xlv, xls - real(r8), intent(in) :: dt, qvmin, qlmin, qimin - real(r8), intent(in) :: dp(ncol,mkx) - real(r8), intent(inout) :: qv(ncol,mkx), ql(ncol,mkx), qi(ncol,mkx), t(ncol,mkx), s(ncol,mkx) - real(r8), intent(inout) :: qvten(ncol,mkx), qlten(ncol,mkx), qiten(ncol,mkx), sten(ncol,mkx) - integer i, k - real(r8) dql, dqi, dqv, sum, aa, dum - - ! Modification : I should check whether this is exactly same as the one used in - ! shallow convection and cloud macrophysics. - - do i = 1, ncol - do k = mkx, 1, -1 ! From the top to the 1st (lowest) layer from the surface - dql = max(0._r8,1._r8*qlmin-ql(i,k)) - dqi = max(0._r8,1._r8*qimin-qi(i,k)) - qlten(i,k) = qlten(i,k) + dql/dt - qiten(i,k) = qiten(i,k) + dqi/dt - qvten(i,k) = qvten(i,k) - (dql+dqi)/dt - sten(i,k) = sten(i,k) + xlv * (dql/dt) + xls * (dqi/dt) - ql(i,k) = ql(i,k) + dql - qi(i,k) = qi(i,k) + dqi - qv(i,k) = qv(i,k) - dql - dqi - s(i,k) = s(i,k) + xlv * dql + xls * dqi - t(i,k) = t(i,k) + (xlv * dql + xls * dqi)/cp - dqv = max(0._r8,1._r8*qvmin-qv(i,k)) - qvten(i,k) = qvten(i,k) + dqv/dt - qv(i,k) = qv(i,k) + dqv - if( k .ne. 1 ) then - qv(i,k-1) = qv(i,k-1) - dqv*dp(i,k)/dp(i,k-1) - qvten(i,k-1) = qvten(i,k-1) - dqv*dp(i,k)/dp(i,k-1)/dt - endif - qv(i,k) = max(qv(i,k),qvmin) - ql(i,k) = max(ql(i,k),qlmin) - qi(i,k) = max(qi(i,k),qimin) - end do - ! Extra moisture used to satisfy 'qv(i,1)=qvmin' is proportionally - ! extracted from all the layers that has 'qv > 2*qvmin'. This fully - ! preserves column moisture. - if( dqv .gt. 1.e-20_r8 ) then - sum = 0._r8 - do k = 1, mkx - if( qv(i,k) .gt. 2._r8*qvmin ) sum = sum + qv(i,k)*dp(i,k) - enddo - aa = dqv*dp(i,1)/max(1.e-20_r8,sum) - if( aa .lt. 0.5_r8 ) then - do k = 1, mkx - if( qv(i,k) .gt. 2._r8*qvmin ) then - dum = aa*qv(i,k) - qv(i,k) = qv(i,k) - dum - qvten(i,k) = qvten(i,k) - dum/dt - endif - enddo - else - write(iulog,*) 'Full positive_moisture is impossible in vertical_diffusion' - endif - endif - end do - return - -end subroutine positive_moisture - -end module vertical_diffusion From caefbe9c6c02a01a67e835d985daa8f9bbb08fce Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 4 Sep 2023 13:06:48 +0200 Subject: [PATCH 54/71] moved aero_model to oslo_aero_model in chemistry/oslo_aero --- src/NorESM/physpkg.F90 | 18 +++++++++-------- src/chemistry/mozart/chemistry.F90 | 20 +++++++++++++++---- src/chemistry/mozart/mo_gas_phase_chemdr.F90 | 7 +++++-- src/chemistry/mozart/mo_usrrxt.F90 | 4 ++++ .../{aero_model.F90 => oslo_aero_model.F90} | 4 ++-- 5 files changed, 37 insertions(+), 16 deletions(-) rename src/chemistry/oslo_aero/{aero_model.F90 => oslo_aero_model.F90} (99%) diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index 44e3d66d51..fb88fe0c18 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -1270,7 +1270,6 @@ subroutine tphysac (ztodt, cam_in, & use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_tend ! WACCM-X use aoa_tracers, only: aoa_tracers_timestep_tend use physconst, only: rhoh2o, latvap,latice - use aero_model, only: aero_model_drydep use carma_intr, only: carma_emission_tend, carma_timestep_tend use carma_flags_mod, only: carma_do_aerosol, carma_do_emission use check_energy, only: check_energy_chng, calc_te_and_aam_budgets @@ -1291,6 +1290,11 @@ subroutine tphysac (ztodt, cam_in, & use qneg_module, only: qneg4 use co2_cycle, only: co2_cycle_set_ptend use nudging, only: Nudge_Model,Nudge_ON,nudging_timestep_tend +#ifdef OSLO_AERO + use oslo_aero_model, only: aero_model_drydep +#else + use aero_model, only: aero_model_drydep +#endif ! ! Arguments @@ -1717,11 +1721,6 @@ subroutine tphysbc (ztodt, state, & use dadadj_cam, only: dadadj_tend use rk_stratiform, only: rk_stratiform_tend use microp_driver, only: microp_driver_tend -#ifdef OSLO_AERO - use oslo_aero_microp,only: oslo_aero_microp_run -#else - use microp_aero, only: microp_aero_run -#endif use macrop_driver, only: macrop_driver_tend use physics_types, only: physics_state, physics_tend, physics_ptend, & physics_update, physics_ptend_init, physics_ptend_sum, & @@ -1737,7 +1736,6 @@ subroutine tphysbc (ztodt, state, & use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng use check_energy, only: calc_te_and_aam_budgets use dycore, only: dycore_is - use aero_model, only: aero_model_wetdep use carma_intr, only: carma_wetdep_tend, carma_timestep_tend use carma_flags_mod, only: carma_do_detrain, carma_do_cldice, carma_do_cldliq, carma_do_wetdep use radiation, only: radiation_tend @@ -1752,10 +1750,14 @@ subroutine tphysbc (ztodt, state, & use subcol, only: subcol_gen, subcol_ptend_avg use subcol_utils, only: subcol_ptend_copy, is_subcol_on use qneg_module, only: qneg3 - #ifdef OSLO_AERO + use oslo_aero_model, only: aero_model_wetdep + use oslo_aero_microp,only: oslo_aero_microp_run use oslo_aero_params use oslo_aero_share +#else + use microp_aero, only: microp_aero_run + use aero_model, only: aero_model_wetdep #endif implicit none diff --git a/src/chemistry/mozart/chemistry.F90 b/src/chemistry/mozart/chemistry.F90 index 4531a729e7..bad3d179cc 100644 --- a/src/chemistry/mozart/chemistry.F90 +++ b/src/chemistry/mozart/chemistry.F90 @@ -172,8 +172,11 @@ subroutine chem_register use cfc11star, only : register_cfc11star use mo_photo, only : photo_register use mo_aurora, only : aurora_register +#ifdef OSLO_AERO + use oslo_aero_model, only : aero_model_register +#else use aero_model, only : aero_model_register - +#endif implicit none !----------------------------------------------------------------------- @@ -346,10 +349,11 @@ subroutine chem_readnl(nlfile) use linoz_data, only: linoz_data_defaultopts, linoz_data_setopts use tracer_cnst, only: tracer_cnst_defaultopts, tracer_cnst_setopts use tracer_srcs, only: tracer_srcs_defaultopts, tracer_srcs_setopts - use aero_model, only: aero_model_readnl #ifdef OSLO_AERO + use oslo_aero_model, only: aero_model_readnl use oslo_aero_dust, only: oslo_aero_dust_readnl #else + use aero_model, only: aero_model_readnl use dust_model, only: dust_readnl #endif use gas_wetdep_opts, only: gas_wetdep_readnl @@ -771,12 +775,16 @@ subroutine chem_init(phys_state, pbuf2d) use infnan, only : nan, assignment(=) use mo_chem_utls, only : get_spc_ndx use cam_abortutils, only : endrun - use aero_model, only : aero_model_init use mo_setsox, only : sox_inti use constituents, only : sflxnam use noy_ubc, only : noy_ubc_init use fire_emissions, only : fire_emissions_init use short_lived_species, only : short_lived_species_initic +#ifdef OSLO_AERO + use oslo_aero_model, only : aero_model_init +#else + use aero_model, only : aero_model_init +#endif type(physics_buffer_desc), pointer :: pbuf2d(:,:) type(physics_state), intent(in):: phys_state(begchunk:endchunk) @@ -982,13 +990,17 @@ end subroutine chem_init !================================================================================ !================================================================================ subroutine chem_emissions( state, cam_in ) - use aero_model, only: aero_model_emissions use camsrfexch, only: cam_in_t use constituents, only: sflxnam use cam_history, only: outfld use mo_srf_emissions, only: set_srf_emissions use cam_cpl_indices, only: index_x2a_Fall_flxvoc use fire_emissions, only: fire_emissions_srf +#ifdef OSLO_AERO + use oslo_aero_model, only: aero_model_emissions +#else + use aero_model, only: aero_model_emissions +#endif ! Arguments: diff --git a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 index a638b28d35..2de61311eb 100644 --- a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 +++ b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 @@ -359,10 +359,13 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & ! ! for aqueous chemistry and aerosol growth ! +#ifdef OSLO_AERO + use oslo_aero_model, only : aero_model_gasaerexch + use oslo_aero_model, only : aero_model_strat_surfarea +#else use aero_model, only : aero_model_gasaerexch - use aero_model, only : aero_model_strat_surfarea - +#endif implicit none !----------------------------------------------------------------------- diff --git a/src/chemistry/mozart/mo_usrrxt.F90 b/src/chemistry/mozart/mo_usrrxt.F90 index aa7f526a94..76ca25e9a0 100644 --- a/src/chemistry/mozart/mo_usrrxt.F90 +++ b/src/chemistry/mozart/mo_usrrxt.F90 @@ -446,7 +446,11 @@ subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, & use mo_setinv, only : inv_o2_ndx=>o2_ndx, inv_h2o_ndx=>h2o_ndx use physics_buffer,only : physics_buffer_desc use carma_flags_mod, only : carma_hetchem_feedback +#ifdef OSLO_AERO + use oslo_aero_model, only : aero_model_surfarea +#else use aero_model, only : aero_model_surfarea +#endif use rad_constituents,only : rad_cnst_get_info implicit none diff --git a/src/chemistry/oslo_aero/aero_model.F90 b/src/chemistry/oslo_aero/oslo_aero_model.F90 similarity index 99% rename from src/chemistry/oslo_aero/aero_model.F90 rename to src/chemistry/oslo_aero/oslo_aero_model.F90 index bf097403c1..4e1b5f5396 100644 --- a/src/chemistry/oslo_aero/aero_model.F90 +++ b/src/chemistry/oslo_aero/oslo_aero_model.F90 @@ -1,4 +1,4 @@ -module aero_model +module oslo_aero_model !=============================================================================== ! Oslo Aerosol Model @@ -944,4 +944,4 @@ subroutine calcaersize_sub( ncol, t, h2ommr, pmid, pdel,wetnumberMedianDiameter, end subroutine calcaersize_sub -end module aero_model +end module oslo_aero_model From 24ac1e9b77160f345f6324f9617ee669251d9ec9 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 4 Sep 2023 20:52:18 +0200 Subject: [PATCH 55/71] more cleanup to compile without defining OSLO_AERO --- src/NorESM/cam_diagnostics.F90 | 8 +++--- src/NorESM/physpkg.F90 | 15 ++++++----- src/chemistry/mozart/mo_gas_phase_chemdr.F90 | 6 ++--- src/chemistry/mozart/mo_neu_wetdep.F90 | 27 ++++++++++---------- src/control/runtime_opts.F90 | 2 +- src/physics/cam/vertical_diffusion.F90 | 7 ++--- 6 files changed, 33 insertions(+), 32 deletions(-) diff --git a/src/NorESM/cam_diagnostics.F90 b/src/NorESM/cam_diagnostics.F90 index 51c0412080..b638b968b1 100644 --- a/src/NorESM/cam_diagnostics.F90 +++ b/src/NorESM/cam_diagnostics.F90 @@ -474,7 +474,7 @@ subroutine diag_init_dry(pbuf2d) call addfld ('BATOTVIS',(/'lev'/),'A','1/km','Aerosol 3d absorption at 0.442-0.625') ! CAM4-Oslo: 0.35-0.64um call addfld ('BATSW13 ',(/'lev'/),'A','1/km','Aerosol 3d SW absorption at 3.077-3.846um') call addfld ('BATLW01 ',(/'lev'/),'A','1/km','Aerosol 3d LW absorption depth at 3.077-3.846um') -!+ +#ifdef OSLO_AERO do i=1,nbmodes modeString=" " write(modeString,"(I2)"),i @@ -489,7 +489,7 @@ subroutine diag_init_dry(pbuf2d) varName = "Cxsrel"//trim(modeString) if(i.ne.3) call addfld(varName, horiz_only, 'A', 'unitless', 'relative exessive added mass column for mode'//modeString) enddo - +#endif end if if (history_amwg) then @@ -781,6 +781,7 @@ subroutine diag_init_dry(pbuf2d) call add_default ('BATOTVIS', 1, ' ') call add_default ('BATSW13 ', 1, ' ') call add_default ('BATLW01 ', 1, ' ') +#ifdef OSLO_AERO do i=1,nbmodes modeString=" " write(modeString,"(I2)"),i @@ -795,8 +796,7 @@ subroutine diag_init_dry(pbuf2d) varName = "Cxsrel"//trim(modeString) if(i.ne.3) call add_default(varName, 1, ' ') enddo -!-- -!- +#endif end if end subroutine diag_init_dry diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index fb88fe0c18..f7da22bd09 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -1807,8 +1807,9 @@ subroutine tphysbc (ztodt, state, & integer :: macmic_it ! iteration variables real(r8) :: cld_macmic_ztodt ! modified timestep +#ifdef OSLO_AERO integer kcomp ! mode number (1-14) oslo_aero - +#endif ! physics buffer fields to compute tendencies for stratiform package integer itim_old, ifld real(r8), pointer, dimension(:,:) :: cld ! cloud fraction @@ -1869,7 +1870,7 @@ subroutine tphysbc (ztodt, state, & logical :: lq(pcnst) - ! OSLO_AERO beg +#ifdef AEROCOM real(r8) :: logsig3d(pcols,pver,nmodes) ! Log (log10) of standard deviation for lognormal modes, method 2. real(r8) :: rnew3d(pcols,pver,nmodes) ! New modal radius from look-up tables, method 2. real(r8) :: logsig1(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 1, method 2. @@ -1914,7 +1915,7 @@ subroutine tphysbc (ztodt, state, & real(r8) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) real(r8) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt real(r8) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor - ! OSLO_AERO_END +#endif !----------------------------------------------------------------------- call t_startf('bc_init') @@ -2510,9 +2511,9 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) use epp_ionization, only: epp_ionization_active use iop_forcing, only: scam_use_iop_srf use nudging, only: Nudge_Model, nudging_timestep_init - ! OSLO_AERO beg +#ifdef OSLO_AERO use oslo_aero_ocean, only: oslo_aero_ocean_time - ! OSLO_AERO end +#endif implicit none @@ -2547,9 +2548,9 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) call aircraft_emit_adv(phys_state, pbuf2d) call prescribed_volcaero_adv(phys_state, pbuf2d) call prescribed_strataero_adv(phys_state, pbuf2d) - ! OSLO_AERO beg +#ifdef OSLO_AERO call oslo_aero_ocean_time(phys_state, pbuf2d) - ! OSLO_AERO end +#endif ! prescribed aerosol deposition fluxes call aerodep_flx_adv(phys_state, pbuf2d, cam_out) diff --git a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 index 2de61311eb..3624cb5ae4 100644 --- a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 +++ b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 @@ -86,7 +86,7 @@ subroutine gas_phase_chemdr_inti() call phys_getopts( convproc_do_aer_out = convproc_do_aer, history_cesm_forcing_out=history_cesm_forcing ) -#if defined(OSLO_AERO) +#ifdef OSLO_AERO inv_o3 = get_inv_ndx('O3') > 0 inv_oh = get_inv_ndx('OH') > 0 inv_no3 = get_inv_ndx('NO3') > 0 @@ -343,7 +343,7 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & use mo_chm_diags, only : chm_diags, het_diags use perf_mod, only : t_startf, t_stopf use gas_wetdep_opts, only : gas_wetdep_method -#if (defined OSLO_AERO) +#ifdef OSLO_AERO use oslo_aero_diurnal_var, only : set_diurnal_invariants #endif use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx @@ -676,7 +676,7 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & !----------------------------------------------------------------------- call setinv( invariants, tfld, h2ovmr, vmr, pmid, ncol, lchnk, pbuf ) -#if defined (OSLO_AERO) +#ifdef OSLO_AERO !----------------------------------------------------------------------- ! ... Set the "day/night cycle for prescribed oxidants" !----------------------------------------------------------------------- diff --git a/src/chemistry/mozart/mo_neu_wetdep.F90 b/src/chemistry/mozart/mo_neu_wetdep.F90 index 4238271eaa..88c354b7d9 100644 --- a/src/chemistry/mozart/mo_neu_wetdep.F90 +++ b/src/chemistry/mozart/mo_neu_wetdep.F90 @@ -285,8 +285,6 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & real(r8) :: wrk_wd(pcols) logical history_aerosol #endif - -call phys_getopts( history_aerosol_out = history_aerosol) ! ! from cam/src/physics/cam/stratiform.F90 ! @@ -481,22 +479,23 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & if ( debug) print *,'mo_neu ',mapping_to_mmr(m),(wk_out(1:ncol)) wd_tend_int(1:ncol,mapping_to_mmr(m)) = wk_out(1:ncol) ! - end do + end do !This is output normally in mo_chm_diags, but !if neu wetdep, we have to output it here! #ifdef OSLO_AERO - if(history_aerosol)then - do m=1,gas_wetdep_cnt - wrk_wd(:ncol) = 0.0_r8 - do k=1,pver - !Note sign: tendency is negative, so this becomes a positive flux! - wrk_wd(:ncol) = wrk_wd(:ncol) & - - wd_tend(1:ncol,k,mapping_to_mmr(m))*pdel(:ncol,k)*rgrav !kg/m2/sec - end do - call outfld('WD_A_'//trim(gas_wetdep_list(m)),wrk_wd(:ncol),ncol,lchnk) - end do - end if + call phys_getopts( history_aerosol_out = history_aerosol) + if(history_aerosol)then + do m=1,gas_wetdep_cnt + wrk_wd(:ncol) = 0.0_r8 + do k=1,pver + !Note sign: tendency is negative, so this becomes a positive flux! + wrk_wd(:ncol) = wrk_wd(:ncol) & + - wd_tend(1:ncol,k,mapping_to_mmr(m))*pdel(:ncol,k)*rgrav !kg/m2/sec + end do + call outfld('WD_A_'//trim(gas_wetdep_list(m)),wrk_wd(:ncol),ncol,lchnk) + end do + end if #endif ! if ( do_diag ) then diff --git a/src/control/runtime_opts.F90 b/src/control/runtime_opts.F90 index d82280a6e8..358b1d9d7c 100644 --- a/src/control/runtime_opts.F90 +++ b/src/control/runtime_opts.F90 @@ -191,7 +191,7 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) #if ( defined OFFLINE_DYN ) call metdata_readnl(nlfilename) #endif -#if (defined OSLO_AERO) +#ifdef OSLO_AERO call oslo_aero_ctl_readnl(nlfilename) #endif call offline_driver_readnl(nlfilename) diff --git a/src/physics/cam/vertical_diffusion.F90 b/src/physics/cam/vertical_diffusion.F90 index ec48a4cb6e..3fa31560d1 100644 --- a/src/physics/cam/vertical_diffusion.F90 +++ b/src/physics/cam/vertical_diffusion.F90 @@ -328,15 +328,16 @@ subroutine vertical_diffusion_init(pbuf2d) allocate(pmam_cnst_idx(pmam_ncnst)) call fillAerosolTracerList(pmam_cnst_idx) #else - !NOTE THAT THIS BREAKS THE CONCEPT OF KEEPEING MAM-AEROSOLS OUT OF - !DIFFUSION, BUT IF YOU ARE USING MAM, YOU SHOULD NOT BEE HERE ANYWAY!! + if (prog_modal_aero) then + ! NOTE THAT THIS BREAKS THE CONCEPT OF KEEPEING MAM-AEROSOLS OUT OF + ! DIFFUSION, BUT IF YOU ARE USING MAM, YOU SHOULD NOT BEE HERE ANYWAY!! + ! First need total number of mam constituents call rad_cnst_get_info(0, nmodes=nmodes) do m = 1, nmodes call rad_cnst_get_info(0, m, nspec=nspec) pmam_ncnst = pmam_ncnst + 1 + nspec end do - allocate(pmam_cnst_idx(pmam_ncnst)) ! Get the constituent indicies From 890b114bd48bf7f73d8c5e637e1bbd073ad7a97d Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 4 Sep 2023 21:02:11 +0200 Subject: [PATCH 56/71] pointing to chemistry/oslo_aero as an external --- src/chemistry/oslo_aero/oslo_aero_aerocom.F90 | 1905 ------------ .../oslo_aero/oslo_aero_aerocom_dry.F90 | 1138 ------- .../oslo_aero/oslo_aero_aerocom_opt.F90 | 1296 -------- src/chemistry/oslo_aero/oslo_aero_coag.F90 | 760 ----- src/chemistry/oslo_aero/oslo_aero_conc.F90 | 790 ----- .../oslo_aero/oslo_aero_condtend.F90 | 1024 ------ src/chemistry/oslo_aero/oslo_aero_const.F90 | 32 - src/chemistry/oslo_aero/oslo_aero_control.F90 | 190 -- src/chemistry/oslo_aero/oslo_aero_depos.F90 | 1987 ------------ .../oslo_aero/oslo_aero_diurnal_var.F90 | 488 --- src/chemistry/oslo_aero/oslo_aero_dust.F90 | 251 -- .../oslo_aero/oslo_aero_dust_sediment.F90 | 424 --- src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 | 1467 --------- .../oslo_aero/oslo_aero_linear_interp.F90 | 134 - .../oslo_aero/oslo_aero_logn_tables.F90 | 716 ----- src/chemistry/oslo_aero/oslo_aero_microp.F90 | 462 --- src/chemistry/oslo_aero/oslo_aero_model.F90 | 947 ------ src/chemistry/oslo_aero/oslo_aero_ndrop.F90 | 2034 ------------ .../oslo_aero/oslo_aero_nucleate_ice.F90 | 1089 ------- src/chemistry/oslo_aero/oslo_aero_ocean.F90 | 342 -- .../oslo_aero/oslo_aero_optical_params.F90 | 526 ---- src/chemistry/oslo_aero/oslo_aero_params.F90 | 79 - src/chemistry/oslo_aero/oslo_aero_seasalt.F90 | 148 - src/chemistry/oslo_aero/oslo_aero_share.F90 | 714 ----- .../oslo_aero/oslo_aero_sox_cldaero.F90 | 473 --- .../oslo_aero/oslo_aero_sw_tables.F90 | 2766 ----------------- src/chemistry/oslo_aero/oslo_aero_utils.F90 | 170 - 27 files changed, 22352 deletions(-) delete mode 100644 src/chemistry/oslo_aero/oslo_aero_aerocom.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_coag.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_conc.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_condtend.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_const.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_control.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_depos.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_dust.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_dust_sediment.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_linear_interp.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_microp.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_model.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_ndrop.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_ocean.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_optical_params.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_params.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_seasalt.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_share.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 delete mode 100644 src/chemistry/oslo_aero/oslo_aero_utils.F90 diff --git a/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 deleted file mode 100644 index 8af15920c2..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_aerocom.F90 +++ /dev/null @@ -1,1905 +0,0 @@ -module oslo_aero_aerocom - -#ifdef AEROCOM - - use ppgrid - use shr_kind_mod, only: r8 => shr_kind_r8 - use cam_history, only: outfld - use physics_types, only: physics_state - ! - use oslo_aero_aerocom_opt, only: extinction_coeffs, extinction_coeffsn - use oslo_aero_aerocom_dry, only: aerodry_prop - use oslo_aero_sw_tables - use oslo_aero_share - use oslo_aero_params - use oslo_aero_const - - public :: aerocom - public :: opticsAtConstRh - public :: intfrh - -contains - - subroutine aerocom(daylight, Cam) - - ! Arguments - real(r8), intent(in) :: Cam(pcols,pver,nbmodes) - - ! Local variables - integer i, k, ib, icol, mplus10 - integer iloop - logical daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. - - real(r8) Ctotdry(pcols,pver), Cwater(pcols,pver), mmr_aerh2o(pcols,pver), & - dod550dry(pcols), abs550dry(pcols) - - real(r8) daerh2o(pcols), dload(pcols,0:nmodes), dload3d(pcols,pver,0:nmodes), & - dload_mi(pcols), dload_ss(pcols), & - dload_s4(pcols), dload_oc(pcols), dload_bc(pcols), & - dload_s4_a(pcols), dload_s4_1(pcols), dload_s4_5(pcols) - - real(r8) dload_bc_0(pcols), dload_bc_ac(pcols), dload_oc_ac(pcols), & - dload_bc_2(pcols), dload_bc_4(pcols), dload_bc_12(pcols), dload_bc_14(pcols), & - dload_oc_4(pcols), dload_oc_14(pcols) - - real(r8) cmin(pcols,pver), cseas(pcols,pver) - - real(r8) nnat_1(pcols,pver), nnat_2(pcols,pver), nnat_3(pcols,pver), & - nnat_4(pcols,pver), nnat_5(pcols,pver), nnat_6(pcols,pver), & - nnat_7(pcols,pver), nnat_8(pcols,pver), nnat_9(pcols,pver), & - nnat_10(pcols,pver), nnat_12(pcols,pver), & - nnat_14(pcols,pver), nnat_0(pcols,pver) - - real(r8) ck(pcols,pver,0:nmodes), cknorm(pcols,pver,0:nmodes), & - cknlt05(pcols,pver,0:nmodes), ckngt125(pcols,pver,0:nmodes) - - real(r8) aaerosn(pcols,pver,nbmp1:nmodes), aaeroln(pcols,pver,nbmp1:nmodes), & - vaerosn(pcols,pver,nbmp1:nmodes), vaeroln(pcols,pver,nbmp1:nmodes), & - aaeros(pcols,pver,0:nbmodes), aaerol(pcols,pver,0:nbmodes), & - vaeros(pcols,pver,0:nbmodes), vaerol(pcols,pver,0:nbmodes) - - real(r8) cintbg(pcols,pver,0:nbmodes), & - cintbg05(pcols,pver,0:nbmodes), cintbg125(pcols,pver,0:nbmodes), & - cintbc(pcols,pver,0:nbmodes), & - cintbc05(pcols,pver,0:nbmodes), cintbc125(pcols,pver,0:nbmodes), & - cintoc(pcols,pver,0:nbmodes), & - cintoc05(pcols,pver,0:nbmodes), cintoc125(pcols,pver,0:nbmodes), & - cintsc(pcols,pver,0:nbmodes), & - cintsc05(pcols,pver,0:nbmodes), cintsc125(pcols,pver,0:nbmodes), & - cintsa(pcols,pver,0:nbmodes), & - cintsa05(pcols,pver,0:nbmodes), cintsa125(pcols,pver,0:nbmodes) - - real(r8) c_mi(pcols,pver), c_mi05(pcols,pver), c_mi125(pcols,pver), & - c_ss(pcols,pver), c_ss05(pcols,pver), c_ss125(pcols,pver), & - c_bc(pcols,pver), c_bc05(pcols,pver), c_bc125(pcols,pver), & - c_oc(pcols,pver), c_oc05(pcols,pver), c_oc125(pcols,pver), & - c_sa(pcols,pver), c_sa05(pcols,pver), c_sa125(pcols,pver), & - c_sc(pcols,pver), c_sc05(pcols,pver), c_sc125(pcols,pver), & - c_s4(pcols,pver), c_s405(pcols,pver), c_s4125(pcols,pver), & - c_s4_a(pcols,pver), c_s4_1(pcols,pver), c_s4_5(pcols,pver) - - real(r8) c_bc_0(pcols,pver), c_bc_ac(pcols,pver), c_oc_ac(pcols,pver), & - c_bc_2(pcols,pver), c_bc_4(pcols,pver), c_bc_12(pcols,pver), c_bc_14(pcols,pver), & - c_oc_4(pcols,pver), c_oc_14(pcols,pver) - - real(r8) c_tots(pcols), c_tot125s(pcols), c_pm25s(pcols) ! = PM all sizes, PM>2.5um and PM<2.5um (PM2.5) - - real(r8) c_tot(pcols,pver), c_tot125(pcols,pver), c_pm25(pcols,pver), & - mmr_pm25(pcols,pver), c_tot05(pcols,pver), c_pm1(pcols,pver), mmr_pm1(pcols,pver) - - real(r8) aaeros_tot(pcols,pver), aaerol_tot(pcols,pver), vaeros_tot(pcols,pver), & - vaerol_tot(pcols,pver), aaercols(pcols), aaercoll(pcols), vaercols(pcols), & - vaercoll(pcols), derlt05(pcols), dergt05(pcols), der(pcols), & - erlt053d(pcols,pver), ergt053d(pcols,pver), er3d(pcols,pver) - - real(r8) bebglt1(pcols,pver,0:nbmodes), bebggt1(pcols,pver,0:nbmodes), & - bebclt1(pcols,pver,0:nbmodes), bebcgt1(pcols,pver,0:nbmodes), & - beoclt1(pcols,pver,0:nbmodes), beocgt1(pcols,pver,0:nbmodes), & - bes4lt1(pcols,pver,0:nbmodes), bes4gt1(pcols,pver,0:nbmodes), & - backsc550(pcols,pver,0:nbmodes), backsc550x(pcols,pver,nbmp1:nmodes), & - backsc550tot(pcols,pver), ec550_aer(pcols,pver), abs550_aer(pcols,pver), & - bs550_aer(pcols,pver) - - ! Additional AeroCom Phase III output: - real(r8) asydry_aer(pcols,pver) ! dry asymtot in the visible band - ! - real(r8) ec550_so4(pcols,pver),ec550_bc(pcols,pver), ec550_pom(pcols,pver), & - ec550_ss(pcols,pver), ec550_du(pcols,pver) - - real(r8) bebglt1n(pcols,pver,0:nbmodes), bebggt1n(pcols,pver,0:nbmodes), & - bebclt1n(pcols,pver,0:nbmodes), bebcgt1n(pcols,pver,0:nbmodes), & - beoclt1n(pcols,pver,0:nbmodes), beocgt1n(pcols,pver,0:nbmodes), & - bes4lt1n(pcols,pver,0:nbmodes), bes4gt1n(pcols,pver,0:nbmodes), & - backsc550n(pcols,pver,0:nbmodes) - - real(r8) bext440tot(pcols,pver), babs440tot(pcols,pver), & - bext500tot(pcols,pver), babs500tot(pcols,pver), & - bext550tot(pcols,pver), babs550tot(pcols,pver), & - bext670tot(pcols,pver), babs670tot(pcols,pver), & - bext870tot(pcols,pver), babs870tot(pcols,pver), & - bebg440tot(pcols,pver), & - bebg500tot(pcols,pver), & - bebg550tot(pcols,pver), babg550tot(pcols,pver), & - bebg670tot(pcols,pver), & - bebg870tot(pcols,pver), & - bebc440tot(pcols,pver), & - bebc500tot(pcols,pver), & - bebc550tot(pcols,pver), babc550tot(pcols,pver), & - bebc670tot(pcols,pver), & - bebc870tot(pcols,pver), & - beoc440tot(pcols,pver), & - beoc500tot(pcols,pver), & - beoc550tot(pcols,pver), baoc550tot(pcols,pver), & - beoc670tot(pcols,pver), & - beoc870tot(pcols,pver), & - besu440tot(pcols,pver), & - besu500tot(pcols,pver), & - besu550tot(pcols,pver), basu550tot(pcols,pver), & - besu670tot(pcols,pver), & - besu870tot(pcols,pver) - - real(r8) bebglt1t(pcols,pver), bebggt1t(pcols,pver), bebclt1t(pcols,pver), & - bebcgt1t(pcols,pver), beoclt1t(pcols,pver), beocgt1t(pcols,pver), & - bes4lt1t(pcols,pver), bes4gt1t(pcols,pver) - - real(r8) be440x(pcols,pver,nbmp1:nmodes), ba440x(pcols,pver,nbmp1:nmodes), & - be500x(pcols,pver,nbmp1:nmodes), ba500x(pcols,pver,nbmp1:nmodes), & - be550x(pcols,pver,nbmp1:nmodes), ba550x(pcols,pver,nbmp1:nmodes), & - be670x(pcols,pver,nbmp1:nmodes), ba670x(pcols,pver,nbmp1:nmodes), & - be870x(pcols,pver,nbmp1:nmodes), ba870x(pcols,pver,nbmp1:nmodes), & - belt1x(pcols,pver,nbmp1:nmodes), begt1x(pcols,pver,nbmp1:nmodes) - - real(r8) bebc440xt(pcols,pver),babc440xt(pcols,pver), & - bebc500xt(pcols,pver),babc500xt(pcols,pver), & - bebc550xt(pcols,pver),babc550xt(pcols,pver), & - bebc670xt(pcols,pver),babc670xt(pcols,pver), & - bebc870xt(pcols,pver),babc870xt(pcols,pver), & - beoc440xt(pcols,pver),baoc440xt(pcols,pver), & - beoc500xt(pcols,pver),baoc500xt(pcols,pver), & - beoc550xt(pcols,pver),baoc550xt(pcols,pver), & - beoc670xt(pcols,pver),baoc670xt(pcols,pver), & - beoc870xt(pcols,pver),baoc870xt(pcols,pver) - - real(r8) bbclt1xt(pcols,pver), & - bbcgt1xt(pcols,pver), boclt1xt(pcols,pver), bocgt1xt(pcols,pver) - - real(r8) bint440du(pcols,pver), bint500du(pcols,pver), bint550du(pcols,pver), & - bint670du(pcols,pver), bint870du(pcols,pver), & - bint440ss(pcols,pver), bint500ss(pcols,pver), bint550ss(pcols,pver), & - bint670ss(pcols,pver), bint870ss(pcols,pver), & - baint550du(pcols,pver), baint550ss(pcols,pver) - - real(r8) bedustlt1(pcols,pver), bedustgt1(pcols,pver), & - besslt1(pcols,pver), bessgt1(pcols,pver) - - real(r8) dod4403d(pcols,pver), abs4403d(pcols,pver), & - dod4403d_ss(pcols,pver), & ! abs4403d_ss(pcols,pver), & - dod4403d_dust(pcols,pver), & ! abs4403d_dust(pcols,pver), & - dod4403d_so4(pcols,pver), & ! abs4403d_so4(pcols,pver), & - dod4403d_bc(pcols,pver), & ! abs4403d_bc(pcols,pver), & - dod4403d_pom(pcols,pver), & ! abs4403d_pom(pcols,pver), & - dod5003d(pcols,pver), abs5003d(pcols,pver), & - dod5003d_ss(pcols,pver), & ! abs5003d_ss(pcols,pver), & - dod5003d_dust(pcols,pver), & ! abs5003d_dust(pcols,pver), & - dod5003d_so4(pcols,pver), & ! abs5003d_so4(pcols,pver), & - dod5003d_bc(pcols,pver), & ! abs5003d_bc(pcols,pver), & - dod5003d_pom(pcols,pver), & ! abs5003d_pom(pcols,pver), & - dod5503d(pcols,pver), abs5503d(pcols,pver), abs5503dalt(pcols,pver), & - dod5503d_ss(pcols,pver), abs5503d_ss(pcols,pver), & - dod5503d_dust(pcols,pver), abs5503d_dust(pcols,pver), & - dod5503d_so4(pcols,pver), abs5503d_so4(pcols,pver), & - dod5503d_bc(pcols,pver), abs5503d_bc(pcols,pver), & - dod5503d_pom(pcols,pver), abs5503d_pom(pcols,pver), & - dod6703d(pcols,pver), abs6703d(pcols,pver), & - dod6703d_ss(pcols,pver), & ! abs6703d_ss(pcols,pver), & - dod6703d_dust(pcols,pver), & ! abs6703d_dust(pcols,pver), & - dod6703d_so4(pcols,pver), & ! abs6703d_so4(pcols,pver), & - dod6703d_bc(pcols,pver), & ! abs6703d_bc(pcols,pver), & - dod6703d_pom(pcols,pver), & ! abs6703d_pom(pcols,pver), & - dod8703d(pcols,pver), abs8703d(pcols,pver), & - dod8703d_ss(pcols,pver), & ! abs8703d_ss(pcols,pver), & - dod8703d_dust(pcols,pver), & ! abs8703d_dust(pcols,pver), & - dod8703d_so4(pcols,pver), & ! abs8703d_so4(pcols,pver), & - dod8703d_bc(pcols,pver), & ! abs8703d_bc(pcols,pver), & - dod8703d_pom(pcols,pver) ! abs8703d_pom(pcols,pver) - - real(r8) dod5503dlt1_ss(pcols,pver), dod5503dgt1_ss(pcols,pver), & - dod5503dlt1_dust(pcols,pver), dod5503dgt1_dust(pcols,pver), & - dod5503dlt1_so4(pcols,pver), dod5503dgt1_so4(pcols,pver), & - dod5503dlt1_bc(pcols,pver), dod5503dgt1_bc(pcols,pver), & - dod5503dlt1_pom(pcols,pver), dod5503dgt1_pom(pcols,pver) - - real(r8) abs440(pcols), dod500(pcols), abs500(pcols), & - dod670(pcols),& - abs670(pcols), abs870(pcols), & - dod440_ss(pcols), dod440_dust(pcols), dod440_so4(pcols), & - dod440_bc(pcols), dod440_pom(pcols), & - dod500_ss(pcols), dod500_dust(pcols), dod500_so4(pcols), & - dod500_bc(pcols), dod500_pom(pcols), & - dod550_ss(pcols), dod550_dust(pcols), dod550_so4(pcols), & - dod550_bc(pcols), dod550_pom(pcols), & - dod670_ss(pcols), dod670_dust(pcols), dod670_so4(pcols), & - dod670_bc(pcols), dod670_pom(pcols), & - dod870_ss(pcols), dod870_dust(pcols), dod870_so4(pcols), & - dod870_bc(pcols), dod870_pom(pcols), & - dod550lt1_ss(pcols), dod550gt1_ss(pcols), dod550lt1_dust(pcols), & - dod550gt1_dust(pcols), dod550lt1_so4(pcols), & - dod550gt1_so4(pcols), dod550lt1_bc(pcols), dod550gt1_bc(pcols), & - dod550lt1_pom(pcols), dod550gt1_pom(pcols) - - real(r8) abs550_ss(pcols), abs550_dust(pcols), & - abs550_so4(pcols), abs550_bc(pcols), abs550_pom(pcols) - - real(r8) batotsw13(pcols,pver), batotlw01(pcols,pver) - character(len=10) :: modeString - character(len=20) :: varname - integer irf,irfmax - real(r8) Camrel(pcols,pver,nbmodes) - real(r8) Camtot(pcols,nbmodes) - real(r8) cxsmtot(pcols,nbmodes) - real(r8) cxsmrel(pcols,nbmodes) - real(r8) xctrel,camdiff,cxsm - real(r8) cxs(pcols,pver), cxstot(pcols,pver), akcxs(pcols) - !------------------------------------------------------------------------- - - ! interpol-calculations only when daylight or not: - do icol=1,ncol - if (coszrs(icol) > 0.0_r8) then - daylight(icol) = .true. - else - daylight(icol) = .false. - endif - end do - - ! Initialize overshooting mass summed over all modes - do k=1,pver - do icol=1,ncol - cxstot(icol,k)=0.0_r8 - enddo - enddo - do icol=1,ncol - akcxs(icol)=0.0_r8 - enddo - - ! Initializing total and relative exessive (overshooting w.r.t. - ! look-up table maxima) added mass column: - do i=1,nbmodes - do icol=1,ncol - Camtot(icol,i)=0.0_r8 - cxsmtot(icol,i)=0.0_r8 - cxsmrel(icol,i)=0.0_r8 - enddo - enddo - - ! Calculating added internally mixed mass onto each mode 1-10, relative to - ! maximum mass which can be added w.r.t. the look-up tables (for level k), - ! as well as the relative exessive added mass column: - do i=1,4 - do k=1,pver - do icol=1,ncol - Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cate(i,16) - xctrel = min(max(Camrel(icol,k,i),cate(i,1)/cate(i,16)),1.0_r8) - camdiff = Cam(icol,k,i)-xctrel*cate(i,16)*(Nnatk(icol,k,i)+eps) - cxsm = max(0.0_r8,camdiff) - cxsmtot(icol,i) = cxsmtot(icol,i)+cxsm*deltah_km(icol,k) - Camtot(icol,i) = Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) - camdiff = Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) - cxs(icol,k) = max(0.0_r8,camdiff) - cxstot(icol,k) = cxstot(icol,k)+cxs(icol,k) - enddo - enddo - enddo - do i=5,nbmodes - do k=1,pver - do icol=1,ncol - Camrel(icol,k,i) = (Cam(icol,k,i)/(Nnatk(icol,k,i)+eps))/cat(i,6) - xctrel = min(max(Camrel(icol,k,i),cat(i,1)/cat(i,6)),1.0_r8) - camdiff = Cam(icol,k,i)-xctrel*cat(i,6)*(Nnatk(icol,k,i)+eps) - cxsm = max(0.0_r8,camdiff) - cxsmtot(icol,i) = cxsmtot(icol,i)+cxsm*deltah_km(icol,k) - Camtot(icol,i) = Camtot(icol,i)+Cam(icol,k,i)*deltah_km(icol,k) - camdiff = Cam(icol,k,i)-xct(icol,k,i)*(Nnatk(icol,k,i)+eps) - cxs(icol,k) = max(0.0_r8,camdiff) - cxstot(icol,k) = cxstot(icol,k)+cxs(icol,k) - enddo - enddo - enddo - - ! Total overshooting mass summed over all modes and all levels - do icol=1,ncol - do k=1,pver - akcxs(icol) =akcxs(icol)+cxstot(icol,k)*deltah_km(icol,k) - enddo - enddo - call outfld('AKCXS ',akcxs ,pcols,lchnk) - - do i=1,nbmodes - do icol=1,ncol - cxsmrel(icol,i)=cxsmtot(icol,i)/(Camtot(icol,i)+eps) - enddo - enddo - - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Camrel"//trim(modeString) - if(i.ne.3) call outfld(varName,Camrel(:,:,i),pcols,lchnk) - enddo - - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Cxsrel"//trim(modeString) - if(i.ne.3) call outfld(varName,cxsmrel(:,i),pcols,lchnk) - enddo - - ! AeroCom: Find dry aerosol asymmetry factor and mass for subsequent - ! calculation of condensed water mass below... - do k=1,pver - do icol=1,ncol - Ctotdry(icol,k)=0.0_r8 - rh0(icol,k)=0.0_r8 - asydry_aer(icol,k)=0.0_r8 - end do - enddo - - ! and define the respective RH input variables for dry aerosols - do k=1,pver - do icol=1,ncol - xrhnull(icol,k)=rh(1) - irh1null(icol,k)=1 - end do - enddo - - !-------- - lw_on = .false. ! No LW optics needed for RH=0 (interpol returns 0-values) - !-------- - - ! BC(ax) mode (dry only): - call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) - - mplus10 = 0 - ! SO4/SOA(Ait) mode: - call interpol1 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - - ! BC&OC(Ait) mode: ------ fcm not valid here (=0). Use faitbc instead - call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, & - xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - - ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call interpol5to10 (lchnk, ncol, daylight, xrhnull, irh1null, & - Nnatk, xct, ict1, xfac, ifac1, & - xfbc, ifbc1, xfaq, ifaq1, & - ssa, asym, be, ke, lw_on, kalw) - - mplus10 = 1 - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - - ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead - call interpol4 (lchnk, ncol, daylight, xrhnull, irh1null, mplus10, & - Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, & - ssa, asym, be, ke, lw_on, kalw) - - do i=0,nmodes ! mode 0 to 14 - do k=1,pver - do icol=1,ncol - dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) - Ctotdry(icol,k)=Ctotdry(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) - end do - enddo - enddo - - ! AeroCom Phase III: adding asymmetry factor for dry aerosol, wavelength band 4 only - ! (and with no CMIP6 volcnic contribution) - ib=4 - do k=1,pver - do icol=1,ncol - betot(icol,k,ib)=0.0_r8 - ssatot(icol,k,ib)=0.0_r8 - asymtot(icol,k,ib)=0.0_r8 - end do - enddo - do i=0,nmodes - do k=1,pver - do icol=1,ncol - betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) - ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib) - asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) - end do - enddo - enddo - do k=1,pver - do icol=1,ncol - ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) - asymtot(icol,k,ib)=asymtot(icol,k,ib) & - /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) - asydry_aer(icol,k)=asymtot(icol,k,ib) - end do - enddo - call outfld('ASYMMDRY',asydry_aer,pcols,lchnk) - - !..................! - - ! Mass concentration (ug/m3) and mmr (kg/kg) of aerosol condensed water - do k=1,pver - do icol=1,ncol - Cwater(icol,k)=Ctot(icol,k)-Ctotdry(icol,k) - mmr_aerh2o(icol,k)=1.e-9_r8*Cwater(icol,k)/rhoda(icol,k) - end do - enddo - - !..................! - - do i=1,ncol - do k=1,pver - batotsw13(i,k)=betot(i,k,13)*(1.0_r8-ssatot(i,k,13)) - batotlw01(i,k)=batotlw(i,k,1) - end do - end do - ! These two fields should be close to equal, both representing absorption - ! in the 3.077-3.846 um wavelenght band (i.e., a check of LUT for LW vs. SW). - call outfld('BATSW13 ',batotsw13,pcols,lchnk) - call outfld('BATLW01 ',batotlw01,pcols,lchnk) - - !..................! - - call outfld('BETOTVIS',betotvis,pcols,lchnk) - call outfld('BATOTVIS',batotvis,pcols,lchnk) - - ! Initialize fields - do icol=1,ncol - daerh2o(icol)=0.0_r8 - vaercols(icol)=0.0_r8 - vaercoll(icol)=0.0_r8 - aaercols(icol)=0.0_r8 - aaercoll(icol)=0.0_r8 - do i=0,nmodes - dload(icol,i)=0.0_r8 - enddo - enddo - vnbcarr(:,:) = 0.0_r8 - vaitbcarr(:,:) = 0.0_r8 - cknorm(:,:,:) = 0.0_r8 - - ! AeroCom diagnostics requiring table look-ups with ambient RH. - do irf=0,0 - call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) - end do ! irf - - do k=1,pver - do icol=1,ncol - - bebglt1t(icol,k)=0.0_r8 - bebggt1t(icol,k)=0.0_r8 - bebclt1t(icol,k)=0.0_r8 - bebcgt1t(icol,k)=0.0_r8 - beoclt1t(icol,k)=0.0_r8 - beocgt1t(icol,k)=0.0_r8 - bes4lt1t(icol,k)=0.0_r8 - bes4gt1t(icol,k)=0.0_r8 - bedustlt1(icol,k)=0.0_r8 - bedustgt1(icol,k)=0.0_r8 - besslt1(icol,k)=0.0_r8 - bessgt1(icol,k)=0.0_r8 - - bext440tot(icol,k)=0.0_r8 - babs440tot(icol,k)=0.0_r8 - bext500tot(icol,k)=0.0_r8 - babs500tot(icol,k)=0.0_r8 - bext550tot(icol,k)=0.0_r8 - babs550tot(icol,k)=0.0_r8 - bext670tot(icol,k)=0.0_r8 - babs670tot(icol,k)=0.0_r8 - bext870tot(icol,k)=0.0_r8 - babs870tot(icol,k)=0.0_r8 - - backsc550tot(icol,k)=0.0_r8 - - bebg440tot(icol,k)=0.0_r8 - bebg500tot(icol,k)=0.0_r8 - bebg550tot(icol,k)=0.0_r8 - babg550tot(icol,k)=0.0_r8 - bebg670tot(icol,k)=0.0_r8 - bebg870tot(icol,k)=0.0_r8 - - bebc440tot(icol,k)=0.0_r8 - bebc500tot(icol,k)=0.0_r8 - bebc550tot(icol,k)=0.0_r8 - babc550tot(icol,k)=0.0_r8 - bebc670tot(icol,k)=0.0_r8 - bebc870tot(icol,k)=0.0_r8 - - beoc440tot(icol,k)=0.0_r8 - beoc500tot(icol,k)=0.0_r8 - beoc550tot(icol,k)=0.0_r8 - baoc550tot(icol,k)=0.0_r8 - beoc670tot(icol,k)=0.0_r8 - beoc870tot(icol,k)=0.0_r8 - - besu440tot(icol,k)=0.0_r8 - besu500tot(icol,k)=0.0_r8 - besu550tot(icol,k)=0.0_r8 - basu550tot(icol,k)=0.0_r8 - besu670tot(icol,k)=0.0_r8 - besu870tot(icol,k)=0.0_r8 - - enddo - enddo - - do i=0,nbmodes - do k=1,pver - do icol=1,ncol - ! total internal extinction and absorption for 0.44, 0.50, 0.55, 0.68 and 0.87 um - bext440tot(icol,k)=bext440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext440(icol,k,i) - babs440tot(icol,k)=babs440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i) - bext500tot(icol,k)=bext500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext500(icol,k,i) - babs500tot(icol,k)=babs500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs500(icol,k,i) - bext550tot(icol,k)=bext550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext550(icol,k,i) - babs550tot(icol,k)=babs550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i) - bext670tot(icol,k)=bext670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext670(icol,k,i) - babs670tot(icol,k)=babs670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs670(icol,k,i) - bext870tot(icol,k)=bext870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bext870(icol,k,i) - babs870tot(icol,k)=babs870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i) - backsc550tot(icol,k)=backsc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%backsc550(icol,k,i) - - ! extinction and absorption for 0.44, 0.50, 0.55 (no abs), 0.68 and 0.87 um - ! for the whole background aerosol (icluding SO4,BC, and OC for modes 0-5) - bebg440tot(icol,k)=bebg440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg440(icol,k,i) - bebg500tot(icol,k)=bebg500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg500(icol,k,i) - bebg550tot(icol,k)=bebg550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg550(icol,k,i) - babg550tot(icol,k)=babg550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babg550(icol,k,i) - bebg670tot(icol,k)=bebg670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg670(icol,k,i) - bebg870tot(icol,k)=bebg870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebg870(icol,k,i) - besu440tot(icol,k)=besu440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu440(icol,k,i) - besu500tot(icol,k)=besu500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu500(icol,k,i) - besu550tot(icol,k)=besu550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu550(icol,k,i) - basu550tot(icol,k)=basu550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%basu550(icol,k,i) - besu670tot(icol,k)=besu670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu670(icol,k,i) - besu870tot(icol,k)=besu870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%besu870(icol,k,i) - ! - ! Condensed OC on modes 1-4 and coagulated BC and OC on modes 5-10: - if(i>=1) then - bebc440tot(icol,k)=bebc440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc440(icol,k,i) - bebc500tot(icol,k)=bebc500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc500(icol,k,i) - bebc550tot(icol,k)=bebc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc550(icol,k,i) - babc550tot(icol,k)=babc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babc550(icol,k,i) - bebc670tot(icol,k)=bebc670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc670(icol,k,i) - bebc870tot(icol,k)=bebc870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%bebc870(icol,k,i) - beoc440tot(icol,k)=beoc440tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc440(icol,k,i) - beoc500tot(icol,k)=beoc500tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc500(icol,k,i) - beoc550tot(icol,k)=beoc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc550(icol,k,i) - baoc550tot(icol,k)=baoc550tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%baoc550(icol,k,i) - beoc670tot(icol,k)=beoc670tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc670(icol,k,i) - beoc870tot(icol,k)=beoc870tot(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%beoc870(icol,k,i) - endif ! i>=1 - if(i==6.or.i==7) then - bedustlt1(icol,k)=bedustlt1(icol,k) +Nnatk(icol,k,i)*bebglt1(icol,k,i) - bedustgt1(icol,k)=bedustgt1(icol,k) +Nnatk(icol,k,i)*bebggt1(icol,k,i) - elseif(i>=8.and.i<=10) then - besslt1(icol,k)=besslt1(icol,k) +Nnatk(icol,k,i)*bebglt1(icol,k,i) - bessgt1(icol,k)=bessgt1(icol,k) +Nnatk(icol,k,i)*bebggt1(icol,k,i) - endif - ! Condensed/coagulated SO4 on all modes 1-10, and wet-phase SO4 on modes 4-10: - bes4lt1t(icol,k)=bes4lt1t(icol,k) +Nnatk(icol,k,i)*bes4lt1(icol,k,i) - bes4gt1t(icol,k)=bes4gt1t(icol,k) +Nnatk(icol,k,i)*bes4gt1(icol,k,i) - ! Condensed OC on mode 1 and coagulated BC and OC on modes 5-10: - if(i>=1) then - bebclt1t(icol,k)=bebclt1t(icol,k) +Nnatk(icol,k,i)*bebclt1(icol,k,i) - bebcgt1t(icol,k)=bebcgt1t(icol,k) +Nnatk(icol,k,i)*bebcgt1(icol,k,i) - beoclt1t(icol,k)=beoclt1t(icol,k) +Nnatk(icol,k,i)*beoclt1(icol,k,i) - beocgt1t(icol,k)=beocgt1t(icol,k) +Nnatk(icol,k,i)*beocgt1(icol,k,i) - endif ! i>=1 - end do ! icol - enddo ! k - enddo ! i - - ! extinction/absorptions (km-1) for each background component - ! in the internal mixture are - do k=1,pver - do icol=1,ncol - bint440du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg440(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg440(icol,k,7) - bint500du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg500(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg500(icol,k,7) - bint550du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg550(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg550(icol,k,7) - bint670du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg670(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg670(icol,k,7) - bint870du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%bebg870(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%bebg870(icol,k,7) - bint440ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg440(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg440(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg440(icol,k,10) - bint500ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg500(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg500(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg500(icol,k,10) - bint550ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg550(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg550(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg550(icol,k,10) - bint670ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg670(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg670(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg670(icol,k,10) - bint870ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%bebg870(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%bebg870(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%bebg870(icol,k,10) - baint550du(icol,k)=Nnatk(icol,k,6)*extinction_coeffs%babg550(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%babg550(icol,k,7) - baint550ss(icol,k)=Nnatk(icol,k,8)*extinction_coeffs%babg550(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%babg550(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%babg550(icol,k,10) - end do - enddo - - ! Need to make the following substitutions - ! bebglt1 bebglt1n => extinction_coeffs%bebg550lt1 - ! bebggt1 bebggt1n => extinction_coeffs%bebg550gt1 - ! bebclt1 bebclt1n => extinction_coeffs%bebc550lt1 - ! bebcgt1 bebcgt1n => extinction_coeffs%bebc550gt1 - ! beoclt1 beoclt1n => extinction_coeffs%beoc550lt1 - ! beocgt1 beocgt1n => extinction_coeffs%beoc550gt1 - ! bes4lt1 bes4lt1n => extinction_coeffs%besu550lt1 - ! bes4gt1 bes4gt1n => extinction_coeffs%besu550gt1 - - do i=11,14 - do k=1,pver - do icol=1,ncol - be440x(icol,k,i) = extinction_coeffsn%bext440(icol,k,i-10) - ba440x(icol,k,i) = extinction_coeffsn%babs440(icol,k,i-10) - be500x(icol,k,i) = extinction_coeffsn%bext500(icol,k,i-10) - ba500x(icol,k,i) = extinction_coeffsn%babs500(icol,k,i-10) - be550x(icol,k,i) = extinction_coeffsn%bext550(icol,k,i-10) - ba550x(icol,k,i) = extinction_coeffsn%babs550(icol,k,i-10) - be670x(icol,k,i) = extinction_coeffsn%bext670(icol,k,i-10) - ba670x(icol,k,i) = extinction_coeffsn%babs670(icol,k,i-10) - be870x(icol,k,i) = extinction_coeffsn%bext870(icol,k,i-10) - ba870x(icol,k,i) = extinction_coeffsn%babs870(icol,k,i-10) - belt1x(icol,k,i) = extinction_coeffsn%bebg550lt1(icol,k,i-10) - begt1x(icol,k,i) = extinction_coeffsn%bebg550gt1(icol,k,i-10) - backsc550x(icol,k,i) = extinction_coeffsn%backsc550(icol,k,i-10) - end do - enddo - enddo - - ! The externally modes' contribution to extinction and absorption: - do k=1,pver - do icol=1,ncol - - !BC - vnbcarr(icol,k) = fnbc(icol,k)/(fnbc(icol,k) & - +(1.0_r8-fnbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) - vnbc = vnbcarr(icol,k) - bebc440xt(icol,k) =Nnatk(icol,k,12)*be440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be440x(icol,k,14) - babc440xt(icol,k) =Nnatk(icol,k,12)*ba440x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba440x(icol,k,14) - bebc500xt(icol,k) =Nnatk(icol,k,12)*be500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be500x(icol,k,14) - babc500xt(icol,k) =Nnatk(icol,k,12)*ba500x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba500x(icol,k,14) - bebc550xt(icol,k) =Nnatk(icol,k,12)*be550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be550x(icol,k,14) - babc550xt(icol,k) =Nnatk(icol,k,12)*ba550x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba550x(icol,k,14) - bebc670xt(icol,k) =Nnatk(icol,k,12)*be670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be670x(icol,k,14) - babc670xt(icol,k) =Nnatk(icol,k,12)*ba670x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba670x(icol,k,14) - bebc870xt(icol,k) =Nnatk(icol,k,12)*be870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*be870x(icol,k,14) - babc870xt(icol,k) =Nnatk(icol,k,12)*ba870x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*ba870x(icol,k,14) - bbclt1xt(icol,k)=Nnatk(icol,k,12)*belt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*belt1x(icol,k,14) - bbcgt1xt(icol,k)=Nnatk(icol,k,12)*begt1x(icol,k,12) & - +vnbc*Nnatk(icol,k,14)*begt1x(icol,k,14) - !OC - beoc440xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be440x(icol,k,14) - baoc440xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba440x(icol,k,14) - beoc500xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be500x(icol,k,14) - baoc500xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba500x(icol,k,14) - beoc550xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be550x(icol,k,14) - baoc550xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba550x(icol,k,14) - beoc670xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be670x(icol,k,14) - baoc670xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba670x(icol,k,14) - beoc870xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*be870x(icol,k,14) - baoc870xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*ba870x(icol,k,14) - boclt1xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*belt1x(icol,k,14) - bocgt1xt(icol,k) = & - +(1.0_r8-vnbc)*Nnatk(icol,k,14)*begt1x(icol,k,14) - ! Total (for all modes) absorption optical depth and backscattering - abs550_aer(icol,k)=babs550tot(icol,k) & - +Nnatk(icol,k,12)*ba550x(icol,k,12) & - +Nnatk(icol,k,14)*ba550x(icol,k,14) - abs550_aer(icol,k)=1.e-3_r8*abs550_aer(icol,k) - bs550_aer(icol,k)= backsc550tot(icol,k) & - +Nnatk(icol,k,12)*backsc550x(icol,k,12) & - +Nnatk(icol,k,14)*backsc550x(icol,k,14) - bs550_aer(icol,k)=1.e-3_r8*bs550_aer(icol,k) - ! - end do - enddo - - ! collect AeroCom-fields for optical depth/absorption of each comp, - ! 3D and 2D, at 440, 500, 550, 670 and 870 nm, for all d, d<1um and d>1um - ! initialize 2d-fields - do icol=1,ncol - dod440(icol) = 0.0_r8 - abs440(icol) = 0.0_r8 - dod500(icol) = 0.0_r8 - abs500(icol) = 0.0_r8 - dod550(icol) = 0.0_r8 - abs550(icol) = 0.0_r8 - abs550alt(icol) = 0.0_r8 - dod670(icol) = 0.0_r8 - abs670(icol) = 0.0_r8 - dod870(icol) = 0.0_r8 - abs870(icol) = 0.0_r8 - ! - abs550_ss(icol) = 0.0_r8 - abs550_dust(icol) = 0.0_r8 - abs550_so4(icol) = 0.0_r8 - abs550_bc(icol) = 0.0_r8 - abs550_pom(icol) = 0.0_r8 - ! - dod440_ss(icol) = 0.0_r8 - dod440_dust(icol) = 0.0_r8 - dod440_so4(icol) = 0.0_r8 - dod440_bc(icol) = 0.0_r8 - dod440_pom(icol) = 0.0_r8 - dod500_ss(icol) = 0.0_r8 - dod500_dust(icol) = 0.0_r8 - dod500_so4(icol) = 0.0_r8 - dod500_bc(icol) = 0.0_r8 - dod500_pom(icol) = 0.0_r8 - dod550_ss(icol) = 0.0_r8 - dod550_dust(icol) = 0.0_r8 - dod550_so4(icol) = 0.0_r8 - dod550_bc(icol) = 0.0_r8 - dod550_pom(icol) = 0.0_r8 - dod670_ss(icol) = 0.0_r8 - dod670_dust(icol) = 0.0_r8 - dod670_so4(icol) = 0.0_r8 - dod670_bc(icol) = 0.0_r8 - dod670_pom(icol) = 0.0_r8 - dod870_ss(icol) = 0.0_r8 - dod870_dust(icol) = 0.0_r8 - dod870_so4(icol) = 0.0_r8 - dod870_bc(icol) = 0.0_r8 - dod870_pom(icol) = 0.0_r8 - dod550lt1_ss(icol) = 0.0_r8 - dod550gt1_ss(icol) = 0.0_r8 - dod550lt1_dust(icol) = 0.0_r8 - dod550gt1_dust(icol) = 0.0_r8 - dod550lt1_so4(icol) = 0.0_r8 - dod550gt1_so4(icol) = 0.0_r8 - dod550lt1_bc(icol) = 0.0_r8 - dod550gt1_bc(icol) = 0.0_r8 - dod550lt1_pom(icol) = 0.0_r8 - dod550gt1_pom(icol) = 0.0_r8 - do k=1,pver - abs4403d(icol,k) = 0.0_r8 - abs5003d(icol,k) = 0.0_r8 - abs5503d(icol,k) = 0.0_r8 - abs6703d(icol,k) = 0.0_r8 - abs8703d(icol,k) = 0.0_r8 - abs5503dalt(icol,k) = 0.0_r8 - enddo - enddo - - do icol=1,ncol - do k=1,pver - ! Layer thickness, unit km - deltah=deltah_km(icol,k) - ! if(k==pver) write(*,*) 'icol, deltah(pmxsub)=', icol, deltah - ! 3D optical depths for monthly averages - !SS - dod4403d_ss(icol,k) = bint440ss(icol,k)*deltah - dod5003d_ss(icol,k) = bint500ss(icol,k)*deltah - dod5503d_ss(icol,k) = bint550ss(icol,k)*deltah - abs5503d_ss(icol,k) = baint550ss(icol,k)*deltah - dod6703d_ss(icol,k) = bint670ss(icol,k)*deltah - dod8703d_ss(icol,k) = bint870ss(icol,k)*deltah - !DUST - dod4403d_dust(icol,k) = bint440du(icol,k)*deltah - dod5003d_dust(icol,k) = bint500du(icol,k)*deltah - dod5503d_dust(icol,k) = bint550du(icol,k)*deltah - abs5503d_dust(icol,k) = baint550du(icol,k)*deltah - dod6703d_dust(icol,k) = bint670du(icol,k)*deltah - dod8703d_dust(icol,k) = bint870du(icol,k)*deltah - !SO4 - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - dod4403d_so4(icol,k) = (besu440tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg440(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg440(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5003d_so4(icol,k) = (besu500tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg500(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg500(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5503d_so4(icol,k) = (besu550tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - abs5503d_so4(icol,k) = (basu550tot(icol,k) & ! condensate ) - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%babg550(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod6703d_so4(icol,k) = (besu670tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg670(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg670(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod8703d_so4(icol,k) = (besu870tot(icol,k) & ! condensate - +(1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%bebg870(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg870(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - !BC - vaitbcarr(icol,k) = faitbc(icol,k)/(faitbc(icol,k) & - +(1.0_r8-faitbc(icol,k))*rhopart(l_bc_ni)/rhopart(l_om_ni)) - vaitbc = vaitbcarr(icol,k) - dod4403d_bc(icol,k) = (bebc440tot(icol,k)+bebc440xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg440(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg440(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg440(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5003d_bc(icol,k) = (bebc500tot(icol,k)+bebc500xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg500(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg500(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg500(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5503d_bc(icol,k) = (bebc550tot(icol,k)+bebc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg550(icol,k,0))*deltah ! background, BC(ax) mode (0) - abs5503d_bc(icol,k) = (babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%babg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%babg550(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod6703d_bc(icol,k) = (bebc670tot(icol,k)+bebc670xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg670(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg670(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg670(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod8703d_bc(icol,k) = (bebc870tot(icol,k)+bebc870xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg870(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*extinction_coeffs%bebg870(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg870(icol,k,0))*deltah ! background, BC(ax) mode (0) - !OC - !soa + v_soana part of mode 11 for the OC volume fraction of that mode - ! v_soana(icol,k) - dod4403d_pom(icol,k) = (beoc440tot(icol,k)+beoc440xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg440(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg440(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5003d_pom(icol,k) = (beoc500tot(icol,k)+beoc500xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg500(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg500(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5503d_pom(icol,k) = (beoc550tot(icol,k)+beoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - abs5503d_pom(icol,k) = (baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod6703d_pom(icol,k) = (beoc670tot(icol,k)+beoc670xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg670(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg670(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod8703d_pom(icol,k) = (beoc870tot(icol,k)+beoc870xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*extinction_coeffs%bebg870(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*extinction_coeffs%bebg870(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - - ec550_so4(icol,k) = 1.e-3*dod5503d_so4(icol,k)/deltah - ec550_bc(icol,k) = 1.e-3*dod5503d_bc(icol,k)/deltah - ec550_pom(icol,k) = 1.e-3*dod5503d_pom(icol,k)/deltah - ec550_ss(icol,k) = 1.e-3*dod5503d_ss(icol,k)/deltah - ec550_du(icol,k) = 1.e-3*dod5503d_dust(icol,k)/deltah - ec550_aer(icol,k) = ec550_so4(icol,k)+ec550_bc(icol,k)+ec550_pom(icol,k) & - + ec550_ss(icol,k)+ec550_du(icol,k) - - ! Total 3D optical depths/abs. for column integrations - dod4403d(icol,k) = dod4403d_ss(icol,k)+dod4403d_dust(icol,k) & - +dod4403d_so4(icol,k)+dod4403d_bc(icol,k) & - +dod4403d_pom(icol,k) - dod5003d(icol,k) = dod5003d_ss(icol,k)+dod5003d_dust(icol,k) & - +dod5003d_so4(icol,k)+dod5003d_bc(icol,k) & - +dod5003d_pom(icol,k) - dod5503d(icol,k) = dod5503d_ss(icol,k)+dod5503d_dust(icol,k) & - +dod5503d_so4(icol,k)+dod5503d_bc(icol,k) & - +dod5503d_pom(icol,k) - dod6703d(icol,k) = dod6703d_ss(icol,k)+dod6703d_dust(icol,k) & - +dod6703d_so4(icol,k)+dod6703d_bc(icol,k) & - +dod6703d_pom(icol,k) - dod8703d(icol,k) = dod8703d_ss(icol,k)+dod8703d_dust(icol,k) & - +dod8703d_so4(icol,k)+dod8703d_bc(icol,k) & - +dod8703d_pom(icol,k) - abs5503d(icol,k) = abs5503d_ss(icol,k)+abs5503d_dust(icol,k) & - +abs5503d_so4(icol,k)+abs5503d_bc(icol,k) & - +abs5503d_pom(icol,k) - ! (Note: Local abs550alt is up to 6% larger (annually averaged) in typical b.b. - ! regions, compared to abs550. This is most likely most correct, but should be checked!) - do i=0,10 - abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i)*deltah - abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs500(icol,k,i)*deltah - abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs670(icol,k,i)*deltah - abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i)*deltah - abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i)*deltah - enddo - do i=11,14 - abs4403d(icol,k) = abs4403d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs440(icol,k,i-10)*deltah - abs5003d(icol,k) = abs5003d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs500(icol,k,i-10)*deltah - abs6703d(icol,k) = abs6703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs670(icol,k,i-10)*deltah - abs8703d(icol,k) = abs8703d(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs870(icol,k,i-10)*deltah - abs5503dalt(icol,k) = abs5503dalt(icol,k)+Nnatk(icol,k,i)*extinction_coeffsn%babs550(icol,k,i-10)*deltah - enddo - - ! optical depths for d<1um and d>1um (r<0.5um and r>0.5um) - !SS - dod5503dlt1_ss(icol,k) = besslt1(icol,k)*deltah - dod5503dgt1_ss(icol,k) = bessgt1(icol,k)*deltah - !DUST - dod5503dlt1_dust(icol,k) = bedustlt1(icol,k)*deltah - dod5503dgt1_dust(icol,k) = bedustgt1(icol,k)*deltah - - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - dod5503dlt1_so4(icol,k) = (bes4lt1t(icol,k) & ! condensate - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebglt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - dod5503dgt1_so4(icol,k) = (bes4gt1t(icol,k) & ! condensate + n-mode (11) - + Nnatk(icol,k,1)*bebggt1(icol,k,1)*(1.0_r8-v_soana(icol,k)) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*bebggt1(icol,k,5))*deltah ! background, SO4(Ait75) mode (5) - !BC - dod5503dlt1_bc(icol,k) = (bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebglt1(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebglt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebglt1(icol,k,0))*deltah ! background, BC(ax) mode (0) - dod5503dgt1_bc(icol,k) = (bebcgt1t(icol,k)+bbcgt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*bebggt1(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc*Nnatk(icol,k,4)*bebggt1(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*bebggt1(icol,k,0))*deltah ! background, BC(ax) mode (0) - !OC - !soa + v_soana part of mode 11 for the OC volume fraction of that mode - dod5503dlt1_pom(icol,k) = (beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC&BC (14) - + Nnatk(icol,k,1)*bebglt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*bebglt1(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebglt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - dod5503dgt1_pom(icol,k) = (beocgt1t(icol,k)+bocgt1xt(icol,k) & ! coagulated + n-mode OC&OC (14) - + Nnatk(icol,k,1)*bebggt1(icol,k,1)*v_soana(icol,k) & ! SOA fraction of mode 1 - !-3 + Nnatk(icol,k,3)*bebggt1(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc)*Nnatk(icol,k,4)*bebggt1(icol,k,4))*deltah ! background in OC&BC(Ait) mode (4) - - ! Column integrated optical depths/abs., total and for each constituent - dod440(icol) = dod440(icol)+dod4403d(icol,k) - abs440(icol) = abs440(icol)+abs4403d(icol,k) - dod500(icol) = dod500(icol)+dod5003d(icol,k) - abs500(icol) = abs500(icol)+abs5003d(icol,k) - dod550(icol) = dod550(icol)+dod5503d(icol,k) - abs550(icol) = abs550(icol)+abs5503d(icol,k) - abs550alt(icol) = abs550alt(icol)+abs5503dalt(icol,k) - dod670(icol) = dod670(icol)+dod6703d(icol,k) - abs670(icol) = abs670(icol)+abs6703d(icol,k) - dod870(icol) = dod870(icol)+dod8703d(icol,k) - abs870(icol) = abs870(icol)+abs8703d(icol,k) - ! Added abs components - abs550_ss(icol) = abs550_ss(icol)+abs5503d_ss(icol,k) - abs550_dust(icol) = abs550_dust(icol)+abs5503d_dust(icol,k) - abs550_so4(icol) = abs550_so4(icol)+abs5503d_so4(icol,k) - abs550_bc(icol) = abs550_bc(icol)+abs5503d_bc(icol,k) - abs550_pom(icol) = abs550_pom(icol)+abs5503d_pom(icol,k) - ! - dod440_ss(icol) = dod440_ss(icol)+dod4403d_ss(icol,k) - dod440_dust(icol) = dod440_dust(icol)+dod4403d_dust(icol,k) - dod440_so4(icol) = dod440_so4(icol)+dod4403d_so4(icol,k) - dod440_bc(icol) = dod440_bc(icol)+dod4403d_bc(icol,k) - dod440_pom(icol) = dod440_pom(icol)+dod4403d_pom(icol,k) - dod500_ss(icol) = dod500_ss(icol)+dod5003d_ss(icol,k) - dod500_dust(icol) = dod500_dust(icol)+dod5003d_dust(icol,k) - dod500_so4(icol) = dod500_so4(icol)+dod5003d_so4(icol,k) - dod500_bc(icol) = dod500_bc(icol)+dod5003d_bc(icol,k) - dod500_pom(icol) = dod500_pom(icol)+dod5003d_pom(icol,k) - dod550_ss(icol) = dod550_ss(icol)+dod5503d_ss(icol,k) - dod550_dust(icol) = dod550_dust(icol)+dod5503d_dust(icol,k) - dod550_so4(icol) = dod550_so4(icol)+dod5503d_so4(icol,k) - dod550_bc(icol) = dod550_bc(icol)+dod5503d_bc(icol,k) - dod550_pom(icol) = dod550_pom(icol)+dod5503d_pom(icol,k) - dod670_ss(icol) = dod670_ss(icol)+dod6703d_ss(icol,k) - dod670_dust(icol) = dod670_dust(icol)+dod6703d_dust(icol,k) - dod670_so4(icol) = dod670_so4(icol)+dod6703d_so4(icol,k) - dod670_bc(icol) = dod670_bc(icol)+dod6703d_bc(icol,k) - dod670_pom(icol) = dod670_pom(icol)+dod6703d_pom(icol,k) - dod870_ss(icol) = dod870_ss(icol)+dod8703d_ss(icol,k) - dod870_dust(icol) = dod870_dust(icol)+dod8703d_dust(icol,k) - dod870_so4(icol) = dod870_so4(icol)+dod8703d_so4(icol,k) - dod870_bc(icol) = dod870_bc(icol)+dod8703d_bc(icol,k) - dod870_pom(icol) = dod870_pom(icol)+dod8703d_pom(icol,k) - dod550lt1_ss(icol) = dod550lt1_ss(icol)+dod5503dlt1_ss(icol,k) - dod550gt1_ss(icol) = dod550gt1_ss(icol)+dod5503dgt1_ss(icol,k) - dod550lt1_dust(icol) = dod550lt1_dust(icol)+dod5503dlt1_dust(icol,k) - dod550gt1_dust(icol) = dod550gt1_dust(icol)+dod5503dgt1_dust(icol,k) - dod550lt1_so4(icol) = dod550lt1_so4(icol)+dod5503dlt1_so4(icol,k) - dod550gt1_so4(icol) = dod550gt1_so4(icol)+dod5503dgt1_so4(icol,k) - dod550lt1_bc(icol) = dod550lt1_bc(icol)+dod5503dlt1_bc(icol,k) - dod550gt1_bc(icol) = dod550gt1_bc(icol)+dod5503dgt1_bc(icol,k) - dod550lt1_pom(icol) = dod550lt1_pom(icol)+dod5503dlt1_pom(icol,k) - dod550gt1_pom(icol) = dod550gt1_pom(icol)+dod5503dgt1_pom(icol,k) - enddo ! k - - enddo ! icol - - ! extinction, absorption (m-1) and backscatter coefficients (m-1 sr-1) - call outfld('EC550AER',ec550_aer,pcols,lchnk) - call outfld('ABS550_A',abs550_aer,pcols,lchnk) - call outfld('BS550AER',bs550_aer,pcols,lchnk) - ! - ! speciated extinction coefficients (m-1) - call outfld('EC550SO4',ec550_so4,pcols,lchnk) - call outfld('EC550BC ',ec550_bc ,pcols,lchnk) - call outfld('EC550POM',ec550_pom,pcols,lchnk) - call outfld('EC550SS ',ec550_ss ,pcols,lchnk) - call outfld('EC550DU ',ec550_du ,pcols,lchnk) - ! - ! optical depths and absorption as requested by AeroCom - ! notation: 3=3D, D=DOD, A=ABS, LT=d<1um, GT=d>1um - call outfld('DOD440 ',dod440 ,pcols,lchnk) - call outfld('ABS440 ',abs440 ,pcols,lchnk) - call outfld('DOD500 ',dod500 ,pcols,lchnk) - call outfld('ABS500 ',abs500 ,pcols,lchnk) - call outfld('DOD550 ',dod550 ,pcols,lchnk) - call outfld('ABS550 ',abs550 ,pcols,lchnk) - call outfld('ABS550AL',abs550alt,pcols,lchnk) - call outfld('DOD670 ',dod670 ,pcols,lchnk) - call outfld('ABS670 ',abs670 ,pcols,lchnk) - call outfld('DOD870 ',dod870 ,pcols,lchnk) - call outfld('ABS870 ',abs870 ,pcols,lchnk) - call outfld('A550_SS ',abs550_ss ,pcols,lchnk) - call outfld('A550_DU ',abs550_dust,pcols,lchnk) - call outfld('A550_SO4',abs550_so4 ,pcols,lchnk) - call outfld('A550_BC ',abs550_bc ,pcols,lchnk) - call outfld('A550_POM',abs550_pom ,pcols,lchnk) - ! - call outfld('D440_SS ',dod440_ss ,pcols,lchnk) - call outfld('D440_DU ',dod440_dust,pcols,lchnk) - call outfld('D440_SO4',dod440_so4 ,pcols,lchnk) - call outfld('D440_BC ',dod440_bc ,pcols,lchnk) - call outfld('D440_POM',dod440_pom ,pcols,lchnk) - call outfld('D500_SS ',dod500_ss ,pcols,lchnk) - call outfld('D500_DU ',dod500_dust,pcols,lchnk) - call outfld('D500_SO4',dod500_so4 ,pcols,lchnk) - call outfld('D500_BC ',dod500_bc ,pcols,lchnk) - call outfld('D500_POM',dod500_pom ,pcols,lchnk) - call outfld('D550_SS ',dod550_ss ,pcols,lchnk) - call outfld('D550_DU ',dod550_dust,pcols,lchnk) - call outfld('D550_SO4',dod550_so4 ,pcols,lchnk) - call outfld('D550_BC ',dod550_bc ,pcols,lchnk) - call outfld('D550_POM',dod550_pom ,pcols,lchnk) - call outfld('D670_SS ',dod670_ss ,pcols,lchnk) - call outfld('D670_DU ',dod670_dust,pcols,lchnk) - call outfld('D670_SO4',dod670_so4 ,pcols,lchnk) - call outfld('D670_BC ',dod670_bc ,pcols,lchnk) - call outfld('D670_POM',dod670_pom ,pcols,lchnk) - call outfld('D870_SS ',dod870_ss ,pcols,lchnk) - call outfld('D870_DU ',dod870_dust,pcols,lchnk) - call outfld('D870_SO4',dod870_so4 ,pcols,lchnk) - call outfld('D870_BC ',dod870_bc ,pcols,lchnk) - call outfld('D870_POM',dod870_pom ,pcols,lchnk) - call outfld('DLT_SS ',dod550lt1_ss,pcols,lchnk) - call outfld('DGT_SS ',dod550gt1_ss,pcols,lchnk) - call outfld('DLT_DUST',dod550lt1_dust,pcols,lchnk) - call outfld('DGT_DUST',dod550gt1_dust,pcols,lchnk) - call outfld('DLT_SO4 ',dod550lt1_so4,pcols,lchnk) - call outfld('DGT_SO4 ',dod550gt1_so4,pcols,lchnk) - call outfld('DLT_BC ',dod550lt1_bc,pcols,lchnk) - call outfld('DGT_BC ',dod550gt1_bc,pcols,lchnk) - call outfld('DLT_POM ',dod550lt1_pom,pcols,lchnk) - call outfld('DGT_POM ',dod550gt1_pom,pcols,lchnk) - ! Dry parameters of each aerosol component - ! BC(ax) mode - call aerodry_prop%intdrypar0(lchnk, ncol, Nnatk) - - ! SO4&SOA(Ait,n) mode - call aerodry_prop%intdrypar1(lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) - - ! BC(Ait,n) and OC(Ait,n) modes - call aerodry_prop%intdrypar2to3(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1) - - ! BC&OC(Ait,n) mode ------ fcm not valid here (=0). Use faitbc or fnbc instead - call aerodry_prop%intdrypar4(lchnk, ncol, Nnatk, xfbcbg, ifbcbg1, xfbcbgn, ifbcbgn1, & - xct, ict1, xfac, ifac1, xfaq, ifaq1) - - ! SO4(Ait75) (5), mineral (6-7) and Sea-salt (8-10) modes: - call aerodry_prop%intdrypar5to10(lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) - - do k=1,pver - do icol=1,ncol - c_ss(icol,k)=0.0_r8 - c_mi(icol,k)=0.0_r8 - enddo - enddo - - do k=1,pver - do icol=1,ncol - ! mineral and sea-salt background concentrations, internally mixed - c_mi(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg(icol,k,6) & - +Nnatk(icol,k,7) * aerodry_prop%cintbg(icol,k,7) - c_mi05(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg05(icol,k,6) & - +Nnatk(icol,k,7) * aerodry_prop%cintbg05(icol,k,7) - c_mi125(icol,k) = Nnatk(icol,k,6) * aerodry_prop%cintbg125(icol,k,6)& - +Nnatk(icol,k,7) * aerodry_prop%cintbg125(icol,k,7) - c_ss(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg(icol,k,8) & - +Nnatk(icol,k,9) * aerodry_prop%cintbg(icol,k,9) & - +Nnatk(icol,k,10) * aerodry_prop%cintbg(icol,k,10) - c_ss05(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg05(icol,k,8) & - +Nnatk(icol,k,9) * aerodry_prop%cintbg05(icol,k,9) & - +Nnatk(icol,k,10) * aerodry_prop%cintbg05(icol,k,10) - c_ss125(icol,k) = Nnatk(icol,k,8) * aerodry_prop%cintbg125(icol,k,8)& - +Nnatk(icol,k,9) * aerodry_prop%cintbg125(icol,k,9) & - +Nnatk(icol,k,10) * aerodry_prop%cintbg125(icol,k,10) - - ! internally mixed bc and oc (from coagulation) and so4 concentrations - ! (sa=so4(aq) and sc=so4(cond+coag), separated because of different density: - ! necessary for calculation of volume fractions!), and total aerosol surface - ! areas and volumes. - c_bc(icol,k)=0.0_r8 - c_bc05(icol,k)=0.0_r8 - c_bc125(icol,k)=0.0_r8 - c_oc(icol,k)=0.0_r8 - c_oc05(icol,k)=0.0_r8 - c_oc125(icol,k)=0.0_r8 - c_s4(icol,k)=0.0_r8 - c_s4_a(icol,k)=0.0_r8 - c_s4_1(icol,k)=0.0_r8 - c_s4_5(icol,k)=0.0_r8 - c_sa(icol,k)=0.0_r8 - c_sa05(icol,k)=0.0_r8 - c_sa125(icol,k)=0.0_r8 - c_sc(icol,k)=0.0_r8 - c_sc05(icol,k)=0.0_r8 - c_sc125(icol,k)=0.0_r8 - aaeros_tot(icol,k)=0.0_r8 - aaerol_tot(icol,k)=0.0_r8 - vaeros_tot(icol,k)=0.0_r8 - vaerol_tot(icol,k)=0.0_r8 - c_bc_0(icol,k)=0.0_r8 - c_bc_2(icol,k)=0.0_r8 - c_bc_4(icol,k)=0.0_r8 - c_bc_12(icol,k)=0.0_r8 - c_bc_14(icol,k)=0.0_r8 - c_oc_4(icol,k)=0.0_r8 - c_oc_14(icol,k)=0.0_r8 - c_tot(icol,k)=0.0_r8 - c_tot125(icol,k)=0.0_r8 - c_tot05(icol,k)=0.0_r8 - c_pm25(icol,k)=0.0_r8 - c_pm1(icol,k)=0.0_r8 - mmr_pm25(icol,k)=0.0_r8 - mmr_pm1(icol,k)=0.0_r8 - - do i=0,nbmodes - if(i.ne.3) then - c_bc(icol,k) = c_bc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc(icol,k,i) - c_bc05(icol,k) = c_bc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc05(icol,k,i) - c_bc125(icol,k) = c_bc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintbc125(icol,k,i) - c_oc(icol,k) = c_oc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc(icol,k,i) - c_oc05(icol,k) = c_oc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc05(icol,k,i) - c_oc125(icol,k) = c_oc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintoc125(icol,k,i) - c_sa(icol,k) = c_sa(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa(icol,k,i) - c_sa05(icol,k) = c_sa05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa05(icol,k,i) - c_sa125(icol,k) = c_sa125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsa125(icol,k,i) - c_sc(icol,k) = c_sc(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc(icol,k,i) - c_sc05(icol,k) = c_sc05(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc05(icol,k,i) - c_sc125(icol,k) = c_sc125(icol,k) + Nnatk(icol,k,i) * aerodry_prop%cintsc125(icol,k,i) - aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeros(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerol(icol,k,i) - vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeros(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerol(icol,k,i) - endif - enddo - ! add dry aerosol area and volume of externally mixed modes - do i=nbmp1,nmodes - aaeros_tot(icol,k) = aaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaerosn(icol,k,i) - aaerol_tot(icol,k) = aaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%aaeroln(icol,k,i) - vaeros_tot(icol,k) = vaeros_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaerosn(icol,k,i) - vaerol_tot(icol,k) = vaerol_tot(icol,k) + Nnatk(icol,k,i) * aerodry_prop%vaeroln(icol,k,i) - end do - - !c_er3d - ! Effective radii for particles smaller and greater than 0.5um, - ! and for all radii, in each layer (er=3*V/A): - erlt053d(icol,k)=3.0_r8*vaeros_tot(icol,k) /(aaeros_tot(icol,k)+eps) - ergt053d(icol,k)=3.0_r8*vaerol_tot(icol,k) /(aaerol_tot(icol,k)+eps) - er3d(icol,k)=3.0_r8*(vaeros_tot(icol,k)+vaerol_tot(icol,k)) /(aaeros_tot(icol,k)+aaerol_tot(icol,k)+eps) - - !c_er3d - ! column integrated dry aerosol surface areas and volumes - ! for r<0.5um and r>0.5um (s and l, respectively). - aaercols(icol)=aaercols(icol)+aaeros_tot(icol,k) - aaercoll(icol)=aaercoll(icol)+aaerol_tot(icol,k) - vaercols(icol)=vaercols(icol)+vaeros_tot(icol,k) - vaercoll(icol)=vaercoll(icol)+vaerol_tot(icol,k) - - ! then add background and externally mixed BC, OC and SO4 to mass concentrations - c_bc_ac(icol,k)= c_bc(icol,k) - c_bc_0(icol,k) = Nnatk(icol,k,0) * aerodry_prop%cintbg(icol,k,0) - c_bc_2(icol,k) = Nnatk(icol,k,2) * aerodry_prop%cintbg(icol,k,2) - c_bc_4(icol,k) = Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*faitbc(icol,k) - c_bc_12(icol,k)= Nnatk(icol,k,12) * aerodry_prop%cknorm(icol,k,12) - c_bc_14(icol,k)= Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) - c_bc(icol,k) = c_bc(icol,k) & - +Nnatk(icol,k,2) * aerodry_prop%cintbg(icol,k,2) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4) * faitbc(icol,k) & - +Nnatk(icol,k,0) * aerodry_prop%cintbg(icol,k,0) & - +Nnatk(icol,k,12) * aerodry_prop%cknorm(icol,k,12) & - +Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*fnbc(icol,k) - c_bc05(icol,k) = c_bc05(icol,k) & - +Nnatk(icol,k,2) * aerodry_prop%cintbg05(icol,k,2) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg05(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0) * aerodry_prop%cintbg05(icol,k,0) & - +Nnatk(icol,k,12) * aerodry_prop%cknlt05(icol,k,12) & - +Nnatk(icol,k,14) * aerodry_prop%cknlt05(icol,k,14)*fnbc(icol,k) - c_bc125(icol,k) = c_bc125(icol,k) & - +Nnatk(icol,k,2) * aerodry_prop%cintbg125(icol,k,2) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg125(icol,k,4)*faitbc(icol,k) & - +Nnatk(icol,k,0) * aerodry_prop%cintbg125(icol,k,0) & - +Nnatk(icol,k,12) * aerodry_prop%ckngt125(icol,k,12) & - +Nnatk(icol,k,14) * aerodry_prop%ckngt125(icol,k,14)*fnbc(icol,k) - c_oc_ac(icol,k)= c_oc(icol,k) - c_oc_4(icol,k) = Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) - c_oc_14(icol,k) = Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc(icol,k) = c_oc(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*f_soana(icol,k) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14) * aerodry_prop%cknorm(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc05(icol,k) = c_oc05(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg05(icol,k,1)*f_soana(icol,k) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg05(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14) * aerodry_prop%cknlt05(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_oc125(icol,k) = c_oc125(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg125(icol,k,1)*f_soana(icol,k) & - +Nnatk(icol,k,4) * aerodry_prop%cintbg125(icol,k,4)*(1.0_r8-faitbc(icol,k)) & - +Nnatk(icol,k,14) * aerodry_prop%ckngt125(icol,k,14)*(1.0_r8-fnbc(icol,k)) - c_s4(icol,k) = c_sa(icol,k)+c_sc(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5) * aerodry_prop%cintbg(icol,k,5) - c_s405(icol,k) = c_sa05(icol,k)+c_sc05(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg05(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5) * aerodry_prop%cintbg05(icol,k,5) - c_s4125(icol,k) = c_sa125(icol,k)+c_sc125(icol,k) & - +Nnatk(icol,k,1) * aerodry_prop%cintbg125(icol,k,1)*(1.0_r8-f_soana(icol,k)) & - +Nnatk(icol,k,5) * aerodry_prop%cintbg125(icol,k,5) - - c_tot(icol,k) = c_s4(icol,k) + c_oc(icol,k) + c_bc(icol,k) + c_mi(icol,k) + c_ss(icol,k) - c_tot125(icol,k) = c_s4125(icol,k) + c_oc125(icol,k) + c_bc125(icol,k) + c_mi125(icol,k) + c_ss125(icol,k) - c_tot05(icol,k) = c_s405(icol,k) + c_oc05(icol,k) + c_bc05(icol,k) + c_mi05(icol,k) + c_ss05(icol,k) - c_pm25(icol,k) = c_tot(icol,k) - c_tot125(icol,k) - c_pm1(icol,k) = c_tot05(icol,k) - - ! mass mixing ratio: - mmr_pm25(icol,k) = 1.e-9*c_pm25(icol,k)/rhoda(icol,k) - mmr_pm1(icol,k) = 1.e-9*c_pm1(icol,k)/rhoda(icol,k) - - ! converting from S to SO4 concentrations is no longer necessary, since - ! sc=H2SO4 and sa=(NH4)2SO4 now, not SO4 as in CAM4-Oslo - ! c_s4(icol,k)=c_s4(icol,k)/3._r8 - ! c_s405(icol,k)=c_s405(icol,k)/3._r8 - ! c_s4125(icol,k)=c_s4125(icol,k)/3._r8 - - c_s4_a(icol,k) = c_sa(icol,k)+c_sc(icol,k) - c_s4_1(icol,k) = Nnatk(icol,k,1) * aerodry_prop%cintbg(icol,k,1)*(1.0_r8-f_soana(icol,k)) - c_s4_5(icol,k) = Nnatk(icol,k,5) * aerodry_prop%cintbg05(icol,k,5) - - end do ! icol - enddo ! k - - ! Total PM and PM2.5 (dry r>1.25um), surface values (ug/m3) - do icol=1,ncol - c_tots(icol) = c_tot(icol,pver) - c_tot125s(icol) = c_tot125(icol,pver) - c_pm25s(icol) = c_pm25(icol,pver) - enddo - - ! Effective, column integrated, radii for particles - ! smaller and greater than 0.5um, and for all radii - do icol=1,ncol - derlt05(icol)=3.0_r8*vaercols(icol)/(aaercols(icol)+eps) - dergt05(icol)=3.0_r8*vaercoll(icol)/(aaercoll(icol)+eps) - der(icol)=3.0_r8*(vaercols(icol)+vaercoll(icol)) /(aaercols(icol)+aaercoll(icol)+eps) - enddo - - do icol=1,ncol - dload_s4(icol)=0.0_r8 - dload_s4_a(icol)=0.0_r8 - dload_s4_1(icol)=0.0_r8 - dload_s4_5(icol)=0.0_r8 - dload_oc(icol)=0.0_r8 - dload_bc(icol)=0.0_r8 - dload_bc_ac(icol)=0.0_r8 - dload_bc_0(icol)=0.0_r8 - dload_bc_2(icol)=0.0_r8 - dload_bc_4(icol)=0.0_r8 - dload_bc_12(icol)=0.0_r8 - dload_bc_14(icol)=0.0_r8 - dload_oc_ac(icol)=0.0_r8 - dload_oc_4(icol)=0.0_r8 - dload_oc_14(icol)=0.0_r8 - do k=1,pver - ! Layer thickness, unit km - !- deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) - deltah=deltah_km(icol,k) - ! Modal and total mass concentrations for clean and dry aerosol, - ! i.e. not including coag./cond./Aq. BC,OC,SO4 or condensed water. - ! Units: ug/m3 for concentrations and mg/m2 (--> kg/m2 later) for mass loading. - do i=0,nmodes - ck(icol,k,i)=cknorm(icol,k,i)*Nnatk(icol,k,i) - dload3d(icol,k,i)=ck(icol,k,i)*deltah - dload(icol,i)=dload(icol,i)+dload3d(icol,k,i) - enddo - nnat_0(icol,k) =Nnatk(icol,k,0) - nnat_1(icol,k) =Nnatk(icol,k,1) - nnat_2(icol,k) =Nnatk(icol,k,2) - nnat_4(icol,k) =Nnatk(icol,k,4) - nnat_5(icol,k) =Nnatk(icol,k,5) - nnat_6(icol,k) =Nnatk(icol,k,6) - nnat_7(icol,k) =Nnatk(icol,k,7) - nnat_8(icol,k) =Nnatk(icol,k,8) - nnat_9(icol,k) =Nnatk(icol,k,9) - nnat_10(icol,k)=Nnatk(icol,k,10) - nnat_12(icol,k)=Nnatk(icol,k,12) - nnat_14(icol,k)=Nnatk(icol,k,14) - ! mineral and sea-salt mass concentrations - cmin(icol,k)=ck(icol,k,6)+ck(icol,k,7) - cseas(icol,k)=ck(icol,k,8)+ck(icol,k,9)+ck(icol,k,10) - ! Aerocom: Condensed water loading (mg_m2) - daerh2o(icol)=daerh2o(icol)+Cwater(icol,k)*deltah - ! just for checking purposes: - dload_s4(icol)=dload_s4(icol)+c_s4(icol,k)*deltah - dload_s4_a(icol)=dload_s4_a(icol)+c_s4_a(icol,k)*deltah - dload_s4_1(icol)=dload_s4_1(icol)+c_s4_1(icol,k)*deltah - dload_s4_5(icol)=dload_s4_5(icol)+c_s4_5(icol,k)*deltah - dload_oc(icol)=dload_oc(icol)+c_oc(icol,k)*deltah - dload_bc(icol)=dload_bc(icol)+c_bc(icol,k)*deltah - ! - dload_bc_ac(icol)=dload_bc_ac(icol)+c_bc_ac(icol,k)*deltah - dload_bc_0(icol)=dload_bc_0(icol)+c_bc_0(icol,k)*deltah - dload_bc_2(icol)=dload_bc_2(icol)+c_bc_2(icol,k)*deltah - dload_bc_4(icol)=dload_bc_4(icol)+c_bc_4(icol,k)*deltah - dload_bc_12(icol)=dload_bc_12(icol)+c_bc_12(icol,k)*deltah - dload_bc_14(icol)=dload_bc_14(icol)+c_bc_14(icol,k)*deltah - dload_oc_ac(icol)=dload_oc_ac(icol)+c_oc_ac(icol,k)*deltah - dload_oc_4(icol)=dload_oc_4(icol)+c_oc_4(icol,k)*deltah - dload_oc_14(icol)=dload_oc_14(icol)+c_oc_14(icol,k)*deltah - ! - end do ! k - dload_mi(icol)=dload(icol,6)+dload(icol,7) - dload_ss(icol)=dload(icol,8)+dload(icol,9)+dload(icol,10) - end do ! icol - - call outfld('PMTOT ',c_tots ,pcols,lchnk) - call outfld('PM25 ',c_pm25s ,pcols,lchnk) - call outfld('PM2P5 ',c_pm25 ,pcols,lchnk) - call outfld('MMRPM2P5',mmr_pm25,pcols,lchnk) - call outfld('MMRPM1 ',mmr_pm1 ,pcols,lchnk) - call outfld('MMRPM2P5_SRF',mmr_pm25(:pcols,pver),pcols,lchnk) - ! total (all r) dry concentrations (ug/m3) and loadings (mg/m2) - call outfld('DLOAD_MI',dload_mi,pcols,lchnk) - call outfld('DLOAD_SS',dload_ss,pcols,lchnk) - call outfld('DLOAD_S4',dload_s4,pcols,lchnk) - call outfld('DLOAD_OC',dload_oc,pcols,lchnk) - call outfld('DLOAD_BC',dload_bc,pcols,lchnk) - - call outfld('LOADBCAC',dload_bc_ac,pcols,lchnk) - call outfld('LOADBC0 ',dload_bc_0,pcols,lchnk) - call outfld('LOADBC2 ',dload_bc_2,pcols,lchnk) - call outfld('LOADBC4 ',dload_bc_4,pcols,lchnk) - call outfld('LOADBC12',dload_bc_12,pcols,lchnk) - call outfld('LOADBC14',dload_bc_14,pcols,lchnk) - call outfld('LOADOCAC',dload_oc_ac,pcols,lchnk) - call outfld('LOADOC4 ',dload_oc_4,pcols,lchnk) - call outfld('LOADOC14',dload_oc_14,pcols,lchnk) - ! condensed water mmr (kg/kg) - call outfld('MMR_AH2O',mmr_aerh2o,pcols,lchnk) - ! condensed water loading (mg/m2) - call outfld('DAERH2O ',daerh2o ,pcols,lchnk) - ! number concentrations (1/cm3) - call outfld('NNAT_0 ',nnat_0 ,pcols,lchnk) - call outfld('NNAT_1 ',nnat_1 ,pcols,lchnk) - call outfld('NNAT_2 ',nnat_2 ,pcols,lchnk) - !=0 call outfld('NNAT_3 ',nnat_3 ,pcols,lchnk) - call outfld('NNAT_4 ',nnat_4 ,pcols,lchnk) - call outfld('NNAT_5 ',nnat_5 ,pcols,lchnk) - call outfld('NNAT_6 ',nnat_6 ,pcols,lchnk) - call outfld('NNAT_7 ',nnat_7 ,pcols,lchnk) - call outfld('NNAT_8 ',nnat_8 ,pcols,lchnk) - call outfld('NNAT_9 ',nnat_9 ,pcols,lchnk) - call outfld('NNAT_10 ',nnat_10,pcols,lchnk) - !=0 call outfld('NNAT_11 ',nnat_11,pcols,lchnk) - call outfld('NNAT_12 ',nnat_12,pcols,lchnk) - !=0 call outfld('NNAT_13 ',nnat_13,pcols,lchnk) - call outfld('NNAT_14 ',nnat_14,pcols,lchnk) - !akc6 call outfld('AIRMASSL',airmassl,pcols,lchnk) - call outfld('AIRMASSL',airmassl,pcols,lchnk) - call outfld('AIRMASS ',airmass,pcols,lchnk) !akc6 - - !c_er3d - ! effective dry radii (um) in each layer - ! call outfld('ERLT053D',erlt053d,pcols,lchnk) - ! call outfld('ERGT053D',ergt053d,pcols,lchnk) - ! call outfld('ER3D ',er3d ,pcols,lchnk) - !c_er3d - ! column integrated effective dry radii (um) - call outfld('DERLT05 ',derlt05,pcols,lchnk) - call outfld('DERGT05 ',dergt05,pcols,lchnk) - call outfld('DER ',der ,pcols,lchnk) - ! - ! Extra AeroCom diagnostics requiring table look-ups with RH = constant - -#ifdef AEROCOM_INSITU - irfmax=6 -#else - irfmax=1 -#endif ! AEROCOM_INSITU - - ! Note: using xrhnull etc as proxy for constant RH input values (see oslo_aero_sw_tables.F90) - do irf=1,irfmax - do k=1,pver - do icol=1,ncol - xrhnull(icol,k)=xrhrf(irf) - irh1null(icol,k)=irhrf1(irf) - end do - enddo - call opticsAtConstRh(lchnk, ncol, pint, rhoda, Nnatk, xrhnull, irh1null, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbcarr, vaitbcarr, v_soana) - end do ! irf - - end subroutine aerocom - - subroutine opticsAtConstRh (lchnk, ncol, pint, rhoda, Nnatk, xrh, irh1, irf, & - xct, ict1, xfaq, ifaq1, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xfac, ifac1, xfbc, ifbc1, & - xfombg, ifombg1, vnbc, vaitbc, v_soana) - - ! Extra AeroCom diagnostics requiring table look-ups with constant/fixed RH, - ! i.e. for RH = (/"00","40","55","65","75","85" /) (see oslo_aero_sw_tables.F90) - - ! Input arguments - ! - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) - real(r8), intent(in) :: rhoda(pcols,pver) ! Density of dry air (kg/m^3) - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - integer, intent(in) :: irf - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! faqm for use in the interpolations - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbcbg(pcols,pver) - integer, intent(in) :: ifbcbg1(pcols,pver) - real(r8), intent(in) :: xfbcbgn(pcols,pver) - integer, intent(in) :: ifbcbgn1(pcols,pver) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! facm for use in the interpolations - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! fbcm for use in the interpolations - integer, intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfombg(pcols,pver) - integer, intent(in) :: ifombg1(pcols,pver) - real(r8), intent(in) :: vnbc(pcols,pver) - real(r8), intent(in) :: vaitbc(pcols,pver) - real(r8), intent(in) :: v_soana(pcols,pver) - ! - ! Local variables - ! - integer :: i, k, icol, mplus10, irh - integer :: iloop - real(r8) :: deltah - real(r8) :: dod550rh(pcols), abs550rh(pcols) - real(r8) :: ec550rh_aer(pcols,pver) - real(r8) :: abs550rh_aer(pcols,pver) - real(r8) :: bebglt1t(pcols,pver) - real(r8) :: bebclt1t(pcols,pver) - real(r8) :: beoclt1t(pcols,pver) - real(r8) :: bes4lt1t(pcols,pver) - real(r8) :: basu550tot(pcols,pver) - real(r8) :: babc550tot(pcols,pver) - real(r8) :: baoc550tot(pcols,pver) - real(r8) :: babc550xt(pcols,pver) - real(r8) :: baoc550xt(pcols,pver) - real(r8) :: ba550x(pcols,pver,nbmp1:nmodes) - real(r8) :: belt1x(pcols,pver,nbmp1:nmodes) - - ! Additionl AeroCom Phase III output: - real(r8) :: ec440rh_aer(pcols,pver) - real(r8) :: abs440rh_aer(pcols,pver) - real(r8) :: ec870rh_aer(pcols,pver) - real(r8) :: abs870rh_aer(pcols,pver) - real(r8) :: be550lt1_aer(pcols,pver,0:nbmodes) - real(r8) :: ec550rhlt1_aer(pcols,pver) - real(r8) :: abs550rh_bc(pcols,pver) - real(r8) :: abs550rh_oc(pcols,pver) - real(r8) :: abs550rh_su(pcols,pver) - real(r8) :: abs550rh_ss(pcols,pver) - real(r8) :: abs550rh_du(pcols,pver) - real(r8) :: ec550rhlt1_bc(pcols,pver) - real(r8) :: ec550rhlt1_oc(pcols,pver) - real(r8) :: ec550rhlt1_su(pcols,pver) - real(r8) :: ec550rhlt1_ss(pcols,pver) - real(r8) :: ec550rhlt1_du(pcols,pver) - real(r8) :: bedustlt1(pcols,pver) - real(r8) :: bedustgt1(pcols,pver) - real(r8) :: besslt1(pcols,pver) - real(r8) :: bessgt1(pcols,pver) - real(r8) :: bbclt1xt(pcols,pver) - real(r8) :: boclt1xt(pcols,pver) - real(r8) :: bocgt1xt(pcols,pver) - - character(len=10) :: modeString - character(len=20) :: varname - !-------------------------------------------------- - - belt1x(:,:,:) = 0._r8 - - do iloop=1,1 - - ! BC(ax) mode (hydrophobic, so no rhum needed here): - call extinction_coeffs%intaeropt0(lchnk, ncol, Nnatk) - - ! SO4(Ait), BC(Ait) and OC(Ait) modes: - mplus10=0 - call extinction_coeffs%intaeropt1(lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) - - mplus10=0 - call extinction_coeffs%intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1) - - ! BC&OC(Ait) (4), OC&BC(Ait) mode - mplus10=0 - call extinction_coeffs%intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1) - - ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call extinction_coeffs%intaeropt5to10(lchnk, ncol, xrh, irh1, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) - - ! then to the externally mixed SO4(n), BC(n) and OC(n) modes: - mplus10=1 - call extinction_coeffsn%intaeropt2to3(lchnk, ncol, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1) - - ! and finally the BC&OC(n) mode: - mplus10=1 - call extinction_coeffsn%intaeropt4(lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbgn, ifbcbgn1, xct, ict1, xfac, ifac1, xfaq, ifaq1) - - end do ! iloop - - - ! Initialization - do k=1,pver - do icol=1,ncol - ec550rh_aer(icol,k) = 0.0_r8 - abs550rh_aer(icol,k) = 0.0_r8 - ec550rhlt1_aer(icol,k) = 0.0_r8 - abs550rh_bc(icol,k) = 0.0_r8 - abs550rh_oc(icol,k) = 0.0_r8 - abs550rh_su(icol,k) = 0.0_r8 - abs550rh_ss(icol,k) = 0.0_r8 - abs550rh_du(icol,k) = 0.0_r8 - ec440rh_aer(icol,k) = 0.0_r8 - abs440rh_aer(icol,k) = 0.0_r8 - ec870rh_aer(icol,k) = 0.0_r8 - abs870rh_aer(icol,k) = 0.0_r8 - basu550tot(icol,k) = 0.0_r8 - babc550tot(icol,k) = 0.0_r8 - baoc550tot(icol,k) = 0.0_r8 - bebglt1t(icol,k) = 0.0_r8 - bebclt1t(icol,k) = 0.0_r8 - beoclt1t(icol,k) = 0.0_r8 - bes4lt1t(icol,k) = 0.0_r8 - bedustlt1(icol,k) = 0.0_r8 - besslt1(icol,k) = 0.0_r8 - end do - end do - do icol=1,ncol - dod550rh(icol) = 0.0_r8 - abs550rh(icol) = 0.0_r8 - end do - - ! Calculation of extinction at given RH and absorption for all r and for r<0.5um - do k=1,pver - do icol=1,ncol - - do i=0,10 - ec550rh_aer(icol,k) = ec550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext550(icol,k,i) - abs550rh_aer(icol,k) = abs550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs550(icol,k,i) - ec440rh_aer(icol,k) = ec440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext440(icol,k,i) - abs440rh_aer(icol,k) = abs440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs440(icol,k,i) - ec870rh_aer(icol,k) = ec870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bext870(icol,k,i) - abs870rh_aer(icol,k) = abs870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babs870(icol,k,i) - basu550tot(icol,k) = basu550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%basu550(icol,k,i) - babc550tot(icol,k) = babc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%babc550(icol,k,i) - baoc550tot(icol,k) = baoc550tot(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%baoc550(icol,k,i) - bes4lt1t(icol,k) = bes4lt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%besu550lt1(icol,k,i) - bebclt1t(icol,k) = bebclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebc550lt1(icol,k,i) - beoclt1t(icol,k) = beoclt1t(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%beoc550lt1(icol,k,i) - enddo - do i=11,14 - ec550rh_aer(icol,k) = ec550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext550(icol,k,i-10) - abs550rh_aer(icol,k) = abs550rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs550(icol,k,i-10) - ec440rh_aer(icol,k) = ec440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext440(icol,k,i-10) - abs440rh_aer(icol,k) = abs440rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs440(icol,k,i-10) - ec870rh_aer(icol,k) = ec870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%bext870(icol,k,i-10) - abs870rh_aer(icol,k) = abs870rh_aer(icol,k) + Nnatk(icol,k,i)*extinction_coeffsn%babs870(icol,k,i-10) - ba550x(icol,k,i) = extinction_coeffsn%babs550(icol,k,i-10) - belt1x(icol,k,i) = extinction_coeffs%bebg550lt1(icol,k,i-10) !??? - enddo - do i=6,7 - bedustlt1(icol,k) = bedustlt1(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebg550lt1(icol,k,i) - enddo - do i=8,10 - besslt1(icol,k) = besslt1(icol,k) + Nnatk(icol,k,i)*extinction_coeffs%bebg550lt1(icol,k,i) - enddo - ec550rhlt1_du(icol,k) = bedustlt1(icol,k) - ec550rhlt1_ss(icol,k) = besslt1(icol,k) - - !soa: *(1-v_soan) for the sulfate volume fraction of mode 11 - bbclt1xt(icol,k) = Nnatk(icol,k,12)*belt1x(icol,k,12) & - + Nnatk(icol,k,14)*belt1x(icol,k,14)*vnbc(icol,k) - !soa + v_soan part of mode 11 for the OC volume fraction of that mode - boclt1xt(icol,k) = Nnatk(icol,k,13)*belt1x(icol,k,13) & - + Nnatk(icol,k,14)*belt1x(icol,k,14)*(1.0_r8-vnbc(icol,k)) - - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - ec550rhlt1_su(icol,k) = bes4lt1t(icol,k) & ! condensate - + Nnatk(icol,k,1)*extinction_coeffs%bebg550lt1(icol,k,1)*(1.0_r8-v_soana(icol,k))& ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%bebg550lt1(icol,k,5) ! background, SO4(Ait75) mode (5) - ec550rhlt1_bc(icol,k) = bebclt1t(icol,k)+bbclt1xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%bebg550lt1(icol,k,2) & ! background, BC(Ait) mode (2) - + Nnatk(icol,k,4)*extinction_coeffs%bebg550lt1(icol,k,4)*vaitbc(icol,k) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%bebg550lt1(icol,k,0) ! background, BC(ax) mode (0) - - !soa + v_soan part of mode 11 for the OC volume fraction of that mode - ec550rhlt1_oc(icol,k) = beoclt1t(icol,k)+boclt1xt(icol,k) & ! coagulated + n-mode OC (13) - + Nnatk(icol,k,3)*extinction_coeffs%bebg550lt1(icol,k,3) & ! background, OC(Ait) mode (3) - + Nnatk(icol,k,4)*extinction_coeffs%bebg550lt1(icol,k,4)*(1.0_r8-vaitbc(icol,k))& ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,1)*extinction_coeffs%bebg550lt1(icol,k,1)*v_soana(icol,k) - - ec550rhlt1_aer(icol,k) = ec550rhlt1_su(icol,k)+ec550rhlt1_bc(icol,k) & - + ec550rhlt1_oc(icol,k) + ec550rhlt1_ss(icol,k)+ec550rhlt1_du(icol,k) - ec550rhlt1_aer(icol,k) = 1.e-3_r8*ec550rhlt1_aer(icol,k) - - abs550rh_du(icol,k) = Nnatk(icol,k,6)*extinction_coeffs%babg550(icol,k,6) & - + Nnatk(icol,k,7)*extinction_coeffs%babg550(icol,k,7) - abs550rh_ss(icol,k) = Nnatk(icol,k,8)*extinction_coeffs%babg550(icol,k,8) & - + Nnatk(icol,k,9)*extinction_coeffs%babg550(icol,k,9) & - + Nnatk(icol,k,10)*extinction_coeffs%babg550(icol,k,10) - - !soa: *(1-v_soana) for the sulfate volume fraction of mode 1 - abs550rh_su(icol,k) = basu550tot(icol,k) & ! condensate:w - + (1.0_r8-v_soana(icol,k))*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! background, SO4(Ait) mode (1) - + Nnatk(icol,k,5)*extinction_coeffs%babg550(icol,k,5) ! background, SO4(Ait75) mode (5) - - !soa: *(1-v_soan) for the sulfate volume fraction - babc550xt(icol,k) = Nnatk(icol,k,12)*ba550x(icol,k,12) & - + Nnatk(icol,k,14)*ba550x(icol,k,14)*vnbc(icol,k) - - baoc550xt(icol,k) = Nnatk(icol,k,13)*ba550x(icol,k,13) & - + Nnatk(icol,k,14)*ba550x(icol,k,14)*(1.0_r8-vnbc(icol,k)) - - abs550rh_bc(icol,k) = babc550tot(icol,k)+babc550xt(icol,k) & ! coagulated + n-mode BC (12) - + Nnatk(icol,k,2)*extinction_coeffs%babg550(icol,k,2) & ! background, BC(Ait) mode (2) - + vaitbc(icol,k)*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) & ! background in OC&BC(Ait) mode (4) - + Nnatk(icol,k,0)*extinction_coeffs%babg550(icol,k,0) ! background, BC(ax) mode (0) - - abs550rh_oc(icol,k) = baoc550tot(icol,k)+baoc550xt(icol,k) & ! coagulated + n-mode OC (13) - + v_soana(icol,k)*Nnatk(icol,k,1)*extinction_coeffs%babg550(icol,k,1) & ! SOA fraction of mode 1 - + Nnatk(icol,k,3)*extinction_coeffs%babg550(icol,k,3) & ! background, OC(Ait) mode (3) - + (1.0_r8-vaitbc(icol,k))*Nnatk(icol,k,4)*extinction_coeffs%babg550(icol,k,4) ! background in OC&BC(Ait) mode (4) - - deltah=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) - dod550rh(icol) = dod550rh(icol)+ec550rh_aer(icol,k)*deltah - abs550rh(icol) = abs550rh(icol)+abs550rh_aer(icol,k)*deltah - - ec550rh_aer(icol,k) = 1.e-3_r8*ec550rh_aer(icol,k) - abs550rh_aer(icol,k) = 1.e-3_r8*abs550rh_aer(icol,k) - ec440rh_aer(icol,k) = 1.e-3_r8*ec440rh_aer(icol,k) - abs440rh_aer(icol,k) = 1.e-3_r8*abs440rh_aer(icol,k) - ec870rh_aer(icol,k) = 1.e-3_r8*ec870rh_aer(icol,k) - abs870rh_aer(icol,k) = 1.e-3_r8*abs870rh_aer(icol,k) - - abs550rh_bc(icol,k) = 1.e-3_r8*abs550rh_bc(icol,k) - abs550rh_oc(icol,k) = 1.e-3_r8*abs550rh_oc(icol,k) - abs550rh_su(icol,k) = 1.e-3_r8*abs550rh_su(icol,k) - abs550rh_ss(icol,k) = 1.e-3_r8*abs550rh_ss(icol,k) - abs550rh_du(icol,k) = 1.e-3_r8*abs550rh_du(icol,k) - - enddo - enddo - - if(irf.eq.1) then - - call outfld('ECDRYAER',ec550rh_aer,pcols,lchnk) - call outfld('ABSDRYAE',abs550rh_aer,pcols,lchnk) - call outfld('OD550DRY',dod550rh,pcols,lchnk) ! 2D variable - call outfld('AB550DRY',abs550rh,pcols,lchnk) ! 2D variable - call outfld('ECDRY440',ec440rh_aer,pcols,lchnk) - call outfld('ABSDR440',abs440rh_aer,pcols,lchnk) - call outfld('ECDRY870',ec870rh_aer,pcols,lchnk) - call outfld('ABSDR870',abs870rh_aer,pcols,lchnk) - call outfld('ECDRYLT1',ec550rhlt1_aer,pcols,lchnk) - ! Since we do not have enough look-up table info to take abs550rhlt1_aer, - ! instead take out abs550rh for each constituent: - call outfld('ABSDRYBC',abs550rh_bc,pcols,lchnk) - call outfld('ABSDRYOC',abs550rh_oc,pcols,lchnk) - call outfld('ABSDRYSU',abs550rh_su,pcols,lchnk) - call outfld('ABSDRYSS',abs550rh_ss,pcols,lchnk) - call outfld('ABSDRYDU',abs550rh_du,pcols,lchnk) - - elseif(irf.ge.2) then ! only happens for AEROCOM_INSITU - - irh=RF(irf) - - modeString=" " - write(modeString,"(I2)"),irh - if(RF(irf).eq.0) modeString="00" - varName = "EC55RH"//trim(modeString) - call outfld(varName,ec550rh_aer(:,:),pcols,lchnk) - varName = "AB55RH"//trim(modeString) - call outfld(varName,abs550rh_aer(:,:),pcols,lchnk) - - end if ! irf - - end subroutine opticsAtConstRh - - subroutine intfrh (lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relh, frh) - - ! Written by Alf Kirkevaag in November 2011, based on interpol1to3 in optinterpol.F90 - ! called by NorESM/physpkg - - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate - real(r8), intent(in) :: v3insol(pcols,pver,nmodes) ! Modal mass fraction of BC and dust - real(r8), intent(in) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) - real(r8), intent(in) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt - real(r8), intent(in) :: relh(pcols,pver) ! Ambient relatve humidity (fraction) - ! - ! Output arguments - real(r8), intent(out) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor - ! - ! Local variables - integer :: i, ierr, irelh, kcomp, k, icol - integer :: irh1(pcols,pver), irh2(pcols,pver) - real(r8) :: a, b, e, fso4, finsol, foc, fss - real(r8) :: xrh(pcols,pver) - integer :: t_irh1, t_irh2 - real(r8) :: t_xrh, t_rh1, t_rh2 - parameter (e=2.718281828) - - ! Relative humidity intries from oslo_aero_sw_tables - ! rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, & - ! 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) - ! Humidity growth factors which are consistent with the aerosol optics look-up tables: - real(r8), dimension(10) :: fh_SO4 = & - (/ 1.00_r8, 1.34_r8, 1.40_r8, 1.53_r8, 1.64_r8, & - 1.71_r8, 1.81_r8, 1.98_r8, 2.39_r8, 5.04_r8 /) - real(r8), dimension(10) :: fh_insol = & - (/ 1.00_r8, 1.01_r8, 1.01_r8, 1.02_r8, 1.02_r8, & - 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8, 1.02_r8 /) - real(r8), dimension(10) :: fh_OC = & - (/ 1.00_r8, 1.02_r8, 1.05_r8, 1.14_r8, 1.19_r8, & - 1.22_r8, 1.27_r8, 1.36_r8, 1.59_r8, 3.18_r8 /) - real(r8), dimension(10) :: fh_SS = & - (/ 1.00_r8, 1.01_r8, 1.02_r8, 1.56_r8, 1.87_r8, & - 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 6.08_r8 /) - ! ----------------------------------------- - - ! write(*,*) 'Before xrh-loop' - do k=1,pver - do icol=1,ncol - !test xrh(icol,k) = 0.8 - xrh(icol,k) = min(max(relh(icol,k),rh(1)),rh(10)) - end do - end do - - ! write(*,*) 'Before rh-loop' - do irelh=1,9 - do k=1,pver - do icol=1,ncol - if(xrh(icol,k) >= rh(irelh).and. & - xrh(icol,k)<=rh(irelh+1)) then - irh1(icol,k)=irelh - irh2(icol,k)=irelh+1 - endif - end do - end do - end do - - ! Loop over all relevant modes (kcomp=1,2,4-11,13,14) - ! (mode 3 is no longer included, and 12 is insoluble) - - do kcomp=1,14 - - do icol=1,ncol - do k=1,pver - frh(icol,k,kcomp)=0.0_r8 - end do - end do - - if(kcomp.ne.3.and.kcomp.ne.12) then - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = irh2(icol,k) - - ! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - - t_xrh = xrh(icol,k) - - if(t_xrh <= 0.37) then ! linear averaging w.r.t. small RH: - fso4 = ((t_rh2-t_xrh)*fh_SO4(t_irh1)+(t_xrh-t_rh1)*fh_SO4(t_irh2)) /(t_rh2-t_rh1) - finsol= ((t_rh2-t_xrh)*fh_insol(t_irh1)+(t_xrh-t_rh1)*fh_insol(t_irh2)) /(t_rh2-t_rh1) - foc = ((t_rh2-t_xrh)*fh_OC(t_irh1)+(t_xrh-t_rh1)*fh_OC(t_irh2)) /(t_rh2-t_rh1) - fss = ((t_rh2-t_xrh)*fh_SS(t_irh1)+(t_xrh-t_rh1)*fh_SS(t_irh2)) /(t_rh2-t_rh1) - else ! exponential averaging w.r.t. large RH: - a = (log(fh_SO4(t_irh2))-log(fh_SO4(t_irh1)))/(t_rh2-t_rh1) - b = (t_rh2*log(fh_SO4(t_irh1))-t_rh1*log(fh_SO4(t_irh2)))/(t_rh2-t_rh1) - fso4 = e**(a*t_xrh+b) - a = (log(fh_insol(t_irh2))-log(fh_insol(t_irh1)))/(t_rh2-t_rh1) - b = (t_rh2*log(fh_insol(t_irh1))-t_rh1*log(fh_insol(t_irh2)))/(t_rh2-t_rh1) - finsol = e**(a*t_xrh+b) - a = (log(fh_OC(t_irh2))-log(fh_OC(t_irh1)))/(t_rh2-t_rh1) - b = (t_rh2*log(fh_OC(t_irh1))-t_rh1*log(fh_OC(t_irh2)))/(t_rh2-t_rh1) - foc = e**(a*t_xrh+b) - a = (log(fh_SS(t_irh2))-log(fh_SS(t_irh1)))/(t_rh2-t_rh1) - b = (t_rh2*log(fh_SS(t_irh1))-t_rh1*log(fh_SS(t_irh2)))/(t_rh2-t_rh1) - fss = e**(a*t_xrh+b) - endif - - ! linear interpolation w.r.t. mass fractions of each internally mixed component - ! (this assumption is only used here, while the full Koehler equation are solved - ! for the look-up tables for log-normal size distributions and aerosol optics): - - frh(icol,k,kcomp) = v3so4(icol,k,kcomp)*fso4 + v3insol(icol,k,kcomp)*finsol & - + v3oc(icol,k,kcomp) *foc + v3ss(icol,k,kcomp)*fss - - ! write(*,*) 'frh =', frh(icol,k,kcomp) - end do ! icol - end do ! k - endif ! kcomp.ne.3.and.kcomp.ne.12 - end do ! kcomp - - end subroutine intfrh - -#endif - -end module oslo_aero_aerocom diff --git a/src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 deleted file mode 100644 index 0b8b24075c..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_aerocom_dry.F90 +++ /dev/null @@ -1,1138 +0,0 @@ -module oslo_aero_aerocom_dry - -#ifdef AEROCOM - - use shr_kind_mod , only: r8 => shr_kind_r8 - use ppgrid , only: pcols, pver - use cam_logfile , only: iulog - ! - use oslo_aero_params , only: nmodes, nbmodes - use oslo_aero_sw_tables , only: cate, cat, fac, faq, fbc, fombg, fbcbg, nbmp1 - use oslo_aero_linear_interp , only: lininterpol3dim, lininterpol4dim, lininterpol5dim - use oslo_aero_control , only: oslo_aero_getopts, dir_string_length - - implicit none - private - - ! Set by init_dryp Mode0 - real(r8) :: a0cintbg, a0cintbg05, a0cintbg125 - real(r8) :: a0aaeros, a0aaerol, a0vaeros, a0vaerol - - ! Used by init_dryp Mode1 - real(r8) :: a1var(19,6,16,6) - - ! Used by init_dryp Mode2to3 - real(r8) :: a2to3var(19,16,6,2:3) - - ! Used by init_dryp Mode4 - real(r8) :: a4var(19,6,16,6,6) - - ! Used by init_dryp Mode5 - real(r8) :: a5to10var(19,6,6,6,6,5:10) - - type, public :: aerodry_prop_type - ! modal mass concentrations (cint), area (aaero) and volume (vaero) - ! (for AeroCom determination of particle effective radii) of each constituent. - ! cint*05 and cint*125 are for r<0.5um and r>1.25um, respectively. - ! aaeros and vaeros are integrated over r<0.5um, and aaerol and vaerol over r>0.5um. - - real(r8) :: cintbg(pcols,pver,0:nbmodes) - real(r8) :: cintbg05(pcols,pver,0:nbmodes) - real(r8) :: cintbg125(pcols,pver,0:nbmodes) - real(r8) :: cintbc(pcols,pver,0:nbmodes) - real(r8) :: cintbc05(pcols,pver,0:nbmodes) - real(r8) :: cintbc125(pcols,pver,0:nbmodes) - real(r8) :: cintoc(pcols,pver,0:nbmodes) - real(r8) :: cintoc05(pcols,pver,0:nbmodes) - real(r8) :: cintoc125(pcols,pver,0:nbmodes) - real(r8) :: cintsc(pcols,pver,0:nbmodes) - real(r8) :: cintsc05(pcols,pver,0:nbmodes) - real(r8) :: cintsc125(pcols,pver,0:nbmodes) - real(r8) :: cintsa(pcols,pver,0:nbmodes) - real(r8) :: cintsa05(pcols,pver,0:nbmodes) - real(r8) :: cintsa125(pcols,pver,0:nbmodes) - real(r8) :: aaeros(pcols,pver,0:nbmodes) - real(r8) :: aaerol(pcols,pver,0:nbmodes) - real(r8) :: vaeros(pcols,pver,0:nbmodes) - real(r8) :: vaerol(pcols,pver,0:nbmodes) - - real(r8) :: aaerosn(pcols,pver,nbmp1:nmodes) - real(r8) :: aaeroln(pcols,pver,nbmp1:nmodes) - real(r8) :: vaerosn(pcols,pver,nbmp1:nmodes) - real(r8) :: vaeroln(pcols,pver,nbmp1:nmodes) - real(r8) :: cknorm(pcols,pver,0:nmodes) - real(r8) :: cknlt05(pcols,pver,0:nmodes) - real(r8) :: ckngt125(pcols,pver,0:nmodes) - - contains - procedure :: intdrypar0 - procedure :: intdrypar1 - procedure :: intdrypar2to3 - procedure :: intdrypar4 - procedure :: intdrypar5to10 - procedure :: zero - procedure :: update - - end type aerodry_prop_type - - type(aerodry_prop_type), public :: aerodry_prop - - public :: initdryp - -! ========================================================== -contains -! ========================================================== - - subroutine initdryp() - - !Purpose: To read in the AeroCom look-up tables for calculation of dry - ! aerosol size and mass distribution properties. The grid for discrete - ! input-values in the look-up tables is defined in opptab. - - ! Tabulating the 'aerodryk'-files to save computing time. Routine - ! originally made by Alf Kirkevaag, and modified for new aerosol - ! schemes in January 2006. - ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, - ! May 2013, and extended for new SOA treatment October 2015. - ! Modified for optimized added masses and mass fractions for - ! concentrations from condensation, coagulation or cloud-processing - ! - Alf Kirkevaag, May 2016. - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - - ! local variables - integer :: iv, kcomp, ifombg, ifbcbg, ictot, ifac, ifbc, ifaq - integer :: ic, ifil, lin - real(r8) :: frombg, frbcbg, catot, frac, fabc, fraq - real(r8) :: cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125 - real(r8) :: cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125 - real(r8) :: cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - real(r8) :: eps7 = 1.e-7_r8 - character(len=dir_string_length) :: aerotab_table_dir - - call oslo_aero_getopts(aerotab_table_dir_out = aerotab_table_dir) - - open(20,file=trim(aerotab_table_dir)//'/aerodryk0.out' ,form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/aerodryk1.out' ,form='formatted',status='old') - open(11,file=trim(aerotab_table_dir)//'/aerodryk2.out' ,form='formatted',status='old') - open(12,file=trim(aerotab_table_dir)//'/aerodryk3.out' ,form='formatted',status='old') - open(13,file=trim(aerotab_table_dir)//'/aerodryk4.out' ,form='formatted',status='old') - open(14,file=trim(aerotab_table_dir)//'/aerodryk5.out' ,form='formatted',status='old') - open(15,file=trim(aerotab_table_dir)//'/aerodryk6.out' ,form='formatted',status='old') - open(16,file=trim(aerotab_table_dir)//'/aerodryk7.out' ,form='formatted',status='old') - open(17,file=trim(aerotab_table_dir)//'/aerodryk8.out' ,form='formatted',status='old') - open(18,file=trim(aerotab_table_dir)//'/aerodryk9.out' ,form='formatted',status='old') - open(19,file=trim(aerotab_table_dir)//'/aerodryk10.out' ,form='formatted',status='old') - - ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 11,21 - call checkTableHeader (ifil) - enddo - ! - !------------------------------------------- - ! Mode 0, BC(ax) - !------------------------------------------- - ! - read(20,996) kcomp, cintbg, cintbg05, cintbg125, aaeros, aaerol, vaeros, vaerol - - ! no ictot-, ifac-, ifbc- or ifaq-dependency for this mode, - ! since BC(ax) is purely externally mixed - - a0cintbg=cintbg - a0cintbg05=cintbg05 - a0cintbg125=cintbg125 - - a0aaeros=aaeros - a0aaerol=aaerol - a0vaeros=vaeros - a0vaerol=vaerol - write(iulog,*)'mode 0 ok' - - !------------------------------------------- - ! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) - !------------------------------------------- - - do lin = 1,576 ! 6x16x6 - read(21,997) kcomp, frombg, catot, frac, & - cintbg, cintbg05, cintbg125, cintbc, cintbc05, cintbc125, & - cintoc, cintoc05, cintoc125, cintsc, cintsc05, cintsc125, & - cintsa, cintsa05, cintsa125, aaeros, aaerol, vaeros, vaerol - - do ic=1,6 - if(abs(frombg-fombg(ic)) 0.0_r8) then - this%cintbg(icol,k,kcomp) = a0cintbg - this%cintbg05(icol,k,kcomp) = a0cintbg05 - this%cintbg125(icol,k,kcomp) = a0cintbg125 - this%cintbc(icol,k,kcomp) = eps - this%cintbc05(icol,k,kcomp) = eps - this%cintbc125(icol,k,kcomp) = eps - this%cintoc(icol,k,kcomp) = eps - this%cintoc05(icol,k,kcomp) = eps - this%cintoc125(icol,k,kcomp) = eps - this%cintsc(icol,k,kcomp) = eps - this%cintsc05(icol,k,kcomp) = eps - this%cintsc125(icol,k,kcomp) = eps - this%cintsa(icol,k,kcomp) = eps - this%cintsa05(icol,k,kcomp) = eps - this%cintsa125(icol,k,kcomp) = eps - this%aaeros(icol,k,kcomp) = a0aaeros - this%aaerol(icol,k,kcomp) = a0aaerol - this%vaeros(icol,k,kcomp) = a0vaeros - this%vaerol(icol,k,kcomp) = a0vaerol - endif - this%cknorm(icol,k,kcomp) = a0cintbg - this%cknlt05(icol,k,kcomp) = a0cintbg05 - this%ckngt125(icol,k,kcomp)= a0cintbg125 - end do ! icol - end do ! k - - end subroutine intdrypar0 - - ! ========================================================== - subroutine intdrypar1 (this, lchnk, ncol, Nnatk, xfombg, ifombg1, xct, ict1, xfac, ifac1) - - ! Output arguments: Modal mass concentrations (cint), area (aaero) and volume (vaero) - ! (for AeroCom determination of particle effective radii) of each constituent. cint*05 - ! and cint*125 are for r<0.5um and r>1.25um, respectively. aaeros and vaeros are - ! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. - - ! Arguments - class(aerodry_prop_type) :: this - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode (1) - integer, intent(in) :: ifombg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - - ! Local variables - real(r8) :: a, b, e, eps - integer :: iv, kcomp, k, icol - integer :: t_ifo1, t_ifo2 - integer :: t_ict1, t_ict2, t_ifc1, t_ifc2 - real(r8) :: t_xct, t_cat1, t_cat2 - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_fombg1, t_fombg2, t_xfombg, t_xfombgn - real(r8) :: d2mx(3), dxm1(3), invd(3) - real(r8) :: opt3d(2,2,2) - real(r8) :: opt1, opt2, opt - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - !--------------------- - ! Mode 1, SO4(Ait): - !--------------------- - kcomp=1 - call this%zero(kcomp,ncol) - - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kcomp)>0.0_r8) then - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - t_ifo1 = ifombg1(icol,k) - t_ifo2 = t_ifo1+1 - t_fombg1 = fombg(t_ifo1) - t_fombg2 = fombg(t_ifo2) - t_xfombg = xfombg(icol,k) - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - - ! partial lengths along each dimension (1-3) for interpolation - d2mx(1) = (t_fombg2-t_xfombg) - dxm1(1) = (t_xfombg-t_fombg1) - invd(1) = 1.0_r8/(t_fombg2-t_fombg1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - - do iv=1,19 ! variable number - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=a1var(iv,t_ifo1,t_ict1,t_ifc1) - opt3d(1,1,2)=a1var(iv,t_ifo1,t_ict1,t_ifc2) - opt3d(1,2,1)=a1var(iv,t_ifo1,t_ict2,t_ifc1) - opt3d(1,2,2)=a1var(iv,t_ifo1,t_ict2,t_ifc2) - opt3d(2,1,1)=a1var(iv,t_ifo2,t_ict1,t_ifc1) - opt3d(2,1,2)=a1var(iv,t_ifo2,t_ict1,t_ifc2) - opt3d(2,2,1)=a1var(iv,t_ifo2,t_ict2,t_ifc1) - opt3d(2,2,2)=a1var(iv,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac and cat dimensions - call lininterpol3dim (d2mx, dxm1, invd, opt3d, opt1, opt2) - - ! finally, interpolation in the fombg dimension - opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - ! update the properties - call this%update(kcomp, k, icol, iv, opt) - - end do ! iv=1,19 - endif - end do ! icol - end do ! k - - - ! Dry parameters for externally mixed mode 11, SO4(n): - kcomp=11 - do k=1,pver - do icol=1,ncol - ! Neither total background concentrations (OM + sulfate) - ! nor areas & volumes depend on fombg: - this%cknorm(icol,k,kcomp) = a1var(1,1,1,1) - this%cknlt05(icol,k,kcomp) = a1var(2,1,1,1) - this%ckngt125(icol,k,kcomp) = a1var(3,1,1,1) - this%aaerosn(icol,k,kcomp) = a1var(16,1,1,1) - this%aaeroln(icol,k,kcomp) = a1var(17,1,1,1) - this%vaerosn(icol,k,kcomp) = a1var(18,1,1,1) - this%vaeroln(icol,k,kcomp) = a1var(19,1,1,1) - end do ! icol - end do ! k - - end subroutine intdrypar1 - - ! ========================================================== - subroutine intdrypar2to3 (this, lchnk, ncol, Nnatk, xct, ict1, xfac, ifac1) - - ! Modal mass concentrations (cint), area (aaero) - ! and volume (vaero) (for AeroCom determination of particle - ! effective radii) of each constituent. cint*05 and cint*125 are - ! for r<0.5um and r>1.25um, respectively. aaeros and vaeros are - ! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. - - ! arguments - class(aerodry_prop_type) :: this - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - - ! local variables - real(r8) :: a, b, e, eps - integer :: iv, kcomp, k, icol - integer :: t_ict1, t_ict2 - real(r8) :: t_xct, t_cat1, t_cat2 - real(r8) :: t_fac1, t_fac2, t_xfac - integer :: t_ifc1, t_ifc2 - real(r8) :: d2mx(2), dxm1(2), invd(2) - real(r8) :: opt2d(2,2) - real(r8) :: opt1, opt2, opt - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! Modes 1-3, SO4(Ait), BC(Ait) and OC(Ait): - - do kcomp=2,3 - call this%zero(kcomp, ncol) - end do ! kcomp - - kcomp = 1 - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kcomp)>0.0_r8) then - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_xct = xct(icol,k,kcomp) - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_xfac = xfac(icol,k,kcomp) - - ! partial lengths along each dimension (1-2) for interpolation - d2mx(1) = (t_cat2-t_xct) - dxm1(1) = (t_xct-t_cat1) - invd(1) = 1.0_r8/(t_cat2-t_cat1) - d2mx(2) = (t_fac2-t_xfac) - dxm1(2) = (t_xfac-t_fac1) - invd(2) = 1.0_r8/(t_fac2-t_fac1) - - do iv=1,19 ! variable number - - ! end points as basis for multidimentional linear interpolation - opt2d(1,1) = a2to3var(iv,t_ict1,t_ifc1,kcomp) - opt2d(1,2) = a2to3var(iv,t_ict1,t_ifc2,kcomp) - opt2d(2,1) = a2to3var(iv,t_ict2,t_ifc1,kcomp) - opt2d(2,2) = a2to3var(iv,t_ict2,t_ifc2,kcomp) - - ! interpolation in the fac dimension - opt1 = (d2mx(2)*opt2d(1,1)+dxm1(2)*opt2d(1,2))*invd(2) - opt2 = (d2mx(2)*opt2d(2,1)+dxm1(2)*opt2d(2,2))*invd(2) - - ! finally, interpolation in the cat dimension - opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - call this%update(kcomp, k, icol, iv, opt) - end do - end if - end do - end do - - ! Dry parameters for externally mixed modes modes 12-13, - ! BC(n) and OC(n): - - do kcomp=12,13 ! using dummy initialization for kcomp=3 - do k=1,pver - do icol=1,ncol - this%cknorm(icol,k,kcomp) = a2to3var(1,1,1,kcomp-10) - this%cknlt05(icol,k,kcomp) = a2to3var(2,1,1,kcomp-10) - this%ckngt125(icol,k,kcomp)= a2to3var(3,1,1,kcomp-10) - this%aaerosn(icol,k,kcomp) = a2to3var(16,1,1,kcomp-10) - this%aaeroln(icol,k,kcomp) = a2to3var(17,1,1,kcomp-10) - this%vaerosn(icol,k,kcomp) = a2to3var(18,1,1,kcomp-10) - this%vaeroln(icol,k,kcomp) = a2to3var(19,1,1,kcomp-10) - end do ! icol - end do ! k - end do ! kcomp - - end subroutine intdrypar2to3 - - ! ========================================================== - subroutine intdrypar4 (this, lchnk, ncol, Nnatk, xfbcbg, ifbcbg1, & - xfbcbgn, ifbcbgn1, xct, ict1, xfac, ifac1, xfaq, ifaq1) - - ! Output arguments: Modal mass concentrations (cint), area (aaero) - ! and volume (vaero) (for AeroCom determination of particle - ! effective radii) of each constituent. cint*05 and cint*125 are - ! for r<0.5um and r>1.25um, respectively. aaeros and vaeros are - ! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. - - ! arguments - class(aerodry_prop_type) :: this - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer , intent(in) :: ifaq1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode (4) - integer , intent(in) :: ifbcbg1(pcols,pver) - real(r8) , intent(in) :: xfbcbgn(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode (14) - integer , intent(in) :: ifbcbgn1(pcols,pver) - - ! local variables - real(r8) :: a, b, e, eps - integer :: iv, kcomp, k, icol - integer :: t_ifb1, t_ifb2 - integer :: t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 - real(r8) :: t_fbcbg1, t_fbcbg2 - real(r8) :: t_faq1, t_faq2, t_xfaq - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_xct, t_cat1, t_cat2 - real(r8) :: t_xfbcbg - real(r8) :: d2mx(4), dxm1(4), invd(4) - real(r8) :: opt4d(2,2,2,2) - real(r8) :: opt1, opt2, opt - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! Mode 4, BC&OC(Ait): - kcomp=4 - call this%zero(kcomp, ncol) - - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kcomp)>0.0_r8) then - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - t_ifb1 = ifbcbg1(icol,k) - t_ifb2 = t_ifb1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - t_xfbcbg = xfbcbg(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_fbcbg2-t_xfbcbg) - dxm1(1) = (t_xfbcbg-t_fbcbg1) - invd(1) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - d2mx(4) = (t_faq2-t_xfaq) - dxm1(4) = (t_xfaq-t_faq1) - invd(4) = 1.0_r8/(t_faq2-t_faq1) - - do iv=1,19 ! variable number - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=a4var(iv,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt4d(1,1,1,2)=a4var(iv,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt4d(1,1,2,1)=a4var(iv,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt4d(1,1,2,2)=a4var(iv,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt4d(1,2,1,1)=a4var(iv,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt4d(1,2,1,2)=a4var(iv,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt4d(1,2,2,1)=a4var(iv,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt4d(1,2,2,2)=a4var(iv,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt4d(2,1,1,1)=a4var(iv,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt4d(2,1,1,2)=a4var(iv,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt4d(2,1,2,1)=a4var(iv,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt4d(2,1,2,2)=a4var(iv,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt4d(2,2,1,1)=a4var(iv,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt4d(2,2,1,2)=a4var(iv,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt4d(2,2,2,1)=a4var(iv,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt4d(2,2,2,2)=a4var(iv,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac and cat dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) - - ! finally, interpolation in the fbcbg dimension - opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - call this%update(kcomp, k, icol, iv, opt) - end do - endif - end do ! icol - end do ! k - - kcomp=14 - do k=1,pver - do icol=1,ncol - - t_ifb1 = ifbcbgn1(icol,k) - t_ifb2 = t_ifb1+1 - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_xfbcbg = xfbcbgn(icol,k) - - d2mx(1) = (t_fbcbg2-t_xfbcbg) - dxm1(1) = (t_xfbcbg-t_fbcbg1) - invd(1) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - - ! Only interpolation in the fbcbg dimension for mode 14 - opt1 = a4var(1,1,1,1,1) - opt2 = a4var(1,2,1,1,1) - this%cknorm(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - opt1 = a4var(2,1,1,1,1) - opt2 = a4var(2,2,1,1,1) - this%cknlt05(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - opt1 = a4var(3,1,1,1,1) - opt2 = a4var(3,2,1,1,1) - this%ckngt125(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - ! (The remaining variables are actually independent of fbcbg, - ! but we follow the same procedure anyway:) - - opt1 = a4var(16,1,1,1,1) - opt2 = a4var(16,2,1,1,1) - this%aaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - opt1 = a4var(17,1,1,1,1) - opt2 = a4var(17,2,1,1,1) - this%aaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - opt1 = a4var(18,1,1,1,1) - opt2 = a4var(18,2,1,1,1) - this%vaerosn(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - opt1 = a4var(19,1,1,1,1) - opt2 = a4var(19,2,1,1,1) - this%vaeroln(icol,k,kcomp) = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - end do ! icol - end do ! k - - end subroutine intdrypar4 - - ! ========================================================== - subroutine intdrypar5to10 (this, lchnk, ncol, Nnatk, xct, ict1, & - xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) - - ! Output arguments: Modal mass concentrations (cint), area (aaero) - ! and volume (vaero) (for AeroCom determination of particle - ! effective radii) of each constituent. cint*05 and cint*125 are - ! for r<0.5um and r>1.25um, respectively. aaeros and vaeros are - ! integrated over r<0.5um, and aaerol and vaerol over r>0.5um. - - ! arguments - class(aerodry_prop_type) :: this - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) - integer , intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer , intent(in) :: ifaq1(pcols,pver,nbmodes) - - ! local variables - real(r8) :: a, b, e, eps - integer :: iv, kcomp, k, icol - integer :: t_ict1, t_ict2, t_ifa1, t_ifa2 - integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) :: t_faq1, t_faq2, t_xfaq - real(r8) :: t_fbc1, t_fbc2, t_xfbc - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_xct, t_cat1, t_cat2 - real(r8) :: d2mx(4), dxm1(4), invd(4) - real(r8) :: opt4d(2,2,2,2) - real(r8) :: opt1, opt2, opt - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): - - do kcomp=5,10 - call this%zero(kcomp,ncol) - - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kcomp)>0.0_r8) then - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifb1 = ifbc1(icol,k,kcomp) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - t_cat1 = cat(kcomp,t_ict1) - t_cat2 = cat(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbc1 = fbc(t_ifb1) - t_fbc2 = fbc(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfbc = xfbc(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_cat2-t_xct) - dxm1(1) = (t_xct-t_cat1) - invd(1) = 1.0_r8/(t_cat2-t_cat1) - d2mx(2) = (t_fac2-t_xfac) - dxm1(2) = (t_xfac-t_fac1) - invd(2) = 1.0_r8/(t_fac2-t_fac1) - d2mx(3) = (t_fbc2-t_xfbc) - dxm1(3) = (t_xfbc-t_fbc1) - invd(3) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(4) = (t_faq2-t_xfaq) - dxm1(4) = (t_xfaq-t_faq1) - invd(4) = 1.0_r8/(t_faq2-t_faq1) - !soa - - do iv=1,19 ! variable number - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=a5to10var(iv,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt4d(1,1,1,2)=a5to10var(iv,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt4d(1,1,2,1)=a5to10var(iv,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt4d(1,1,2,2)=a5to10var(iv,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt4d(1,2,1,1)=a5to10var(iv,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt4d(1,2,1,2)=a5to10var(iv,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt4d(1,2,2,1)=a5to10var(iv,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt4d(1,2,2,2)=a5to10var(iv,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt4d(2,1,1,1)=a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt4d(2,1,1,2)=a5to10var(iv,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt4d(2,1,2,1)=a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt4d(2,1,2,2)=a5to10var(iv,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt4d(2,2,1,1)=a5to10var(iv,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt4d(2,2,1,2)=a5to10var(iv,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt4d(2,2,2,1)=a5to10var(iv,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt4d(2,2,2,2)=a5to10var(iv,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, and fac and dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, opt1, opt2) - - ! finally, interpolation in the cat dimension - opt = (d2mx(1)*opt1+dxm1(1)*opt2)*invd(1) - - call this%update(kcomp, k, icol, iv, opt) - end do - endif - - this%cknorm(icol,k,kcomp) = a5to10var(1,1,1,1,1,kcomp) - this%cknlt05(icol,k,kcomp) = a5to10var(2,1,1,1,1,kcomp) - this%ckngt125(icol,k,kcomp)= a5to10var(3,1,1,1,1,kcomp) - - end do ! icol - end do ! k - end do ! kcomp - - end subroutine intdrypar5to10 - - ! ========================================================== - subroutine zero(this, kcomp, ncol) - - class(aerodry_prop_type) :: this - integer , intent(in) :: kcomp - integer , intent(in) :: ncol - - integer :: k - integer :: icol - - ! initialize all output fields to zero - do k=1,pver - do icol=1,ncol - this%cintbg(icol,k,kcomp) = 0.0_r8 - this%cintbg05(icol,k,kcomp) = 0.0_r8 - this%cintbg125(icol,k,kcomp) = 0.0_r8 - this%cintbc(icol,k,kcomp) = 0.0_r8 - this%cintbc05(icol,k,kcomp) = 0.0_r8 - this%cintbc125(icol,k,kcomp) = 0.0_r8 - this%cintoc(icol,k,kcomp) = 0.0_r8 - this%cintoc05(icol,k,kcomp) = 0.0_r8 - this%cintoc125(icol,k,kcomp) = 0.0_r8 - this%cintsc(icol,k,kcomp) = 0.0_r8 - this%cintsc05(icol,k,kcomp) = 0.0_r8 - this%cintsc125(icol,k,kcomp) = 0.0_r8 - this%cintsa(icol,k,kcomp) = 0.0_r8 - this%cintsa05(icol,k,kcomp) = 0.0_r8 - this%cintsa125(icol,k,kcomp) = 0.0_r8 - this%aaeros(icol,k,kcomp) = 0.0_r8 - this%aaerol(icol,k,kcomp) = 0.0_r8 - this%vaeros(icol,k,kcomp) = 0.0_r8 - this%vaerol(icol,k,kcomp) = 0.0_r8 - end do - end do - end subroutine zero - - ! ========================================================== - subroutine update(this, kcomp, k, icol, iv, opt) - - class(aerodry_prop_type) :: this - integer , intent(in) :: kcomp - integer , intent(in) :: k - integer , intent(in) :: icol - integer , intent(in) :: iv - real(r8), intent(in) :: opt - - if(iv==1) then - this%cintbg(icol,k,kcomp)=opt - elseif(iv==2) then - this%cintbg05(icol,k,kcomp)=opt - elseif(iv==3) then - this%cintbg125(icol,k,kcomp)=opt - elseif(iv==4) then - this%cintbc(icol,k,kcomp)=opt - elseif(iv==5) then - this%cintbc05(icol,k,kcomp)=opt - elseif(iv==6) then - this%cintbc125(icol,k,kcomp)=opt - elseif(iv==7) then - this%cintoc(icol,k,kcomp)=opt - elseif(iv==8) then - this%cintoc05(icol,k,kcomp)=opt - elseif(iv==9) then - this%cintoc125(icol,k,kcomp)=opt - elseif(iv==10) then - this%cintsc(icol,k,kcomp)=opt - elseif(iv==11) then - this%cintsc05(icol,k,kcomp)=opt - elseif(iv==12) then - this%cintsc125(icol,k,kcomp)=opt - elseif(iv==13) then - this%cintsa(icol,k,kcomp)=opt - elseif(iv==14) then - this%cintsa05(icol,k,kcomp)=opt - elseif(iv==15) then - this%cintsa125(icol,k,kcomp)=opt - elseif(iv==16) then - this%aaeros(icol,k,kcomp)=opt - elseif(iv==17) then - this%aaerol(icol,k,kcomp)=opt - elseif(iv==18) then - this%vaeros(icol,k,kcomp)=opt - elseif(iv==19) then - this%vaerol(icol,k,kcomp)=opt - endif - - end subroutine update - - subroutine checkTableHeader (ifil) - ! Read the header-text in a look-up table (in file with iu=ifil). - - integer, intent(in) :: ifil - character*80 :: headertext - character*12 :: text0, text1 - - text0='X-CHECK LUT' - text1='none ' - do while (text1(2:12) .ne. text0(2:12)) - read(ifil,'(A)') headertext - text1 = headertext(2:12) - enddo - end subroutine checkTableHeader - -#endif - -end module oslo_aero_aerocom_dry diff --git a/src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 b/src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 deleted file mode 100644 index 709070ce85..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_aerocom_opt.F90 +++ /dev/null @@ -1,1296 +0,0 @@ -module oslo_aero_aerocom_opt - -#ifdef AEROCOM - - use shr_kind_mod , only : r8 => shr_kind_r8 - use ppgrid , only : pcols, pver - use cam_logfile , only : iulog - ! - use oslo_aero_params , only : nmodes, nbmodes - use oslo_aero_sw_tables , only : cate, cat, fac, faq, fbc, rh, fombg, fbcbg - use oslo_aero_control , only : oslo_aero_getopts, dir_string_length - use oslo_aero_linear_interp , only : lininterpol3dim, lininterpol4dim, lininterpol5dim - - implicit none - private - - ! Set by init_aeropt Mode0 - real(r8) :: bex440, bax440 - real(r8) :: bex500, bax500, bax550 - real(r8) :: bex670, bax670 - real(r8) :: bex870, bax870 - real(r8) :: bex550lt1, bex550gt1, backscx550 - - ! Set by init_aeropt Mode1 - real(r8), public :: bep1(38,10,6,16,6) - - ! Set by init_aeropt Mode2to3 - real(r8), public :: bep2to3 (38,10,16,6,2:3) - - ! Set by init_aeropt Mode4 - real(r8), public :: bep4(38,10,6,16,6,6) - - ! Set by init_aeropt Mode5to10 - real(r8), public :: bep5to10(38,10,6,6,6,6,5:10) - - ! Modal total and absorption extiction coefficients (for AeroCom) - ! for 440nm, 500nm, 550nm, 670nm and 870nm, and for d<1um (lt1) and d>1um (gt1). - ! March 2009: + backscatter coefficient, backsc550 (km-1 sr-1). - type, public :: extinction_coeffs_type - real(r8) :: bext440(pcols,pver,0:nbmodes) - real(r8) :: babs440(pcols,pver,0:nbmodes) - real(r8) :: bext500(pcols,pver,0:nbmodes) - real(r8) :: babs500(pcols,pver,0:nbmodes) - real(r8) :: bext550(pcols,pver,0:nbmodes) - real(r8) :: babs550(pcols,pver,0:nbmodes) - real(r8) :: bext670(pcols,pver,0:nbmodes) - real(r8) :: babs670(pcols,pver,0:nbmodes) - real(r8) :: bext870(pcols,pver,0:nbmodes) - real(r8) :: babs870(pcols,pver,0:nbmodes) - real(r8) :: bebg440(pcols,pver,0:nbmodes) - real(r8) :: bebg500(pcols,pver,0:nbmodes) - real(r8) :: bebg550(pcols,pver,0:nbmodes) - real(r8) :: babg550(pcols,pver,0:nbmodes) - real(r8) :: bebg670(pcols,pver,0:nbmodes) - real(r8) :: bebg870(pcols,pver,0:nbmodes) - real(r8) :: bebc440(pcols,pver,0:nbmodes) - real(r8) :: bebc500(pcols,pver,0:nbmodes) - real(r8) :: bebc550(pcols,pver,0:nbmodes) - real(r8) :: babc550(pcols,pver,0:nbmodes) - real(r8) :: bebc670(pcols,pver,0:nbmodes) - real(r8) :: bebc870(pcols,pver,0:nbmodes) - real(r8) :: beoc440(pcols,pver,0:nbmodes) - real(r8) :: beoc500(pcols,pver,0:nbmodes) - real(r8) :: beoc550(pcols,pver,0:nbmodes) - real(r8) :: baoc550(pcols,pver,0:nbmodes) - real(r8) :: beoc670(pcols,pver,0:nbmodes) - real(r8) :: beoc870(pcols,pver,0:nbmodes) - real(r8) :: besu440(pcols,pver,0:nbmodes) - real(r8) :: besu500(pcols,pver,0:nbmodes) - real(r8) :: besu550(pcols,pver,0:nbmodes) - real(r8) :: basu550(pcols,pver,0:nbmodes) - real(r8) :: besu670(pcols,pver,0:nbmodes) - real(r8) :: besu870(pcols,pver,0:nbmodes) - real(r8) :: bebg550lt1(pcols,pver,0:nbmodes) - real(r8) :: bebg550gt1(pcols,pver,0:nbmodes) - real(r8) :: bebc550lt1(pcols,pver,0:nbmodes) - real(r8) :: bebc550gt1(pcols,pver,0:nbmodes) - real(r8) :: beoc550lt1(pcols,pver,0:nbmodes) - real(r8) :: beoc550gt1(pcols,pver,0:nbmodes) - real(r8) :: besu550lt1(pcols,pver,0:nbmodes) - real(r8) :: besu550gt1(pcols,pver,0:nbmodes) - real(r8) :: backsc550(pcols,pver,0:nbmodes) - - contains - procedure :: intaeropt0 - procedure :: intaeropt1 - procedure :: intaeropt2to3 - procedure :: intaeropt4 - procedure :: intaeropt5to10 - procedure :: zero - procedure :: update - end type extinction_coeffs_type - - type(extinction_coeffs_type), public :: extinction_coeffs - type(extinction_coeffs_type), public :: extinction_coeffsn - - public :: initaeropt - -! ========================================================== -contains -! ========================================================== - - subroutine initaeropt() - - !Purpose: To read in the AeroCom look-up tables for aerosol optical properties. - ! The grid for discrete input-values in the look-up tables is defined in opptab. - - ! Tabulating the 'aerocomk'-files to save computing time. - ! Updated for new kcomp1.out including condensed SOA - Alf KirkevÃ¥g, May 2013 - ! Extended for new SOA treatment - Alf Kirkevaag, September 2015. - ! Modified for optimized added masses and mass fractions for - ! concentrations from condensation, coagulation or cloud-processing - ! - Alf Kirkevaag, May 2016. - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - - integer :: ic, ifil, lin, iv - integer :: kcomp, irelh, ictot, ifac, ifbc, ifaq - integer :: ifombg, ifbcbg - real(r8) :: catot, relh, frombg, frbcbg, frac, fabc, fraq - real(r8) :: bext440, babs440, bext500, babs500, babs550 - real(r8) :: bext670, babs670, bext870, babs870 - real(r8) :: bebg440, babg440, bebg500, babg500, babg550 - real(r8) :: bebg670, babg670, bebg870, babg870 - real(r8) :: bebc440, babc440, bebc500, babc500, babc550 - real(r8) :: bebc670, babc670, bebc870, babc870 - real(r8) :: beoc440, baoc440, beoc500, baoc500, baoc550 - real(r8) :: beoc670, baoc670, beoc870, baoc870 - real(r8) :: besu440, basu440, besu500, basu500, basu550 - real(r8) :: besu670, basu670, besu870 - real(r8) :: bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1 - real(r8) :: beoc550lt1, beoc550gt1, besu550lt1, besu550gt1 - real(r8) :: backscat550 - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - real(r8) :: eps7 = 1.e-7_r8 - character(len=dir_string_length) :: aerotab_table_dir - !----------------------------------------------------------- - - call oslo_aero_getopts(aerotab_table_dir_out = aerotab_table_dir) - - open(20,file=trim(aerotab_table_dir)//'/aerocomk0.out' , form='formatted',status='old') - open(21,file=trim(aerotab_table_dir)//'/aerocomk1.out' , form='formatted',status='old') - open(11,file=trim(aerotab_table_dir)//'/aerocomk2.out' , form='formatted',status='old') - open(12,file=trim(aerotab_table_dir)//'/aerocomk3.out' , form='formatted',status='old') - open(13,file=trim(aerotab_table_dir)//'/aerocomk4.out' , form='formatted',status='old') - open(14,file=trim(aerotab_table_dir)//'/aerocomk5.out' , form='formatted',status='old') - open(15,file=trim(aerotab_table_dir)//'/aerocomk6.out' , form='formatted',status='old') - open(16,file=trim(aerotab_table_dir)//'/aerocomk7.out' , form='formatted',status='old') - open(17,file=trim(aerotab_table_dir)//'/aerocomk8.out' , form='formatted',status='old') - open(18,file=trim(aerotab_table_dir)//'/aerocomk9.out' , form='formatted',status='old') - open(19,file=trim(aerotab_table_dir)//'/aerocomk10.out', form='formatted',status='old') - - ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 11,21 - call checkTableHeader (ifil) - enddo - ! - !------------------------------------------- - ! Mode 0, BC - !------------------------------------------- - ! - read(20,'(I2,f6.3,12e11.4)') & - kcomp, relh, & - bex440, bax440, bex500, bax500, bax550, bex670, bax670, & - bex870, bax870, bex550lt1, bex550gt1, backscx550 - - if(bex440<=0.0_r8) then - write(*,*) 'bex440 =', bex440 - write(*,*) 'Error in initialization of bex1' - stop - endif - write(iulog,*)'aerocom mode 0 ok' - ! - !------------------------------------------- - ! Mode 1 (H2SO4 and SOA + condensate from H2SO4 and SOA) - !------------------------------------------- - ! - do lin = 1,5760 ! 10x6x16x6 - read(21,'(I2,f6.3,3e10.3,38e10.3)') & - kcomp, relh, frombg, catot, frac, & - bext440, bext500, bext670, bext870, & - bebg440, bebg500, bebg670, bebg870, & - bebc440, bebc500, bebc670, bebc870, & - beoc440, beoc500, beoc670, beoc870, & - besu440, besu500, besu670, besu870, & - babs440, babs500, babs550, babs670, babs870, & - bebg550lt1, bebg550gt1, bebc550lt1, bebc550gt1, & - beoc550lt1, beoc550gt1, besu550lt1, besu550gt1, & - backscat550, babg550, babc550, baoc550, basu550 - - do ic=1,10 - if(abs(relh-rh(ic)) 0 - end do ! icol - end do ! k - - end subroutine intaeropt2to3 - - ! ========================================================== - subroutine intaeropt4 (this, lchnk, ncol, xrh, irh1, mplus10, Nnatk, & - xfbcbg, ifbcbg1, xct, ict1, xfac, ifac1, xfaq, ifaq1) - - class(extinction_coeffs_type) :: this - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - integer , intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xfbcbg(pcols,pver) - integer , intent(in) :: ifbcbg1(pcols,pver) - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer , intent(in) :: ifaq1(pcols,pver,nbmodes) - - ! Local variables - real(r8) :: a, b, e, eps - integer :: i, iv, kcomp, k, icol, kc10 - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifa1, t_ifa2 - real(r8) :: t_fbcbg1, t_fbcbg2 - integer :: t_ifb1, t_ifb2 - real(r8) :: t_faq1, t_faq2, t_xfaq - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 - real(r8) :: t_cat1, t_cat2 - real(r8) :: t_xfbcbg - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: opt1, opt2, opt(38) - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! BC&OC(Ait) mode: - kcomp = 4 - call this%zero(kcomp, ncol) - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kc10).gt.0) then - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ifb1 = ifbcbg1(icol,k) - t_ifb2 = t_ifb1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xfbcbg = xfbcbg(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fbcbg2-t_xfbcbg) - dxm1(2) = (t_xfbcbg-t_fbcbg1) - invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - do iv=1,38 ! variable number - - opt5d(1,1,1,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=bep4(iv,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=bep4(iv,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=bep4(iv,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=bep4(iv,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - - ! finally, interpolation in the rh dimension - opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - - end do ! iv=1,38 - - ! determine extinction coefficient - call this%update(icol, k, kcomp, opt) - - end if ! Nnatk > 0 - end do ! icol - end do ! k - - end subroutine intaeropt4 - - ! ========================================================== - subroutine intaeropt5to10 (this, lchnk, ncol, xrh, irh1, Nnatk, & - xct, ict1, xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1) - - ! Arguments - class(extinction_coeffs_type) :: this - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - real(r8) , intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer , intent(in) :: irh1(pcols,pver) - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer , intent(in) :: ict1(pcols,pver,nmodes) - real(r8) , intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) - integer , intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) - integer , intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8) , intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer , intent(in) :: ifaq1(pcols,pver,nbmodes) - - ! Local variables - real(r8) :: a, b, e, eps - integer :: i, iv, kcomp, k, icol - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 - integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) :: t_faq1, t_faq2, t_xfaq - real(r8) :: t_fbc1, t_fbc2, t_xfbc - real(r8) :: t_fac1, t_fac2, t_xfac - real(r8) :: t_xrh, t_xct, t_rh1, t_rh2 - real(r8) :: t_cat1, t_cat2 - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: opt1, opt2, opt(38) - parameter (e=2.718281828_r8, eps=1.0e-60_r8) - - ! Modes 5 to 10 (SO4(Ait75) and mineral and seasalt-modes + cond./coag./aq.): - - do kcomp=5,10 - ! zero extinction coefficients for this kcomp - call this%zero(kcomp, ncol) - - do k=1,pver - do icol=1,ncol - if(Nnatk(icol,k,kcomp).gt.0) then - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - t_ifb1 = ifbc1(icol,k,kcomp) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cat(kcomp,t_ict1) - t_cat2 = cat(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbc1 = fbc(t_ifb1) - t_fbc2 = fbc(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfbc = xfbc(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - d2mx(4) = (t_fbc2-t_xfbc) - dxm1(4) = (t_xfbc-t_fbc1) - invd(4) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - do iv=1,38 ! variable number - opt5d(1,1,1,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=bep5to10(iv,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=bep5to10(iv,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=bep5to10(iv,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=bep5to10(iv,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, opt1, opt2) - - ! finally, interpolation in the rh dimension - opt(iv) = ((t_rh2-t_xrh)*opt1+(t_xrh-t_rh1)*opt2) /(t_rh2-t_rh1) - - end do ! iv=1,38 - - ! determine extinction coefficient - call this%update(icol, k, kcomp, opt) - - end if ! Nnatk > 0 - end do ! icol - end do ! k - end do ! kcomp - - end subroutine intaeropt5to10 - - ! ========================================================== - subroutine zero(this, kcomp, ncol) - - class(extinction_coeffs_type) :: this - integer , intent(in) :: kcomp - integer , intent(in) :: ncol - - integer :: k - integer :: icol - - ! initialize all output fields to zero - do k=1,pver - do icol=1,ncol - this%bext440(icol,k,kcomp) = 0.0_r8 - this%babs440(icol,k,kcomp) = 0.0_r8 - this%bext500(icol,k,kcomp) = 0.0_r8 - this%babs500(icol,k,kcomp) = 0.0_r8 - this%bext550(icol,k,kcomp) = 0.0_r8 - this%babs550(icol,k,kcomp) = 0.0_r8 - this%bext670(icol,k,kcomp) = 0.0_r8 - this%babs670(icol,k,kcomp) = 0.0_r8 - this%bext870(icol,k,kcomp) = 0.0_r8 - this%babs870(icol,k,kcomp) = 0.0_r8 - this%bebg440(icol,k,kcomp) = 0.0_r8 - this%bebg500(icol,k,kcomp) = 0.0_r8 - this%bebg550(icol,k,kcomp) = 0.0_r8 - this%babg550(icol,k,kcomp) = 0.0_r8 - this%bebg670(icol,k,kcomp) = 0.0_r8 - this%bebg870(icol,k,kcomp) = 0.0_r8 - this%bebc440(icol,k,kcomp) = 0.0_r8 - this%bebc500(icol,k,kcomp) = 0.0_r8 - this%bebc550(icol,k,kcomp) = 0.0_r8 - this%babc550(icol,k,kcomp) = 0.0_r8 - this%bebc670(icol,k,kcomp) = 0.0_r8 - this%bebc870(icol,k,kcomp) = 0.0_r8 - this%beoc440(icol,k,kcomp) = 0.0_r8 - this%beoc500(icol,k,kcomp) = 0.0_r8 - this%beoc550(icol,k,kcomp) = 0.0_r8 - this%baoc550(icol,k,kcomp) = 0.0_r8 - this%beoc670(icol,k,kcomp) = 0.0_r8 - this%beoc870(icol,k,kcomp) = 0.0_r8 - this%besu440(icol,k,kcomp) = 0.0_r8 - this%besu500(icol,k,kcomp) = 0.0_r8 - this%besu550(icol,k,kcomp) = 0.0_r8 - this%basu550(icol,k,kcomp) = 0.0_r8 - this%besu670(icol,k,kcomp) = 0.0_r8 - this%besu870(icol,k,kcomp) = 0.0_r8 - this%bebg550lt1(icol,k,kcomp) = 0.0_r8 - this%bebg550gt1(icol,k,kcomp) = 0.0_r8 - this%bebc550lt1(icol,k,kcomp) = 0.0_r8 - this%bebc550gt1(icol,k,kcomp) = 0.0_r8 - this%beoc550lt1(icol,k,kcomp) = 0.0_r8 - this%beoc550gt1(icol,k,kcomp) = 0.0_r8 - this%besu550lt1(icol,k,kcomp) = 0.0_r8 - this%besu550gt1(icol,k,kcomp) = 0.0_r8 - this%backsc550(icol,k,kcomp) = 0.0_r8 - end do - end do - - end subroutine zero - - ! ========================================================== - subroutine update(this, icol, k, kcomp, opt) - - class(extinction_coeffs_type) :: this - integer , intent(in) :: icol - integer , intent(in) :: k - integer , intent(in) :: kcomp - real(r8) , intent(in) :: opt(:) - - this%bext440(icol,k,kcomp) = opt(1) - this%bext500(icol,k,kcomp) = opt(2) - this%bext670(icol,k,kcomp) = opt(3) - this%bext870(icol,k,kcomp) = opt(4) - this%bebg440(icol,k,kcomp) = opt(5) - this%bebg500(icol,k,kcomp) = opt(6) - this%bebg670(icol,k,kcomp) = opt(7) - this%bebg870(icol,k,kcomp) = opt(8) - this%bebc440(icol,k,kcomp) = opt(9) - this%bebc500(icol,k,kcomp) = opt(10) - this%bebc670(icol,k,kcomp) = opt(11) - this%bebc870(icol,k,kcomp) = opt(12) - this%beoc440(icol,k,kcomp) = opt(13) - this%beoc500(icol,k,kcomp) = opt(14) - this%beoc670(icol,k,kcomp) = opt(15) - this%beoc870(icol,k,kcomp) = opt(16) - this%besu440(icol,k,kcomp) = opt(17) - this%besu500(icol,k,kcomp) = opt(18) - this%besu670(icol,k,kcomp) = opt(19) - this%besu870(icol,k,kcomp) = opt(20) - this%babs440(icol,k,kcomp) = opt(21) - this%babs500(icol,k,kcomp) = opt(22) - this%babs550(icol,k,kcomp) = opt(23) - this%babs670(icol,k,kcomp) = opt(24) - this%babs870(icol,k,kcomp) = opt(25) - this%bebg550lt1(icol,k,kcomp) = opt(26) - this%bebg550gt1(icol,k,kcomp) = opt(27) - this%bebc550lt1(icol,k,kcomp) = opt(28) - this%bebc550gt1(icol,k,kcomp) = opt(29) - this%beoc550lt1(icol,k,kcomp) = opt(30) - this%beoc550gt1(icol,k,kcomp) = opt(31) - this%besu550lt1(icol,k,kcomp) = opt(32) - this%besu550gt1(icol,k,kcomp) = opt(33) - this%backsc550(icol,k,kcomp) = opt(34) - this%babg550(icol,k,kcomp) = opt(35) - this%babc550(icol,k,kcomp) = opt(36) - this%baoc550(icol,k,kcomp) = opt(37) - this%basu550(icol,k,kcomp) = opt(38) - this%bebg550(icol,k,kcomp) = opt(26)+opt(27) - this%bebc550(icol,k,kcomp) = opt(28)+opt(29) - this%beoc550(icol,k,kcomp) = opt(30)+opt(31) - this%besu550(icol,k,kcomp) = opt(32)+opt(33) - this%bext550(icol,k,kcomp) = this%bebg550(icol,k,kcomp) + this%bebc550(icol,k,kcomp) & - +this%beoc550(icol,k,kcomp) + this%besu550(icol,k,kcomp) - end subroutine update - - subroutine checkTableHeader (ifil) - ! Read the header-text in a look-up table (in file with iu=ifil). - - integer, intent(in) :: ifil - character*80 :: headertext - character*12 :: text0, text1 - - text0='X-CHECK LUT' - text1='none ' - do while (text1(2:12) .ne. text0(2:12)) - read(ifil,'(A)') headertext - text1 = headertext(2:12) - enddo - end subroutine checkTableHeader - -#endif - -end module oslo_aero_aerocom_opt diff --git a/src/chemistry/oslo_aero/oslo_aero_coag.F90 b/src/chemistry/oslo_aero/oslo_aero_coag.F90 deleted file mode 100644 index 150401b0c2..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_coag.F90 +++ /dev/null @@ -1,760 +0,0 @@ -module oslo_aero_coag - - !---------------------------------------------------------------------- - ! modal aerosol coagulation - !---------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - use phys_control, only: phys_getopts - use chem_mods, only: gas_pcnst - use mo_tracname, only: solsym - use physconst, only: rair, gravit - use cam_logfile, only: iulog - use oslo_aero_share - use oslo_aero_const - - implicit none - private - - public :: initializeCoagulationReceivers ! called by oslo_aero/aero_model - public :: initializeCoagulationCoefficients ! called by oslo_aero/aero_model - public :: initializeCoagulationOutput ! called by oslo_aero/aero_model - public :: coagtend ! called by oslo_aero/aero_model - public :: clcoag ! called by oslo_aero/aero_model - - integer, parameter, public :: numberOfCoagulationReceivers = 6 - integer, parameter, public :: numberOfAddCoagReceivers = 6 - - real(r8), public :: normalizedCoagulationSink(0:nmodes,0:nmodes) ![m3/#/s] - real(r8), public :: NCloudCoagulationSink(0:nmodes) ![m3/#/s] - real(r8), public :: normCoagSinkAdd(numberOfAddCoagReceivers) ![m3/#/s] - - !These are the modes which are coagulating (belonging to mixtures no. 0, 1, 2, 4, 12, 14) - integer , parameter :: numberOfCoagulatingModes = 6 - integer, public :: coagulatingMode(numberOfCoagulatingModes) = & - (/MODE_IDX_BC_EXT_AC & !inert mode - , MODE_IDX_SO4SOA_AIT, MODE_IDX_BC_AIT, MODE_IDX_OMBC_INTMIX_COAT_AIT & !internally mixed small modes - , MODE_IDX_BC_NUC, MODE_IDX_OMBC_INTMIX_AIT /) !externally mixed small modes - - !These are the modes which are receiving coagulating material in OsloAero - ! (belonging to mixtures no. 5, 6, 7, 8, 9, 10) - integer, public :: receiverMode(numberOfCoagulationReceivers) = & - (/MODE_IDX_SO4_AC,MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 /) - - !And these are the additional modes which are allowed to contribute to the - ! coagulation sink, defined here and to be used only in the nucleation code in condtend.F90 - ! (belonging to mixtures no. 0, 1, 2, 4, 12, 14) - integer, public :: addReceiverMode(numberOfAddCoagReceivers) = & - (/MODE_IDX_BC_EXT_AC,MODE_IDX_SO4SOA_AIT,MODE_IDX_BC_AIT, & - MODE_IDX_OMBC_INTMIX_COAT_AIT,MODE_IDX_BC_NUC,MODE_IDX_OMBC_INTMIX_AIT /) - - !Coagulation moves aerosol mass to the "coagulate" species, so some - !lifecycle species will receive mass in this routine! - integer :: lifeCycleReceiver(gas_pcnst) - - ! Coagulation between aerosol and cloud droplets move coagulate into - ! the equivalent value for aerosol concentration in cloud water. - ! Exception: Sulphate coagulation with cloud droplets is merged with - ! component from aqueous phase chemistry in order to take advantage of the - ! more detailed addition onto larger particles. - - integer :: CloudAerReceiver(gas_pcnst) - - ! Closest Table index for assumed size of droplets used in coagulation - integer :: tableindexcloud - real(r8),parameter :: rcoagdroplet = 10.e-6 ! m - - real(r8), parameter :: kboltzmann = 1.3806488e-23_r8 ![m2 kg s-2 K-1] - real(r8), parameter :: temperatureLookupTables = 293.15_r8 !Temperature used in look up tables - real(r8), parameter :: mfpAir = 63.3e-9_r8 ![m] mean free path air - real(r8), parameter :: viscosityAir = 1.983e-5_r8 ![Pa s] viscosity of air - real(r8), parameter :: rhoh2o = 1000._r8 ! Density of water - -!================================================================ -contains -!================================================================ - - subroutine initializeCoagulationOutput() - use cam_history, only: addfld, add_default, fieldname_len, horiz_only - - integer :: iChem - character(len=fieldname_len+3) :: fieldname_receiver - character(len=fieldname_len+3) :: fieldname_donor - character(8) :: unit - logical :: history_aerosol - logical :: isAlreadyOnList(gas_pcnst) - - call phys_getopts(history_aerosol_out = history_aerosol) - - isAlreadyOnList(:) = .FALSE. - do iChem = 1,gas_pcnst - !Does this tracer have a receiver? If yes: It contributes to coagulation - if(lifeCycleReceiver(iChem) .gt. 0)then - unit = "kg/m2/s" - fieldname_donor = trim(solsym(iChem))//"coagTend" - fieldname_receiver = trim(solsym(lifeCycleReceiver(iChem)))//"coagTend" - if(.not. isAlreadyOnList(lifeCycleReceiver(iChem)))then - call addfld( fieldname_receiver, horiz_only ,"A", unit, "coagulation tendency") - isAlreadyOnList(lifeCycleReceiver(iChem))=.TRUE. - end if - call addfld( fieldname_donor, horiz_only, 'A', unit, "coagulation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - call add_default( fieldname_donor , 1, ' ') - end if - end if - end do - - isAlreadyOnList(:) = .FALSE. - do iChem = 1,gas_pcnst - if(CloudAerReceiver(iChem) .gt. 0)then - unit = "kg/m2/s" - fieldname_donor = trim(solsym(iChem))//"clcoagTend" - fieldname_receiver = trim(solsym(CloudAerReceiver(iChem)))//"_OCWclcoagTend" - if(.not. isAlreadyOnList(CloudAerReceiver(iChem)))then - call addfld( fieldname_receiver, horiz_only, 'A', unit, "coagulation tendency" ) - isAlreadyOnList(CloudAerReceiver(iChem))=.TRUE. - end if - call addfld( fieldname_donor, horiz_only, "A", unit, "coagulation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - call add_default( fieldname_donor , 1, ' ') - end if - end if - end do - end subroutine initializeCoagulationOutput - - !================================================================ - subroutine initializeCoagulationReceivers() - - !These are the lifecycle-species receiving coagulate - lifeCycleReceiver(:) = -99 - lifeCycleReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ac) - lifeCycleReceiver(chemistryIndex(l_so4_na)) = chemistryIndex(l_so4_ac) !create so4 coagulate from so4 in mode 1 - lifeCycleReceiver(chemistryIndex(l_bc_a)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 2 - lifeCycleReceiver(chemistryIndex(l_bc_ai)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 4 - lifeCycleReceiver(chemistryIndex(l_om_ai)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 4 - lifeCycleReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 12 - lifeCycleReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ac) !create bc coagulate from om in mode 14 - lifeCycleReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 14 - lifeCycleReceiver(chemistryIndex(l_so4_a1)) = chemistryIndex(l_so4_ac) !Create so4 coagulate from so4 condensate - lifeCycleReceiver(chemistryINdex(l_soa_na)) = chemistryIndex(l_soa_a1) - - !These are the lifecycle-species receiving coagulate - CloudAerReceiver(:) = -99 - CloudAerReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ac) - CloudAerReceiver(chemistryIndex(l_so4_na)) = chemistryIndex(l_so4_a2) !create so4 coagulate from so4 in mode 1 - CloudAerReceiver(chemistryIndex(l_bc_a)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 2 - CloudAerReceiver(chemistryIndex(l_bc_ai)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 4 - CloudAerReceiver(chemistryIndex(l_om_ai)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 4 - CloudAerReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_ac) !create bc coagulate from bc in mode 12 - CloudAerReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ac) !create bc coagulate from om in mode 14 - CloudAerReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ac) !create om coagulate from om in mode 14 - CloudAerReceiver(chemistryIndex(l_so4_a1)) = chemistryIndex(l_so4_a2) !Create so4 coagulate from so4 condensate - cloudAerReceiver(chemistryIndex(l_soa_na)) = chemistryIndex(l_soa_a1) - end subroutine initializeCoagulationReceivers - - !================================================================ - subroutine initializeCoagulationCoefficients(rhob,rk) - - use mo_constants, only: pi - use oslo_aero_const, only: normnk - - real(r8), intent(in) :: rk(0:nmodes) ![unit] radius of background (receiver) mode - real(r8), intent(in) :: rhob(0:nmodes) !density of background mode - - real(r8), dimension(numberOfCoagulationReceivers, numberOfCoagulatingModes, nBinsTab) :: K12 = 0.0_r8 !Coagulation coefficient (m3/s) - real(r8), dimension(numberOfAddCoagReceivers,nBinsTab) :: CoagCoeffModeAdd = 0.0_r8 !Coagulation coefficient mode 1 (m3/s) - real(r8), dimension(numberOfCoagulatingModes,nBinsTab) :: K12Cl = 0.0_r8 !Coagulation coefficient (m3/s) - real(r8), dimension(nBinsTab) :: coagulationCoefficient - integer :: aMode - integer :: modeIndex - integer :: modeIndexCoagulator !Index of coagulating mode - integer :: modeIndexReceiver !Index of receiving mode - integer :: iCoagulatingMode !Counter for coagulating mode - integer :: iReceiverMode !Counter for receiver modes - integer :: nsiz !counter for look up table sizes - - do iReceiverMode = 1, numberOfCoagulationReceivers - do iCoagulatingMode = 1,numberOfCoagulatingModes - - !Index of the coagulating mode (0-14), see list above - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) - - !Index of receiver mode (0-14), see list above - modeIndexReceiver = receiverMode(iReceiverMode) - - !Pre-calculate coagulation coefficients for this coagulator.. - !Note: Not using actual density of coagulator here - !Since this is not known at init-time - call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient - , rk(modeIndexCoagulator) & !I [m] radius of coagulator - , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator - , rhob(modeIndexReceiver) ) !I [kg/m3] density of receiver - - !Save values - K12(iReceiverMode,iCoagulatingMode,:) = CoagulationCoefficient(:) - - enddo - end do !receiver modes - - !nuctst3+ - ! call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient - ! , rk(1) & !I [m] radius of coagulator - ! , rhob(1) & !I [kg/m3] density of coagulator - ! , rhob(1) ) !I [kg/m3] density of receiver - ! CoagCoeffMode1(:) = CoagulationCoefficient(:) - !nuctst3- - !ak+ - do iReceiverMode = 1, numberOfAddCoagReceivers - iCoagulatingMode = 1 - - !Index of the coagulating mode (0-14), see list above - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) - - !Index of receiver mode (0-14), see list above - modeIndexReceiver = addReceiverMode(iReceiverMode) - - !Pre-calculate coagulation coefficients for this coagulator.. - !Note: Not using actual density of coagulator here - !Since this is not known at init-time - call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient - , rk(modeIndexCoagulator) & !I [m] radius of coagulator - , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator - , rhob(modeIndexReceiver) ) !I [kg/m3] density of receiver - - !Save values - CoagCoeffModeAdd(iReceiverMode,:) = CoagulationCoefficient(:) - - end do !receiver modes - !ak- - - ! Onl one receivermode for cloud coagulation (water) - do iCoagulatingMode = 1,numberOfCoagulatingModes - - !Index of the coagulating mode (0-14), see list above - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) - - !Pre-calculate coagulation coefficients for this coagulator.. - !Note: Not using actual density of coagulator here - !Since this is not known at init-time - call calculateCoagulationCoefficient(CoagulationCoefficient & !O [m3/s] coagulation coefficient - , rk(modeIndexCoagulator) & !I [m] radius of coagulator - , rhob(modeIndexCoagulator) & !I [kg/m3] density of coagulator - , rhoh2o ) !I [kg/m3] density of receiver - - !Save values - K12Cl(iCoagulatingMode,:) = CoagulationCoefficient(:) - - enddo - - - - !We don't need to remember K12 for all lookuptable sizes!! - !We only need to rember for 1 [#/m3] of each receiver mode - !and then later scale by number concentration in receiver modes - normalizedCoagulationSink(:,:) = 0.0_r8 - - do iCoagulatingMode = 1, numberOfCoagulatingModes - - !Sum the loss for all possible receivers - do iReceiverMode = 1, numberOfCoagulationReceivers - - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of the coagulating mode - - modeIndexReceiver = receiverMode(iReceiverMode) !Index of receiver mode - - do nsiz=1,nBinsTab !aerotab bin sizes - - !Sum up coagulation sink for this coagulating species (for all receiving modes) - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) = & ![m3/#/s] - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] Previous value - + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode - * K12(iReceiverMode, iCoagulatingMode, nsiz) !Coagulation coefficient (m3/#/s) - - end do !Look up table size - end do !receiver modes - end do !coagulator - - - !Calculate additional coagulation sink for mode 1 in such a way that it - !affects coagulationSink but not the lifecycling (directly) otherwise - - !Sum the loss for all possible receivers - normCoagSinkAdd(:) = 0.0_r8 - iCoagulatingMode = 1 - do iReceiverMode = 1, numberOfAddCoagReceivers - modeIndexReceiver = addReceiverMode(iReceiverMode) !Index of additional receiver mode - - do nsiz=1,nBinsTab !aerotab bin sizes - !Sum up coagulation sink for this coagulating species (for all receiving modes) - normCoagSinkAdd(iReceiverMode) = & ![m3/#/s] - normCoagSinkAdd(iReceiverMode) & ![m3/#/s] Previous value - + normnk(modeIndexReceiver, nsiz) & !Normalized size distribution for receiver mode - * CoagCoeffModeAdd(iReceiverMode, nsiz) !Koagulation coefficient (m3/#/s) - end do !Look up table size - end do !receiver modes - !ak- - - nsiz=1 - do while (rBinMidPoint(nsiz).lt.rcoagdroplet.and.nsiz.lt.nBinsTab) - nsiz=nsiz+1 - end do - - if (abs(rBinMidPoint(nsiz-1)-rcoagdroplet).lt.abs(rBinMidPoint(nsiz)-rcoagdroplet)) then - tableindexcloud=nsiz-1 - else - tableindexcloud=nsiz - end if - write(iulog,*) 'Assumed droplet size and table bin number for cloud & - coagulation ',rcoagdroplet, ' nbin ',tableindexcloud,'binmid',rBinMidPoint(tableindexcloud) - - do iCoagulatingMode = 1, numberOfCoagulatingModes - modeIndexCoagulator = coagulatingMode(iCoagulatingMode) !Index of the coagulating mode - - NCloudCoagulationSink(modeIndexCoagulator) = & ![m3/#/s] - K12Cl(iCoagulatingMode, tableindexcloud) !Koagulation coefficient (m3/#/s) - end do - - end subroutine initializeCoagulationCoefficients - - !================================================================ - subroutine calculateCoagulationCoefficient(CoagulationCoefficient, modeRadius, modeDensity, receiverDensity) - !Calculates coagulation coefficient for a coagulator mode - !with a given radius with all look-up table modes - - real(r8), intent(in) :: modeRadius ! [m] (?) - real(r8), intent(in) :: modeDensity ! [kg/m3] densityi - real(r8), intent(in) :: receiverDensity ! [kg/m3] density of receiver - real(r8), intent(out), dimension(:) :: coagulationCoefficient ![m3/s] - - integer :: i !Counter for look-up tables - - real(r8) :: diff1 ![m2/s] diffusivity - real(r8) :: diff2 ![m2/s] diffusivity - real(r8) :: g12 ![-] factor - real(r8) :: g1 ![-] factor - real(r8) :: g2 ![-] factor - real(r8) :: c12 ![m/s] average particle thermal velocity - real(r8) :: c1 ![m/s] particle thermal velocity - real(r8) :: c2 ![m/s] particle thermal velocity - real(r8) :: mfv1 ![m] mean free path particle - real(r8) :: mfv2 ![m] mean free path particle - - ! coagulation coefficient for SO4 (Brownian, Fuchs form) - !Loop through indexes in look-up table - do i=1,nBinsTab - c1=calculateThermalVelocity(rBinMidPoint(i), receiverDensity) !receiving size - c2=calculateThermalVelocity(modeRadius, modeDensity) !coagulating aerosol - c12=sqrt(c1**2+c2**2) - - diff1 = calculateParticleDiffusivity(rBinMidPoint(i)) !receiving particle - diff2 = calculateParticleDiffusivity(modeRadius) !coagulating particle - - mfv1=calculateMeanFreePath(diff1,c1) !receiving particle - mfv2=calculateMeanFreePath(diff2,c2) !coagulating particle - - g1 = calculateGFactor(rBinMidPoint(i), mfv1) - g2 = calculateGFactor(modeRadius, mfv2) - - g12=sqrt(g1**2+g2**2) - - !Coagulation coefficient of receiver size "i" with the coagulating - !mode "kcomp" - CoagulationCoefficient(i) = & - 4.0_r8*pi*(rBinMidPoint(i)+modeRadius)*(diff1+diff2) & - /((rBinMidPoint(i)+modeRadius)/(rBinMidPoint(i)+modeRadius+g12) & - +(4.0_r8/c12)*(diff1+diff2)/(modeRadius+rBinMidPoint(i))) - - enddo ! loop on imax - end subroutine calculateCoagulationCoefficient - - !================================================================ - subroutine coagtend( q, pmid, pdel, temperature, delt_inverse, ncol , lchnk) - ! Time step routine for coagulation - called from chemistry - ! Calculate the coagulation of small aerosols with larger particles and - ! cloud droplets. Only particles smaller that dry radius of - ! 40 nm is assumed to have an efficient coagulation with other particles. - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only : pcols, pver - use cam_history, only: outfld - use oslo_aero_share - use oslo_aero_const - use physics_buffer, only : physics_buffer_desc - - ! input arguments - integer, intent(in) :: ncol ! number of horizontal grid cells (columns) - real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure - real(r8), intent(in) :: pdel(pcols,pver) - real(r8), intent(in) :: temperature(pcols,pver) ! [K] temperature - real(r8), intent(in) :: delt_inverse ! [1/s] inverse time step - integer, intent(in) :: lchnk ! [] chnk id needed for output - ! local - integer :: k ! level counter - integer :: i ! horizontal counter - integer :: m ! Species counter - integer :: iCoagulator !counter for species coagulating - integer :: iReceiver !counter for species receiving coagulate - integer :: iSpecie !counter for species in mode - integer :: nsiz !loop up table size - integer :: l_index_receiver - integer :: l_index_donor - integer :: modeIndexCoagulator !Index of coagulating mode - integer :: modeIndexReceiver !Index of receiving mode - real(r8) :: rhoAir ![kg/m3] air density - real(r8) :: coagulationSink ![1/s] loss for coagulating specie - real(r8), dimension(numberOfCoagulationReceivers):: numberConcentration ![#/m3] number concentration - real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost - character(128) :: long_name ![-] needed for diagnostics - real(r8), pointer :: fldcw(:,:) - real(r8), dimension(pcols, gas_pcnst) :: coltend - real(r8), dimension(pcols) :: tracer_coltend - logical :: history_aerosol - - - totalLoss(:,:,:)=0.0_r8 - - - call phys_getopts(history_aerosol_out = history_aerosol) - - do k=1,pver - do i=1,ncol - - !Air density - rhoAir = pmid(i,k)/rair/temperature(i,k) - - !Initialize number concentration for all receivers - numberConcentration(:) = 0.0_r8 - - !Go though all modes receiving coagulation - do ireceiver = 1,numberOfCoagulationReceivers - - !Go through all core species in that mode - do iSpecie = 1,getNumberOfTracersInMode(receiverMode(ireceiver)) - - !Find the lifecycle-specie receiving the coagulation - l_index_receiver = getTracerIndex(receiverMode(ireceiver) , iSpecie , .true.) - - long_name = solsym(l_index_receiver) !For testing - - - if(.NOT. is_process_mode(l_index_receiver,.true.)) then - !Add up the number concentration of the receiving mode - numberConcentration(iReceiver) = numberConcentration(iReceiver) & !previous value - + q(i,k,l_index_receiver) & !kg/kg - / rhopart(physicsIndex(l_index_receiver)) & !*[m3/kg] ==> m3/kg - * volumeToNumber(receiverMode(ireceiver)) & ![#/m3] ==> #/kg - * rhoAir !#/kg ==> #/m3 - end if - end do !Lifecycle "core" species in this mode - enddo - - - !Go through all coagulating modes - do iCoagulator = 1, numberOfCoagulatingModes - - !Initialize loss (for a coagulator) summed over all receivers - coagulationSink = 0.0_r8 - - modeIndexCoagulator = coagulatingMode(iCoagulator) - - !Sum the loss for all possible receivers - do iReceiver = 1, numberOfCoagulationReceivers - - modeIndexReceiver = receiverMode(iReceiver) - - !Sum up coagulation sink for this coagulating species (for all receiving modes) - coagulationSink = & ![1/s] - coagulationSink + & ![1/] previous value - normalizedCoagulationSink(modeIndexReceiver, modeIndexCoagulator) & ![m3/#/s] - * numberConcentration(ireceiver) !numberConcentration (#/m3) - end do !receiver modes - - !SOME LIFECYCLE SPECIES CHANGE "HOST MODE" WHEN THEY PARTICIPATE - !IN COAGULATION (THEY GO FROM EXTERNALLY MIXED TO INTERNALLY MIXED MODES) - - !Each coagulating mode can contain several species - do ispecie = 1, getNumberOfTracersInMode(modeIndexCoagulator) - - !Get the lifecycle specie which is lost - l_index_donor = getTracerIndex(modeIndexCoagulator , ispecie,.true. ) - - !Move lifecycle species to new lifecycle species due to coagulation - - !process modes don't change mode except so4 condensate which becomes coagulate instead - !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT - if( .NOT. is_process_mode(l_index_donor,.true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then - - !Done summing total loss of this coagulating specie - totalLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers - * q(i,k,l_index_donor) & !* mixing ratio ==> MMR/s - / delt_inverse ! seconds ==> MMR - - !Can not loose more than we have - totalLoss(i,k,l_index_donor) = min(totalLoss(i,k,l_index_donor) , q(i,k,l_index_donor)) - - - end if !check on process modes - end do !species in mode - - end do !coagulator mode - end do ! i - end do ! k - - - !UPDATE THE TRACERS AND DO DIAGNOSTICS - do iCoagulator = 1, numberOfCoagulatingModes - do ispecie = 1, getNumberOfTracersInMode(coagulatingMode(iCoagulator)) - - l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie ,.true.) - - !so4_a1 is a process mode (condensate), but is still lost in coagulation - if( .NOT. is_process_mode(l_index_donor, .true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then - - l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie,.true. ) - - !index of mode gaining mass (l_so4_ac, l_om_ac, l_bc_ac), coagulate - l_index_receiver = lifeCycleReceiver(l_index_donor) - - do k=1,pver - !Loose mass from tracer in donor mode - q(:ncol,k,l_index_donor) = q(:ncol,k,l_index_donor) - totalLoss(:ncol,k,l_index_donor) - - !Give mass to tracer in receiver mode - q(:ncol,k,l_index_receiver) = q(:ncol,k,l_index_receiver) + totalLoss(:ncol,k,l_index_donor) - end do !k - endif - end do - end do - - !Output for diagnostics - if(history_aerosol)then - coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst - !Check if species contributes to coagulation - if(lifeCycleReceiver(i) .gt. 0)then - !Loss from the donor specie - tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse - coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor - coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) - endif - end do - do i=1,gas_pcnst - if(lifeCycleReceiver(i) .gt. 0)then - long_name= trim(solsym(i))//"coagTend" - call outfld(long_name, coltend(:ncol,i), pcols, lchnk) - long_name= trim(solsym(lifeCycleReceiver(i)))//"coagTend" - call outfld(long_name, coltend(:ncol,lifeCycleReceiver(i)),pcols,lchnk) - end if - end do - endif - end subroutine coagtend - - !================================================================ - subroutine clcoag( q, pmid, pdel, temperature, cldnum, cldfrc, delt_inverse, ncol , lchnk, im, pbuf) - ! Calculate the coagulation of small aerosols with larger particles and - ! cloud droplets. Only particles smaller that dry radius of - ! 40 nm is assumed to have an efficient coagulation with other particles. - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver - use physics_buffer, only: physics_buffer_desc - use cam_history, only: outfld - ! - use oslo_aero_share - use oslo_aero_const - - ! input arguments - integer , intent(in) :: ncol ! number of horizontal grid cells (columns) - real(r8) , intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8) , intent(in) :: pmid(pcols,pver) ! [Pa] midpoint pressure - real(r8) , intent(in) :: pdel(pcols,pver) - real(r8) , intent(in) :: temperature(pcols,pver) ! [K] temperature - real(r8) , intent(in) :: cldnum(ncol,pver) ! Droplet concentration #/kg - real(r8) , intent(in) :: cldfrc(ncol,pver) ! Cloud volume fraction - real(r8) , intent(in) :: delt_inverse ! [1/s] inverse time step - integer , intent(in) :: lchnk ! [] chnk id needed for output - integer , intent(in) :: im - type(physics_buffer_desc), pointer :: pbuf(:) - - ! local - integer :: k ! level counter - integer :: i ! horizontal counter - integer :: m ! Species counter - integer :: iCoagulator !counter for species coagulating - integer :: iReceiver !counter for species receiving coagulate - integer :: iSpecie !counter for species in mode - integer :: nsiz !loop up table size - integer :: l_index_receiver - integer :: l_index_donor - integer :: modeIndexCoagulator !Index of coagulating mode - integer :: modeIndexReceiver !Index of receiving mode - real(r8) :: coagulationSink ![1/s] loss for coagulating specie - real(r8) :: cloudLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost - character(128) :: long_name ![-] needed for diagnostics - real(r8) :: rhoAir ![kg/m3] air density - real(r8), pointer :: fldcw(:,:) - real(r8) :: coltend(pcols, gas_pcnst) - real(r8) :: tracer_coltend(pcols) - logical :: history_aerosol - - call phys_getopts(history_aerosol_out = history_aerosol) - - cloudLoss(:,:,:)=0.0_r8 - do k=1,pver - do i=1,ncol - if (cldfrc(i,k).gt.1.e-2) then - rhoAir = pmid(i,k)/rair/temperature(i,k) - !Go through all coagulating modes - do iCoagulator = 1, numberOfCoagulatingModes - - !Initialize loss (for a coagulator) summed over all receivers - coagulationSink = 0.0_r8 - - modeIndexCoagulator = coagulatingMode(iCoagulator) - - !Receiver for cloud coagulation is water droplets so do not need - !go through the coagulation receivers. - - !Sum up coagulation sink for this coagulating species (for all receiving modes) - coagulationSink = & ![1/s] - NCloudCoagulationSink(modeIndexCoagulator) & ![m3/#/s] - * (rhoair*cldnum(i,k)/cldfrc(i,k)) ![kg/m3*#/kg - - !Each coagulating mode can contain several species - do ispecie = 1, getNumberOfTracersInMode(modeIndexCoagulator) - - !Get the lifecycle specie which is lost - l_index_donor = getTracerIndex(modeIndexCoagulator , ispecie,.true. ) - - !Move lifecycle species to new lifecycle species due to coagulation - - !process modes don't change mode except so4 condensate which becomes coagulate instead - !assumed to have same sink as MODE_IDX_OMBC_INTMIX_AIT - if( .NOT. is_process_mode(l_index_donor,.true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. modeIndexCoagulator .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then - - !Done summing total loss of this coagulating specie - cloudLoss(i,k,l_index_donor) = coagulationSink & !loss rate for a mode in [1/s] summed over all receivers - * cldfrc(i,k)*q(i,k,l_index_donor) & !* mixing ratio ==> MMR/s - / delt_inverse ! seconds ==> MMR - - !Can not loose more than we have - ! At present day assumed lost within the cloud - cloudLoss(i,k,l_index_donor) = min(cloudLoss(i,k,l_index_donor) , cldfrc(i,k)*q(i,k,l_index_donor)) - - - end if !check on process modes - end do !species in mode - - end do !coagulator mode - end if ! cldfrc .gt. 0.01 - end do ! i - end do ! k - - !UPDATE THE TRACERS AND DO DIAGNOSTICS - do iCoagulator = 1, numberOfCoagulatingModes - do ispecie = 1, getNumberOfTracersInMode(coagulatingMode(iCoagulator)) - l_index_donor = getTracerIndex(coagulatingMode(iCoagulator) , ispecie ,.true.) - - !so4_a1 is a process mode (condensate), but is still lost in coagulation - if( .NOT. is_process_mode(l_index_donor, .true.) & - .OR. ( (l_index_donor.eq.chemistryIndex(l_so4_a1)) .AND. coagulatingMode(iCoagulator) & - .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) ) then - - l_index_donor = getTracerIndex(coagulatingMode(iCoagulator), ispecie, .true.) - - !index of mode gaining mass (l_so4_a2, l_om_ac, l_bc_ac), coagulate - l_index_receiver = CloudAerReceiver(l_index_donor) - fldcw => qqcw_get_field(pbuf, CloudAerReceiver(l_index_donor)+im) - - do k=1,pver - !Loose mass from tracer in donor mode - q(:ncol,k,l_index_donor) = q(:ncol,k,l_index_donor) - cloudLoss(:ncol,k,l_index_donor) - - !Give mass to tracer in receiver mode - if(associated(fldcw)) then - fldcw(:ncol,k) = fldcw(:ncol,k) + cloudLoss(:ncol,k,l_index_donor) - end if - end do !k - endif - end do - end do - - !Output for diagnostics - if(history_aerosol)then - coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst - !Check if species contributes to coagulation - if(CloudAerReceiver(i) .gt. 0)then - !Loss from the donor specie - tracer_coltend(:ncol) = sum(cloudLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit*delt_inverse - - coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative, loss for donor - coltend(:ncol,CloudAerReceiver(i)) = coltend(:ncol,CloudAerReceiver(i)) + tracer_coltend(:ncol) - endif - end do - do i=1,gas_pcnst - if(CloudAerReceiver(i) .gt. 0)then - long_name= trim(solsym(i))//"clcoagTend" - call outfld(long_name, coltend(:ncol,i), pcols, lchnk) - long_name= trim(solsym(CloudAerReceiver(i)))//"_OCWclcoagTend" - call outfld(long_name, coltend(:ncol,CloudAerReceiver(i)),pcols,lchnk) - end if - end do - endif - end subroutine clcoag - - !================================================================ - function calculateThermalVelocity(radius, density) result(thermalVelocity) - real(r8), intent(in) :: radius ![m] - real(r8), intent(in) :: density ![kg/m3] - real(r8) :: thermalVelocity ![m/s] - - !Formula for "c1" in Seinfeld & Pandis, table 12.1 - thermalVelocity = sqrt(8.0_r8*kboltzmann*temperatureLookupTables/pi/pi/((4.0_r8/3.0_r8)*density*radius**3)) - end function calculateThermalVelocity - - !================================================================ - function calculateParticleDiffusivity(radius) result (diffusivity) - real(r8), intent(in) :: radius ![m] particle radius - - real(r8) :: knudsenNumber ![-] knudsen number - real(r8) :: diffusivity ![m2/s] diffusivity - real(r8) :: factor - real(r8) :: numerator, nominator - - !Solve eqn for diffusivity in Seinfeld/Pandis, table 12.1 - knudsenNumber = mfpAir/radius - factor = (kboltzmann*temperatureLookupTables/3.0_r8/pi/viscosityAir/2.0_r8/radius) - numerator = 5.0_r8 + 4.0_r8*knudsenNumber + 6.0_r8*knudsenNumber**2 + 18.0_r8*knudsenNumber**3 - nominator = 5.0_r8 - knudsenNumber + (8.0_r8 + pi)*knudsenNumber**2 - diffusivity = factor*numerator/nominator - end function calculateParticleDiffusivity - - !================================================================ - function calculateMeanFreePath(diffusivity,thermalVelocity) result(MeanFreePath) - real(r8) :: diffusivity ![m2/s] - real(r8) :: thermalVelocity ![m/s] - real(r8) :: meanFreePath ![m] - - meanFreePath = 8.0_r8*diffusivity/(pi*thermalVelocity) - end function calculateMeanFreePath - - !================================================================ - function calculateGFactor(radius, meanFreePath) result(g) - real(r8) :: radius ![m] - real(r8) :: meanFreePath ![m] - real(r8) :: g - - g = ((2.0_r8*radius+meanFreePath)**3 & - -(4.0_r8*radius**2+meanFreePath**2)**1.5_r8) & - /(6.0_r8*radius*meanFreePath) & - -2.0_r8*radius - end function calculateGFactor - -end module oslo_aero_coag diff --git a/src/chemistry/oslo_aero/oslo_aero_conc.F90 b/src/chemistry/oslo_aero/oslo_aero_conc.F90 deleted file mode 100644 index 4904bb9a52..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_conc.F90 +++ /dev/null @@ -1,790 +0,0 @@ -module oslo_aero_conc - - ! Calculate concentrations of aerosol modes based on lifecycle species - - use shr_kind_mod , only: r8 => shr_kind_r8 - use ppgrid , only: pcols, pver - use physconst , only: density_water =>rhoh2o, molecularWeightWater=>mwh2o, pi - use constituents , only: pcnst, cnst_name - ! - use oslo_aero_logn_tables, only: intlog1to3_sub, intlog4_sub, intlog5to10_sub, initlogn - use oslo_aero_utils, only: calculateNumberConcentration - use oslo_aero_coag, only: normalizedCoagulationSink - use oslo_aero_condtend, only: normalizedCondensationSink, COND_VAP_H2SO4, COND_VAP_ORG_SV - use oslo_aero_const, only: smallNumber, volumeToNumber,smallNumber - use oslo_aero_params - use oslo_aero_share - - implicit none - private - - public :: oslo_aero_conc_calc - public :: calculateBulkProperties - public :: partitionMass - - private :: getAerosolMask - private :: calculateHygroscopicity - private :: addModeHygroscopicity - private :: doLognormalInterpolation - private :: modalapp2d - - ! Size of molecule-layer which defines when particles are coated - real(r8), parameter :: coatingLimit = 2.e-9_r8 ![m] - - ! The fraction of soluble material required in a components before it!will add to any coating - real(r8), parameter :: solubleMassFractionCoatingLimit=0.50_r8 - real(r8), parameter :: aThird = 1.0_r8/3.0_r8 - real(r8), parameter :: ln10 = log(10.0_r8) - - logical :: init_logn_tables = .false. - -contains - - !******************************************************************************************** - subroutine oslo_aero_conc_calc(ncol, mmr, rho_air, CProcessModes, & - f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & - numberConcentration, volumeConcentration, hygroscopicity, lnsigma, hasAerosol, volumeCore, volumeCoat) - - !---------------------------------------------- - ! Calculate concentrations of aerosol modes based on lifecycle species - !---------------------------------------------- - - ! arguments - integer, intent(in) :: ncol ! Number of columns used in chunk - real(r8), intent(in) :: mmr(pcols,pver,pcnst) ! [kg/kg] mass mixing ratio of tracers - real(r8), intent(in) :: rho_air(pcols,pver) ! [kg/m3] air density - logical, intent(out) :: hasAerosol(pcols, pver, nmodes) ! [t/f] do we have this type of aerosol here? - real(r8), intent(out) :: f_acm(pcols,pver, nbmodes) ! [frc] carbon fraction in mode - real(r8), intent(out) :: f_bcm(pcols,pver, nbmodes) ! [frc] fraction of c being bc - real(r8), intent(out) :: f_aqm(pcols, pver, nbmodes) ! [frc] fraction of sulfate being aquous - real(r8), intent(out) :: f_so4_condm(pcols, pver, nbmodes) ! [frc] fraction of non-aquous SO4 being condensate - real(r8), intent(out) :: f_soam(pcols, pver, nbmodes) ! Needed in "get component fraction" - real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ! [#/m3] number concentraiton - real(r8), intent(out) :: volumeConcentration(pcols,pver,nmodes) ! [m3/m3] volume concentration - real(r8), intent(out) :: hygroscopicity(pcols,pver,nmodes) ! [mol_{aer}/mol_{water}] hygroscopicity - real(r8), intent(out) :: lnsigma(pcols,pver,nmodes) ! [-] log(base e) sigma - real(r8), intent(out) :: CProcessModes(pcols,pver) - real(r8), intent(out) :: cam(pcols,pver,nbmodes) - real(r8), intent(out) :: f_c(pcols, pver) - real(r8), intent(out) :: f_aq(pcols,pver) - real(r8), intent(out) :: f_bc(pcols,pver) - real(r8), intent(out) :: f_so4_cond(pcols,pver) - real(r8), intent(out) :: f_soa(pcols,pver) - real(r8), intent(out) :: volumeCore(pcols,pver,nmodes) - real(r8), intent(out) :: volumeCoat(pcols,pver,nmodes) - - ! local variables - real(r8) :: f_aitbc(pcols,pver) ! [-] bc fraction in the coated bc-oc mode - real(r8) :: f_nbc(pcols,pver) ! [-] mass fraction of bc in uncoated bc/oc mode - real(r8) :: f_soana(pcols,pver) ! [-] - - !Get mass, number concentration and the total add-ons (previous convaer) - call calculateBulkProperties(ncol, mmr, rho_air, numberConcentration, CProcessModes, & - f_c, f_bc, f_aq, f_so4_cond, f_soa, f_aitbc, f_nbc, f_soana) - - ! Find the points where we have aerosol (number concentration) - call getAerosolMask(ncol, numberConcentration, hasAerosol) - - ! Find out how much is added per size-mode (modalapp) - call partitionMass( ncol, numberConcentration, CProcessModes, & - f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam) - - ! Calculate they hygroscopicity - call calculateHygroscopicity( ncol, mmr, numberConcentration, rho_air, Cam, & - f_acm, f_bcm, f_aqm, hasAerosol, hygroscopicity, & - volumeConcentration, volumeCore, volumeCoat) - - ! Do the interpolation to new modes - call doLognormalInterpolation(ncol, numberConcentration, hasAerosol, cam, & - volumeConcentration, f_c, f_acm, f_bcm, f_aqm, f_aitbc, lnSigma) - - end subroutine oslo_aero_conc_calc - - !****************************************************************** - subroutine calculateBulkProperties( ncol, qm, rho_air, numberConcentration, CProcessModes, & - f_c, f_bc, f_aq, f_so4_cond, f_soa, f_aitbc, f_nbc, f_soana) - - !---------------------------------------------- - ! Create bulk properties (dependent on tracers, not size modes) - !---------------------------------------------- - - ! arguments - integer , intent(in) :: ncol ! [nbr] number of columns used - real(r8), intent(in) :: qm(pcols,pver,pcnst) ! [kg/kg] mmr for transported tracers - real(r8), intent(in) :: rho_air(pcols,pver) ! [kg/m3] air density - real(r8), intent(out) :: numberConcentration(pcols,pver,0:nmodes) ! [#/m3] aerosol number concentration - real(r8), intent(out) :: f_c(pcols,pver) ![-] mass fraction of process mode being c - real(r8), intent(out) :: f_bc(pcols,pver) ![-] mass fraction of c being bc - real(r8), intent(out) :: f_aq(pcols,pver) ![-] mass fraction of s being aq phase - real(r8), intent(out) :: f_so4_cond(pcols,pver) ![-] mass fraction of non-aq s being condensate - real(r8), intent(out) :: f_soa(pcols,pver) ![-] mass fraction of OM being SOA - real(r8), intent(out) :: f_aitbc(pcols,pver) ![-] mass fraction of bc in bc/oc mixed, coated mode - real(r8), intent(out) :: f_nbc(pcols,pver) ![-] mass fraction of bc in bc/oc mixed, un-coated mode - real(r8), intent(out) :: f_soana(pcols,pver) ![-] mass fraction of soa in background in int mix ait mode (1) - - !Local variables - real(r8) :: totalProcessModes(pcols,pver) ! [kg/kg] Int. mixed (cond./coag./aq.) SO4+BC+OC concentration - real(r8) :: CProcessModes(pcols,pver) ! [kg/m3] Int. mixed (cond./coag./aq.) SO4+BC+OC concentration - integer :: k !counter for layers - - ! Total number concentration per mode - call calculateNumberConcentration(ncol, qm, rho_air, numberConcentration) - - do k=1,pver - - !Total coagulated bc and oc and SO4 (condensate, wet phase and coagulated) (kg/kg) - !internally mixed with background modes - totalProcessModes(:ncol,k) = qm(:ncol,k,l_bc_ac) + qm(:ncol,k,l_om_ac) & - + qm(:ncol,k,l_so4_a1) + qm(:ncol,k,l_so4_a2) + qm(:ncol,k,l_so4_ac) + qm(:ncol,k,l_soa_a1) - - CProcessModes(:ncol,k) = rho_air(:ncol,k)*totalProcessModes(:ncol,k) !==> kg/m3 - - !fraction of process-mode being carbonaceous - f_c(:ncol,k) = min((qm(:ncol,k,l_bc_ac)+qm(:ncol,k,l_om_ac)+qm(:ncol,k,l_soa_a1) )& - /(totalProcessModes(:ncol,k)+smallNumber), 1.0_r8) - - !fraction of "c" being bc (total is oc and bc) - f_bc(:ncol,k) = min(qm(:ncol,k,l_bc_ac)/(qm(:ncol,k,l_bc_ac)+qm(:ncol,k,l_om_ac)+qm(:ncol,k,l_soa_a1)+smallNumber), 1.0_r8) - - !fraction of non-aqeous phase sulphate being condensate - f_so4_cond(:ncol,k) = min(qm(:ncol,k,l_so4_a1)/(qm(:ncol,k,l_so4_a1)+qm(:ncol,k,l_so4_ac)+smallNumber), 1.0_r8) - - !fraction of sulphate being aquous phase (total is condensate + aqeous phase + coagulate) - f_aq(:ncol,k) = min(qm(:ncol,k,l_so4_a2) & - /(qm(:ncol,k,l_so4_a1)+qm(:ncol,k,l_so4_a2)+qm(:ncol,k,l_so4_ac)+smallNumber),1.0_r8) - - !fraction of bc in the sulfate-coated bc/oc mode (total background is bc and oc) - f_aitbc(:ncol,k) = min(qm(:ncol,k,l_bc_ai) / (qm(:ncol,k,l_bc_ai) + qm(:ncol,k,l_om_ai) + smallNumber), 1.0_r8) - - !fraction of bc in the un-coated bc/oc (total is bc and oc) - f_nbc(:ncol,k) = min(qm(:ncol,k,l_bc_ni) / (qm(:ncol,k,l_bc_ni) + qm(:ncol,k,l_om_ni) + smallNumber),1.0_r8) - - !fraction of OM process-mode which is SOA - f_soa(:ncol,k) = min(qm(:ncol,k,l_soa_a1) / (qm(:ncol,k,l_om_ac) + qm(:ncol,k,l_soa_a1) + smallNumber), 1.0_r8) - - !fraction of "background" int-mix (mode 1) which is SOA - f_soana(:ncol,k) = min(qm(:ncol,k,l_soa_na) / (qm(:ncol,k,l_soa_na) + qm(:ncol,k,l_so4_na) + smallNumber), 1.0_r8 ) - - end do !k - - return - end subroutine calculateBulkProperties - - !******************************************************************************** - subroutine partitionMass( ncol, Nnatk, CProcessModes, & - f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam) - - integer , intent(in) :: ncol ! [nbr] number of columns used - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! [#/m3] number concentration - real(r8), intent(in) :: CProcessModes(pcols,pver) ! [kg/m3] total added mass - real(r8), intent(in) :: f_c(pcols,pver) ! [frc] fraction of added mass being c - real(r8), intent(in) :: f_bc(pcols,pver) ! [frc] fraction of c being bc - real(r8), intent(in) :: f_aq(pcols,pver) ! [frc] fraction of SO4 being aq - real(r8), intent(in) :: f_so4_cond(pcols,pver) ! [frc] fraction of SO4 coag+cond being cond - real(r8), intent(in) :: f_soa(pcols,pver) ! [frc] fraction of OM being SOA - real(r8), intent(out) :: cam(pcols, pver, nbmodes) ! [kg/m3] added mass distributed to modes - real(r8), intent(out) :: f_acm(pcols,pver,nbmodes) ! [frc] as f_c per mode - real(r8), intent(out) :: f_bcm(pcols,pver,nbmodes) ! [frc] as f_bc per mode - real(r8), intent(out) :: f_aqm(pcols,pver,nbmodes) ! [frc] as f_aq per mode - real(r8), intent(out) :: f_so4_condm(pcols,pver,nbmodes) ! [frc] fraction of non aq sulfate being coagulate - real(r8), intent(out) :: f_soam(pcols,pver,nbmodes) ! [frc] fraction of OC being SOA - - call modalapp2d(ncol, Nnatk(1,1,1), CProcessModes, & - f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam) - - end subroutine partitionMass - - !************************************************************* - subroutine getAerosolMask(ncol,numberConcentration, hasAerosol) - - ! Find out where we have aerosols - - integer, intent(in) :: ncol !number of columns used - real(r8), intent(in) :: numberConcentration(pcols, pver, 0:nmodes) - logical, intent(out) :: hasAerosol(pcols, pver, nmodes) - integer :: k !counter for levels - integer :: m !counter for modes - - do m=1,nmodes - do k=1,pver - where(numberConcentration(:ncol,k,m) .gt. smallNumber) - hasAerosol(:ncol,k,m)= .true. - elsewhere - hasAerosol(:ncol,k,m) = .false. - end where - end do !levels - end do !modes - - end subroutine getAerosolMask - - !************************************************************* - subroutine calculateHygroscopicity(ncol, mmr, numberConcentration, rho_air, Cam, & - f_acm, f_bcm, f_aqm, hasAerosol, hygroscopicity, volumeConcentration, volumeCore,volumeCoat) - - ! A parameterization of aerosol activation 2. Multiple aerosol types, JGR, vol 105, noD5, pp 6837 - ! http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract - ! Abdul-Razzak and S. Ghan: - - ! arguments - integer , intent(in) :: ncol - real(r8) , intent(in) :: mmr(pcols,pver,pcnst) ! [kg/kg] mass mixing ratios - real(r8) , intent(in) :: numberConcentration(pcols,pver,0:nmodes) ! [#/m3] number concentrations - real(r8) , intent(in) :: rho_air(pcols,pver) ! [kg/m3] air density - real(r8) , intent(in) :: Cam(pcols, pver, nbmodes) ! [kg/m3] total added mass during microphysics - real(r8) , intent(in) :: f_acm(pcols,pver,nbmodes) ! [-] fraction of added mass which is carbon - real(r8) , intent(in) :: f_aqm(pcols,pver,nbmodes) ! [-] fraction of sulfate which is aq. phase - real(r8) , intent(in) :: f_bcm(pcols,pver,nbmodes) ! [-] fraction of C which is bc - logical , intent(in) :: hasAerosol(pcols,pver,nmodes) ! [t/f] do we have aerosols - real(r8) , intent(out) :: hygroscopicity(pcols,pver,nmodes) - real(r8) , intent(out) :: volumeConcentration(pcols,pver,nmodes) - real(r8) , intent(out) :: volumeCore(pcols,pver,nmodes) ![m3] - real(r8) , intent(out) :: volumeCoat(pcols,pver,nmodes) ![m3] - - ! local variables - integer :: kcomp !counter for modes - integer :: l !counter for components - integer :: k !counter for levels - integer :: tracerIndex - integer :: i - real(r8) :: hygroscopicityAvg(pcols,pver) - real(r8) :: hygroscopicityCoat(pcols,pver) - real(r8) :: massConcentrationTracerInMode(pcols,pver) - real(r8) :: averageRadiusCore(pcols,pver) ![m] - real(r8) :: averageRadiusTotal(pcols,pver) ![m] - - ! initialize - hygroscopicity(:,:,:) = 0.0_r8 - volumeConcentration(:,:,:)=0.0_r8 - - do kcomp=1,nmodes - - !Don't do anything if no tracers in mode - if(getNumberOfBackgroundTracersInMode(kcomp) .lt. 1)then - volumeCore(:,:,kcomp)=smallNumber - volumeCoat(:,:,kcomp)=smallNumber - volumeConcentration(:,:,kcomp)=smallNumber - hygroscopicity(:,:,kcomp) = smallNumber - cycle - end if - - hygroscopicityAvg(:,:) = 0.0_r8 - hygroscopicityCoat(:,:) = 0.0_r8 - volumeCore(:,:,kcomp) = 0.0_r8 - volumeCoat(:,:,kcomp) = 0.0_r8 - - !Loop over tracers in mode - do l=1,getNumberOfBackgroundTracersInMode(kcomp) - - tracerIndex = getTracerIndex(kcomp,l,.false.) !get index in physcis space - - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = mmr(:ncol,k,tracerIndex)*rho_air(:ncol,k) - end do - - ! hasAerosol is true if any concentration in this point - call addModeHygroscopicity( ncol, hasAerosol(:,:,kcomp), & - massConcentrationTracerInMode, volumeCore(:,:,kcomp), volumeCoat(:,:,kcomp), & - hygroscopicityAvg, hygroscopicityCoat, tracerIndex) - - end do !background tracers in mode (l) - - !The background modes can have tracer mass added to them - if (kcomp .le. nbmodes)then - - ! added aquous sulfate - if(isTracerInMode(kcomp,l_so4_a2))then - - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*f_aqm(:ncol,k,kcomp) - end do - - ! hasAerosol is true if any concentration in this point - call addModeHygroscopicity( ncol, hasAerosol(:,:,kcomp), & - massConcentrationTracerInMode, volumeCore(:,:,kcomp), volumeCoat(:,:,kcomp), & - hygroscopicityAvg, hygroscopicityCoat, l_so4_a2) - - endif - - ! added condensate/coagulate - ! All modes which have coagulate have also condensate, so it is - ! ok to check for condensate and add the combined mass.. - if (isTracerInMode(kcomp,l_so4_a1))then - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*(1.0_r8 - f_acm(:ncol,k,kcomp))*(1.0_r8 - f_aqm(:ncol,k,kcomp)) - end do - - call addModeHygroscopicity(ncol, hasAerosol(:,:,kcomp), & - massConcentrationTracerInMode, volumeCore(:,:,kcomp), volumeCoat(:,:,kcomp), & - hygroscopicityAvg, hygroscopicityCoat, l_so4_a1) - - endif - - ! Added bc - if (isTracerInMode(kcomp,l_bc_ac))then - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*f_bcm(:ncol,k,kcomp) - end do - - call addModeHygroscopicity( ncol, hasAerosol(:,:,kcomp), & - massConcentrationTracerInMode, volumeCore(:,:,kcomp), volumeCoat(:,:,kcomp), & - hygroscopicityAvg, hygroscopicityCoat, l_bc_ac ) - endif - - ! Added oc (both POM and SOA), then both have the same - ! properties, so add combined mass here. - ! All modes which have condensate also has coagulate, so OK to check - ! for condensate and distribute the sum.. - if (isTracerInMode(kcomp,l_soa_a1))then - do k=1,pver - massConcentrationTracerInMode(:ncol,k) = Cam(:ncol,k,kcomp)*f_acm(:ncol,k,kcomp)*(1.0_r8 -f_bcm(:ncol,k,kcomp)) - end do - - call addModeHygroscopicity( ncol & - , hasAerosol(:,:,kcomp) & !true if any concentration in this point - , massConcentrationTracerInMode & - , volumeCore(:,:,kcomp) & - , volumeCoat(:,:,kcomp) & - , hygroscopicityAvg & - , hygroscopicityCoat & - , l_om_ac & - ) - endif - end if - - !Note: NCAR definitions of molecular weights are kg/kmol. This is used - !inside "addModeHygroscopicity" and here as in molecularWeightWater. SI units are kg/mol, but - !the error cancels out since eqn 4 has Mw_water/Mw_tracer - - do k=1,pver - - !Finally, when the sums are calculated, Apply finally eqn 4 here!! - - where (hasAerosol(:ncol,k,kcomp)) - where(VolumeCoat(:ncol,k,kcomp) .gt. 1.e-30_r8) - !If there is enough soluble material, a coating will be formed: In that case, the - !volume of the aerosol in question is only the volume of the coating! - hygroscopicityCoat(:ncol,k) = molecularWeightWater*hygroscopicityCoat(:ncol,k) & - /( density_water * volumeCoat(:ncol,k,kcomp)) !Note use of volume Coating here - elsewhere - hygroscopicityCoat(:ncol,k) = 1.e-30_r8 - endwhere - !mode total volume: - volumeConcentration(:ncol,k,kcomp) = volumeCore(:ncol,k,kcomp) + volumeCoat(:ncol,k,kcomp) - - !hygroscopicity of mixture (Note use of total volume to get average hygroscopicity) - hygroscopicityAvg(:ncol,k) = molecularWeightWater*hygroscopicityAvg(:ncol,k) & - /(density_water * volumeConcentration(:ncol,k,kcomp)) - - - !Average size of insoluble core (average radius) - averageRadiusCore(:ncol,k) = 0.5_r8*( (volumeCore(:ncol,k,kcomp)) & - / numberConcentration(:ncol,k,kcomp) * (6.0_r8/pi))**athird - - !Average size of total aerosol (average radius) - averageRadiusTotal(:ncol,k) = 0.5_r8*((volumeConcentration(:ncol,k,kcomp)) & - / numberConcentration(:ncol,k,kcomp)*(6.0_r8/pi))**athird - - !do i=1,ncol - ! if(numberConcentration(i,k,kcomp) .gt. 1.e6 .and. kcomp.eq.6 )then - ! print*, "hygro_check",kcomp,numberConcentration(i,k,kcomp), averageRadiusTotal(i,k)*1.e6, averageRadiusCore(i,k)*1.e6 & - ! , hygroscopicityCoat(i,k), hygroscopicityAvg(i,k), (averageRadiusTotal(i,k)-averageRadiusCore(i,k))*1.e9 - ! endif - !end do - - ! use one or the other hygroscopicity based on coating - where ( averageRadiusTotal(:ncol,k) - averageRadiusCore(:ncol,k) .gt. coatingLimit ) - hygroscopicity(:ncol,k,kcomp) = hygroscopicityCoat(:ncol,k) - elsewhere - hygroscopicity(:ncol,k,kcomp) = hygroscopicityAvg(:ncol,k) - endwhere - - elsewhere ! No aerosol - - hygroscopicity(:ncol,k,kcomp) = 1.e-10_r8 - - end where - - end do !levels - - end do !kcomp /modes - - end subroutine calculateHygroscopicity - - !************************************************************************************** - subroutine addModeHygroscopicity (ncol, hasAerosol, massConcentrationTracerInMode, & - volumeCore, volumeCoat, hygroscopicityAvg, hygroscopicityCoat, tracerIndex) - - ! arguments - integer , intent(in) :: ncol - logical , intent(in) :: hasAerosol(pcols,pver) ![bool] true if we have any aerosol here - real(r8) , intent(in) :: massConcentrationTracerInMode(pcols,pver) ![kg/m3] mass concentration in - integer , intent(in) :: tracerIndex !in physics space - real(r8) , intent(inout) :: volumeCore(pcols, pver) !O [m3/m3] volume of insoluble core - real(r8) , intent(inout) :: volumeCoat(pcols, pver) !O [m3/m3] volume of total aerosol - real(r8) , intent(inout) :: hygroscopicityAvg(pcols, pver) !O [-] average hygroscopicity - real(r8) , intent(inout) :: hygroscopicityCoat(pcols, pver) !O [-] average hygroscopicity - - ! local variables - real(r8) :: massFractionInCoating - integer :: k !counter for levels - - ! Only tracers more soluble than 20% can add to the coating volume - if(solubleMassFraction(tracerIndex) .gt. solubleMassFractionCoatingLimit)then - massFractionInCoating = 1.0_r8 !all volume goes to coating - else - massFractionInCoating = 0.0_r8 !zero volume goes to coating - endif - - do k=1,pver - - where(hasAerosol(:ncol,k) .eqv. .true.) - - volumeCore(:ncol,k) = volumeCore(:ncol,k) & - + massConcentrationTracerInMode(:ncol,k)/rhopart(tracerIndex)*(1.0_r8 - massFractionInCoating) - - volumeCoat(:ncol,k) = volumeCoat(:ncol,k) & - + massConcentrationTracerInMode(:ncol,k)/rhopart(tracerIndex)*massFractionInCoating - - !sum up numerator in eqn 4 in Abdul-Razzak et al (average - !hygrocopicity) Note that molecular weight is that of the - !AEROSOL TYPE This is because of some conflict with mozart - !which needs molecular weight of OC tracers to be 12 when - !reading emissions So molecular weight is duplicated, and - !the molecular weight of the TYPE is used here! - - hygroscopicityAvg(:ncol,k) = hygroscopicityAvg(:ncol,k) + & - massConcentrationTracerInMode(:ncol,k)*numberOfIons(tracerIndex)*osmoticCoefficient(tracerIndex) & - *solubleMassFraction(tracerIndex)/aerosol_type_molecular_weight(aerosolType(tracerIndex)) - - !Contribution to hygroscopicity of coating (only if goes to coating) - !sum up numerator in eqn 4 in Abdul-Razzak et al (average hygrocopicity) - !Note that molecular weight is that of the AEROSOL TYPE - !This is because of some conflict with mozart which needs - !molecular weight of OC tracers to be 12 when reading - !emissions So molecular weight is duplicated, and the - !molecular weight of the TYPE is used here! - - hygroscopicityCoat(:ncol,k) = hygroscopicityCoat(:ncol,k) + & - massConcentrationTracerInMode(:ncol,k)*numberOfIons(tracerIndex)*osmoticCoefficient(tracerIndex) & - *solubleMassFraction(tracerIndex)/aerosol_type_molecular_weight(aerosolType(tracerIndex)) & - *massFractionInCoating !Only add to this if mass goes to coating - - elsewhere - - hygroscopicityAvg(:ncol,k) = 1.0e-10_r8 - hygroscopicityCoat(:ncol,k)= 1.0e-10_r8 - - end where - - end do - - end subroutine addModeHygroscopicity - - !**************************************************************** - subroutine doLognormalInterpolation(ncol, numberConcentration, hasAerosol, & - cam, volumeConcentration, f_c, f_acm, f_bcm, f_aqm, f_aitbc, lnSigma) - - ! arguments - integer , intent(in) :: ncol - real(r8) , intent(in) :: volumeConcentration(pcols,pver,nmodes) - logical , intent(in) :: hasAerosol(pcols,pver,nmodes) - real(r8) , intent(in) :: cam(pcols,pver,nbmodes) ![kg/m3] total added mass per mode - real(r8) , intent(in) :: f_c(pcols,pver) ![frc] fraction of carbon in total add-on - real(r8) , intent(in) :: f_acm(pcols,pver,nbmodes) ![frc] fraction of carbon per mode (in add-on) - real(r8) , intent(in) :: f_bcm(pcols,pver,nbmodes) ![frc] fraction of bc in carbon per mode - real(r8) , intent(in) :: f_aqm(pcols,pver,nbmodes) ![frc] fraction of aq in sulfate added - real(r8) , intent(in) :: f_aitbc(pcols,pver) ![frc] fraction of bc in coated bc/oc mode - real(r8) , intent(inout) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration - real(r8) , intent(out) :: lnsigma(pcols,pver,nmodes) ![-] log (base e) of std. dev - - ! local variables - integer :: kcomp - integer :: i,k - real(r8) :: nconccm3(pcols,pver) - real(r8) :: camUg(pcols,pver) - real(r8) :: log10sig(pcols,pver) ! [-] logarithm (base 10) of look up tables - real(r8) :: f_ocm(pcols,pver,4) ! [-] fraction of added mass which is either SOA condensate or OC coagulate - real(r8) :: cxs(pcols,pver,nbmodes) ![ug/m3] NOTE NON-SI UNITS non-allocated mass - real(r8) :: radius_tmp(pcols,pver) ![m] radius in look up tables - - ! Initialize logn tables for interpolation - if (.not. init_logn_tables) then - call initlogn() - init_logn_tables = .true. - end if - - ! total mass not allocated to any mode - ! this is non-zero if the look-up table can not cope with all the add-on mass - ! cxstot(:,:) = 0.0_r8 - - ! calculate fraction of added mass which is either SOA condensate or OC coagulate, - ! which in AeroTab are both treated as condensate for kcomp=1-4 - do kcomp=1,4 - do k=1,pver - do i=1,ncol - f_ocm(i,k,kcomp) = f_acm(i,k,kcomp)*(1.0_r8-f_bcm(i,k,kcomp)) - enddo - enddo - enddo - - ! Go through all "background" size-modes (kcomp=1-10) - do kcomp=1,nbmodes - - camUg(:,:) = cam(:,:,kcomp)*1.e9_r8 - nConccm3(:,:) = 1e-6_r8*numberConcentration(:,:,kcomp) - - ! Calculate growth from knowing added process specific internally mixed mass to each background mode - ! (level sent but not needed, and kcomp not needed for intlog4_sub) - - if ( kcomp .ge. MODE_IDX_SO4SOA_AIT .and. kcomp .le. MODE_IDX_BC_AIT) then ! kcomp=1,2 - - do k=1,pver - call intlog1to3_sub( & - ncol, & !I number of points - kcomp, & !I [idx] mode index - camUg(:,k), & !I [ug/m3] mass concentration - nConccm3(:,k), & !I [#/cm3] number concentration - f_ocm(:,k,kcomp), & !I [frc] mass fraction which is SOA cond. or OC coag. - cxs(:,k,kcomp), & !O [ug/m3] mass which did not fit the table - log10sig(:,k), & !O [-]sigma, is later thrown away begause of volume balance - radius_tmp(:,k) & !O [m] Number median radius - ) - end do !loop on levels - - else if (kcomp .eq. MODE_IDX_OMBC_INTMIX_COAT_AIT) then ! kcomp=4 - - do k=1,pver - call intlog4_sub( & - ncol, & !I [nbr] number of points - kcomp, & !I [idx] mode index - camUg(:,k), & !I [ug/m3] mass concentration - nConccm3(:,k), & !I [#/cm3] number concentration - f_ocm(:,k,kcomp), & !I [frc] mass fraction which is SOA cond. or OC coag. - f_aqm(:,k,kcomp), & !I [frc] fraction of sulfate which is aquous - cxs(:,k,kcomp), & !O [ug/m3] mass which did not fit the table - log10sig(:,k), & !O [-]sigma, is later thrown away begause of volume balance - radius_tmp(:,k) & !O [m] Number median radius - ) - end do - - else if (kcomp .ge. MODE_IDX_SO4_AC .and. kcomp .le. MODE_IDX_SS_A3)then ! kcomp=5-10 - - do k=1,pver - call intlog5to10_sub( & - ncol, & !I [nbr] number of points used - kcomp, & !I [mode index] - camUg(:,k), & !I [ug/m3] mass concentration - nConccm3(:,k), & !I [#/cm3] number concentration - f_acm(:,k,kcomp), & !I [frc] fraction of aerosol which is carbon - f_bcm(:,k,kcomp), & !I [frc] fraction of carbon which is bc - f_aqm(:,k,kcomp), & !I [frc] fraction of sulfate which is aquous - cxs(:,k,kcomp), & !O [ug/m3] mass which did not fit the table (not given to any mode) - log10sig(:,k), & !O logarithm (base 10) sigma, is later thrown away begause of volume balance - radius_tmp(:,k) & !O [m] Number median radius - ) - end do ! k - - endif - - !initialize - lnsigma(:,:,kcomp) = log(2.0_r8) - - !The whole point of the interpolation routines is to get the new sigma ==> so trust the sigma - - !This means that in order to conserve the volume (which is known), we have to throw away - !the number concentration. Should create a diagnostic or a warning if number concenration is very different - !from the original number concentration since in principal, the number concentration is - !also conserved! - do k=1,pver - !Don't change number concentration unless "hasAerosol" is true - where(hasAerosol(:ncol,k,kcomp)) - - lnsigma(:ncol,k,kcomp) = ln10*log10sig(:ncol,k) - - numberConcentration(:ncol,k,kcomp) = volumeConcentration(:ncol,k,kcomp)*6.0_r8/pi & - /(2.0_r8*radius_tmp(:ncol,k))**3 & - *DEXP(-4.5_r8*lnsigma(:ncol,k,kcomp)*lnsigma(:ncol,k,kcomp)) - - !==> Now we have a set of n, vol, sigma which is consistent and gives back whatever the - !lookup tables told us! If the look up tables were conserving volume we didn't have to do - !the step just above!! - - !Sum up all mass which was not added to any mode (mass exceeding the max limit in the look-up tables) - !cxstot(:ncol,k) = cxstot(:ncol,k) + cxs(:ncol,k,kcomp)*1.e-9_r8 ! ug/m3 ==> kg/m3 - - end where - end do - - end do !kcomp - - !The modes which do not have any added aerosol: - do kcomp=nbmodes+1,nmodes - do k=1,pver - lnsigma(:ncol,k,kcomp) = log(originalSigma(kcomp)) - end do - end do - - !AK (fxm): "unactivated" code below... - !Excessive internally mixed process mass added to the background modes (exceeding the max limit in the look-up tables) - !is instead added to / lumped with the externally mixed non-background modes (kcomp=11,12,14) - !numberConcentration(:,:,MODE_IDX_SO4_NUC) = numberConcentration(:,:,MODE_IDX_SO4_NUC) & - ! + (volumeToNumber(MODE_IDX_SO4_NUC) & !excess sulfate mass is moved to this mode - ! *RESHAPE(cxstot,(/pcols,pver/)) & - ! *(1.0_r8-f_c(:,:))/rhopart(l_so4_n)) - - !numberConcentration(:,:,MODE_IDX_BC_NUC) = numberConcentration(:,:,MODE_IDX_BC_NUC) & - ! + (volumeToNumber(MODE_IDX_BC_NUC) & !excess carbon mass is moved to this mode - ! * RESHAPE(cxstot,(/pcols,pver/)) & - ! * f_c(:,:)/rhopart(l_bc_n)) - - !SKIP LUMPING OF OC-MODE TO MODE MODE_IDX_LUMPED ORGANICS SINCE THIS WILL MESS UP THE HASAEROSOL-MASK! - ! modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) = efact_omn & !excess OM mass is moved to this mode (originally kcomp=13) - ! * (modedefs(i)%Nnatk(MODE_IDX_LUMPED_ORGANICS) + cxstot(i)*modedefs(i)%f_c*(1.0_r8-modedefs(i)%f_bc)) - - end subroutine doLognormalInterpolation - - !******************************************************************************************** - subroutine modalapp2d(ncol,Nnatkbg,Ca,f_c,f_bc,f_aq,f_so4_cond,f_soa,Cam,fcm,fbcm,faqm,fso4condm,fsoam) - - ! Calculation of the apportionment of internally mixed SO4, BC and OC - ! mass between the various background mineral and sea-salt modes. - ! Now also Aitken-modes are subject to condensation of H2SO4, and both n and - ! Aitken modes may coagulate onto the mineral/sea-salt background aerosol. - ! SOA - ! May 2013: The SO4(Ait) mode now takes into account condensed SOA in addition - ! to H2SO4, but as long as SOA is not allowed to condense on more than one - ! mode, no changes are necessary here. NB: to allow SOA to condense also on - ! the BC(Ait) and/or other modes, change this code accordingly! Without any - ! changes, Cam(pcols,1) = condensed SO4 onto the SO4(ait) mode still. - ! SOA - ! Alf Grini, february 2014 : Added info about units, - ! used values calculated at initialization. - ! changed in-out variables to components of derived data types (modedefs) - ! defined in microphysics_oslo.F90, and corrected for mass balance error - ! for SO4 due to lumping of coagulate and condensate. - - ! Arguments - integer , intent(in) :: ncol ! number of columns used - real(r8), intent(in) :: Nnatkbg(pcols,pver,nbmodes) ! aerosol background mode number concentration #/m3 - real(r8), intent(in) :: Ca(pcols,pver) ! internally mixed mass, tot=SO4+OC+BC - real(r8), intent(in) :: f_c(pcols,pver) ! mass fraction (OC+BC)/tot - real(r8), intent(in) :: f_bc(pcols,pver) ! mass fraction BC/(OC+BC) - real(r8), intent(in) :: f_aq(pcols,pver) ! mass fraction SO4(aq)/SO4 - real(r8), intent(in) :: f_soa(pcols,pver) ! mass fraction SOA/(POM+SOA) - real(r8), intent(in) :: f_so4_cond(pcols,pver) ! mass fraction SO4_COND/(COND+COAG) - real(r8), intent(out) :: Cam(pcols,pver,nbmodes) ! modal internal mass, tot=SO4+BC+OC - real(r8), intent(out) :: fcm(pcols,pver,nbmodes) ! modal mass fraction (OC+BC)/tot - real(r8), intent(out) :: fbcm(pcols,pver,nbmodes) ! modal mass fraction BC/(OC+BC) - real(r8), intent(out) :: faqm(pcols,pver,nbmodes) ! modal mass fraction SO4(aq)/SO4 - real(r8), intent(out) :: fso4condm(pcols,pver,nbmodes) ! modal mass fraction (SO4(cond)/SO4(cond+coag)) - real(r8), intent(out) :: fsoam(pcols,pver,nbmodes) ! modal mass fraction SOA / (POM+SOA) - - ! - ! Local variables - real(r8) condensationSinkSO4(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode - real(r8) condensationSinkOA(pcols,pver,nbmodes) ![1/s] loss rate of cond. vap on any mode - real(r8) coagulationSink(pcols,pver,nbmodes) ![1/s] loss rate of BC through coagulation on any mode - real(r8) aquousPhaseSink(pcols,pver,nbmodes) ![-] fraction of particles available for aq. phase in any mode - - real(r8) sumCondensationSinkSO4(pcols,pver) ![1/s] sum condensation sink to all modes - real(r8) sumCondensationSinkOA(pcols,pver) ![1/s] sum condensation sink to all modes - real(r8) sumCoagulationSink(pcols,pver) ![1/s] sum coagulation sink to all modes - real(r8) sumAquousPhaseSink(pcols,pver) ![1/s] sum aquous phase sink to all modes - - real(r8) fcondkSO4(pcols,pver,nbmodes) - real(r8) fcondkOA(pcols,pver,nbmodes) - real(r8) fcoagk(pcols,pver,nbmodes) - real(r8) faqk(pcols,pver,nbmodes) - - real(r8) cabck(pcols,pver,nbmodes) ![kg/m3] bc distributed to each mode - real(r8) caock(pcols,pver,nbmodes) ![kg/m3] pom coagulate distributed to each mode - real(r8) csoacondsk(pcols,pver,nbmodes) - real(r8) caqsk(pcols,pver,nbmodes) ![kg/m3] aq phase sulfate distributed to each mode - real(r8) cso4condsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode - real(r8) cso4coagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode - real(r8) cso4condcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate condensate distributed to each mode - real(r8) coccondcoagsk(pcols,pver,nbmodes) ![kg/m3] non-aq sulfate coagulate distributed to each mode - - integer :: i !counter for modes - integer :: k !counter for levels - - !Find the sink on any mode (0 is omitted here, WHY??, it does receive matter in oslo_aero_coag/condtend!!)) - !Should either remove it from there or add something to it here! - do i=1,nbmodes - do k=1,pver - condensationSinkSO4(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_H2SO4)*Nnatkbg(:ncol,k,i) - condensationSinkOA(:ncol,k,i) = normalizedCondensationSink(i,COND_VAP_ORG_SV)*Nnatkbg(:ncol,k,i) - coagulationSink(:ncol,k,i) = normalizedCoagulationSink(i,MODE_IDX_BC_NUC)*Nnatkbg(:ncol,k,i) !use a typical coagulator (BC_NUC) - aquousPhaseSink(:ncol,k,i) = numberFractionAvailableAqChem(i)*Nnatkbg(:ncol,k,i) !aq phase sink to this mode - end do - enddo - - !Sum the sinks - sumCondensationSinkSO4(:,:) = 0.0_r8 - sumCondensationSinkOA(:,:) = 0.0_r8 - sumCoagulationSink(:,:) = 0.0_r8 - sumAquousPhaseSink(:,:) = 0.0_r8 - do i=1,nbmodes - do k=1,pver - sumCondensationSinkSO4(:ncol,k) = sumCondensationSinkSO4(:ncol,k) + condensationSinkSO4(:ncol,k,i) - sumCondensationSinkOA(:ncol,k) = sumCondensationSinkOA(:ncol,k) + condensationSinkOA(:ncol,k,i) - sumCoagulationSink(:ncol,k) = sumCoagulationSink(:ncol,k) + coagulationSink(:ncol,k,i) - sumAquousPhaseSink(:ncol,k) = sumAquousPhaseSink(:ncol,k) + aquousPhaseSink(:ncol,k,i) - end do - end do - - ! And finally the contribution from each mode relative to the totals are calculated, - ! assuming that the apportionment of mass for the first iteration (in time) is representative - ! for the whole apportionment process (which is ok for small and moderate masses added): - do i=1,nbmodes - do k=1,pver - !Get the fraction of contribution per process per mode - fcondkSO4(:ncol,k,i)=condensationSinkSO4(:ncol,k,i)/(sumCondensationSinkSO4(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode - fcondkOA(:ncol,k,i)=condensationSinkOA(:ncol,k,i)/(sumCondensationSinkOA(:ncol,k)+1.e-100_r8) !fraction of condensation sink in this mode - fcoagk(:ncol,k,i)=coagulationSink(:ncol,k,i)/(sumCoagulationSink(:ncol,k)+1.e-100_r8) !fraction of coagulation sink in this mode - faqk(:ncol,k,i)=aquousPhaseSink(:ncol,k,i)/(sumAquousPhaseSink(:ncol,k)+1.e-100_r8) !fraction of aquous phase sink in this mode - - !BC coagulate to this mode [kg/m3] - cabck(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*f_bc(:ncol,k)*Ca(:ncol,k) - - !OC coagulate to this mode [kg/m3] - caock(:ncol,k,i)=fcoagk(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*(1.0_r8-f_soa(:ncol,k))*Ca(:ncol,k) - - !SOA condensate to this mode [kg/m3] - csoacondsk(:ncol,k,i) = fcondkOA(:ncol,k,i)*f_c(:ncol,k)*(1.0_r8-f_bc(:ncol,k))*f_soa(:ncol,k)*Ca(:ncol,k) - - !Aquous phase SO4 to this mode [kg/m3] - caqsk(:ncol,k,i)=faqk(:ncol,k,i)*f_aq(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) - - !so4 condensate - cso4condsk(:ncol,k,i)=fcondkSO4(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*f_so4_cond(:ncol,k)*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) - - !soa coagulate - cso4coagsk(:ncol,k,i) = fcoagk(:ncol,k,i)*(1.0_r8-f_aq(:ncol,k))*(1.0_r8-f_so4_cond(:ncol,k))*(1.0_r8-f_c(:ncol,k))*Ca(:ncol,k) ![kg/m3] so4 coagulate - end do - enddo - - !The tables take as input the combined coagulate and condensate (both POM and SOA) - !The activation needs them separately for mass balance! - cso4condcoagsk(:ncol,:,:) = cso4condsk(:ncol,:,:) + cso4coagsk(:ncol,:,:) - coccondcoagsk(:ncol,:,:) = caock(:ncol,:,:) + csoacondsk(:ncol,:,:) - - do i=1,nbmodes - do k=1,pver - Cam(:ncol,k,i)= cabck(:ncol,k,i) & !BC - + coccondcoagsk(:ncol,k,i) & !OM - + caqsk(:ncol,k,i) + cso4condcoagsk(:ncol,k,i) + smallNumber!SO4 ==> !total process mode mass to mode i - - fcm(:ncol,k,i)=(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i))/(Cam(:ncol,k,i)+smallNumber) !fraction of mass being carbon (oc or bc) - fbcm(:ncol,k,i)=cabck(:ncol,k,i)/(cabck(:ncol,k,i)+coccondcoagsk(:ncol,k,i)+smallNumber) !fraction of carbon mass being bc - faqm(:ncol,k,i)=caqsk(:ncol,k,i)/(caqsk(:ncol,k,i)+cso4condcoagsk(:ncol,k,i)+smallNumber) !fraction of sulfate being aq phase - - !Not needed for tables, but for mass balances in activation - fso4condm(:ncol,k,i) = cso4condsk(:ncol,k,i)/(cso4condcoagsk(:ncol,k,i) + smallNumber) !fraction of cond+coag which is coag - fsoam(:ncol,k,i) = csoacondsk(:ncol,k,i)/(coccondcoagsk(:ncol,k,i) + smallNumber) !fraction of OC which is SOA - end do - enddo - - end subroutine modalapp2d - -end module oslo_aero_conc diff --git a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 b/src/chemistry/oslo_aero/oslo_aero_condtend.F90 deleted file mode 100644 index c38cf2bc7e..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_condtend.F90 +++ /dev/null @@ -1,1024 +0,0 @@ -module oslo_aero_condtend - - ! Calculate the sulphate nucleation rate, and condensation rate of - ! aerosols used for parameterising the transfer of externally mixed - ! aitken mode particles into an internal mixture. - ! Note the parameterisation for conversion of externally mixed particles - ! used the h2so4 lifetime onto the particles, and not a given - ! increase in particle radius. Will be improved in future versions of the model - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver, pverp - use phys_control, only: phys_getopts - use chem_mods, only: gas_pcnst - use mo_tracname, only: solsym - use cam_history, only: addfld, add_default, fieldname_len, horiz_only, outfld - use physconst, only: rair, gravit, pi, avogad - use chem_mods, only: adv_mass !molecular weights from mozart - use wv_saturation, only: qsat_water - use m_spc_id, only: id_H2SO4, id_soa_lv - ! - use oslo_aero_coag, only: normalizedCoagulationSink, receiverMode,numberOfCoagulationReceivers - use oslo_aero_coag, only: numberOfAddCoagReceivers,addReceiverMode,normCoagSinkAdd - use constituents, only: pcnst ! h2so4 and soa nucleation (cka) - use oslo_aero_share ! only: MODE_IDX_SO4SOA_AIT, rhopart, l_so4_a1, l_soa_lv, l_so4_na, l_soa_na - use oslo_aero_params ! only: originalNumberMedianRadius - use oslo_aero_const ! only: volumeToNumber - - implicit none - private - - ! public routines - public :: registerCondensation - public :: initializeCondensation - public :: condtend - - ! private routines - private :: aeronucl - private :: appformrate - - integer, parameter, public :: N_COND_VAP = 3 - integer, parameter, public :: COND_VAP_H2SO4 = 1 - integer, parameter, public :: COND_VAP_ORG_LV = 2 - integer, parameter, public :: COND_VAP_ORG_SV = 3 - - real(r8), public :: normalizedCondensationSink(0:nmodes,N_COND_VAP) ! [m3/#/s] condensation sink per particle in mode i - - integer , private :: lifeCycleReceiver(gas_pcnst) ! [-] array of transformation of life cycle tracers - real(r8), private :: stickingCoefficient(0:nmodes,N_COND_VAP) ! [-] stickingCoefficient for H2SO4 on a mode - integer , private :: cond_vap_map(N_COND_VAP) - - ! Assumed number of monolayers - real(r8), parameter, private :: n_so4_monolayers_age = 3.0_r8 - - ! thickness of the so4 monolayers (m) - ! for so4(+nh4), use bi-sulfate mw and 1.77 g/cm3 as in MAM - real(r8), parameter, public :: dr_so4_monolayers_age = n_so4_monolayers_age * 4.76e-10_r8 - -!=============================================================================== -contains -!=============================================================================== - - subroutine registerCondensation() - - ! local variables - integer :: iDonor - integer :: l_donor - integer :: tracerIndex - integer :: mode_index_donor - - !These are the lifecycle-species which receive mass when - !the externally mixed modes receive condensate, - !e.g. the receiver of l_so4_n mass is the tracer l_so4_na - lifeCycleReceiver(:) = -99 - lifeCycleReceiver(chemistryIndex(l_bc_n)) = chemistryIndex(l_bc_a) !create bc int mix from bc in mode 12 - lifeCycleReceiver(chemistryIndex(l_bc_ni)) = chemistryIndex(l_bc_ai) !create bc int mix from bc in mode 14 - lifeCycleReceiver(chemistryIndex(l_om_ni)) = chemistryIndex(l_om_ai) - - !!create om int mix from om in mode 14 - lifeCycleReceiver(chemistryIndex(l_bc_ax)) = chemistryIndex(l_bc_ai) - !!create bc int mix from bc in mode 0. Note Mass is conserved but not number - - !Sticking coeffcients for H2SO4 condensation - !See table 1 in Kirkevag et al (2013) - !http://www.geosci-model-dev.net/6/207/2013/gmd-6-207-2013.html - !Note: In NorESM1, sticking coefficients of the externally mixed modes were - !used for the internally mixed modes in modallapp. In condtend the internally - !mixed modes had sticking coefficient = 1.0 - !This might be correct, but is too confusing, so here just - !assign based on background aerosol and table 1 in Kirkevag et al - stickingCoefficient(:,:) = 1.0_r8 - stickingCoefficient(MODE_IDX_BC_EXT_AC,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_BC_AIT,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_OMBC_INTMIX_COAT_AIT,:) = 0.5_r8 - stickingCoefficient(MODE_IDX_DST_A2,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_DST_A3,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_BC_NUC,:) = 0.3_r8 - stickingCoefficient(MODE_IDX_OMBC_INTMIX_AIT,:) = 0.5_r8 - - end subroutine registerCondensation - - !=============================================================================== - - subroutine initializeCondensation() - - !condensation coefficients: - !Theory: Poling et al, "The properties of gases and liquids" - !5th edition, eqn 11-4-4 - - ! local variables - real(r8), parameter :: aunit = 1.6606e-27_r8 ![kg] Atomic mass unit - real(r8), parameter :: boltz = 1.3806e-23_r8 ![J/K/molec] - real(r8), parameter :: t0 = 273.15_r8 ![K] standard temperature - real(r8), parameter :: p0 = 101325.0_r8 ! [Pa] Standard pressure - real(r8), parameter :: radair = 1.73e-10_r8 ![m] Typical air molecule collision radius - real(r8), parameter :: Mair = 28.97_r8 ![amu/molec] Molecular weight for dry air - !Diffusion volumes for simple molecules [Poling et al], table 11-1 - real(r8), dimension(N_COND_VAP), parameter :: vad = (/51.96_r8, 208.18_r8, 208.18_r8/) ![cm3/mol] - real(r8), parameter :: vadAir = 19.7_r8 ![cm3/mol] - real(r8), parameter :: aThird = 1.0_r8/3.0_r8 - real(r8), parameter :: cm2Tom2 = 1.e-4_r8 !convert from cm2 ==> m2 - - real(r8), dimension(0:100,0:nmodes,N_COND_VAP) :: DiffusionCoefficient ! [m2/s] Diffusion coefficient - character(len=fieldname_len+3) :: fieldname_donor - character(len=fieldname_len+3) :: fieldname_receiver - character(128) :: long_name - character(8) :: unit - - integer :: nsiz !counter for aerotab sizes - integer :: iChem !counter for chemical species - integer :: mode_index_donor !index for mode - integer :: iMode !Counter for mode - integer :: tracerIndex !counter for chem. spec - - logical :: history_aerosol - logical :: isAlreadyOnList(gas_pcnst) - integer :: cond_vap_idx - - real(r8), dimension(N_COND_VAP) :: mfv ![m] mean free path - real(r8), dimension(N_COND_VAP) :: diff ![m2/s] diffusion coefficient for cond. vap - real(r8) :: molecularWeight !amu/molec molecular weight - real(r8) :: Mdual ![molec/amu] 1/M_1 + 1/M_2 - real(r8) :: rho ![kg/m3] density of component in question - real(r8) :: radmol ![m] radius molecule - real(r8), dimension(N_COND_VAP) :: th !thermal velocity - - !Couple the condenseable vapours to chemical species for properties and indexes - cond_vap_map(COND_VAP_H2SO4) = chemistryIndex(l_h2so4) - cond_vap_map(COND_VAP_ORG_LV) = chemistryIndex(l_soa_lv) - cond_vap_map(COND_VAP_ORG_SV) = chemistryIndex(l_soa_sv) - - do cond_vap_idx = 1, N_COND_VAP - - rho = rhopart(physicsIndex(cond_vap_map(cond_vap_idx))) !pick up densities from oslo_aero_share - - molecularWeight=adv_mass(cond_vap_map(cond_vap_idx)) !pick up molecular weights from mozart - - ! https://en.wikipedia.org/wiki/Thermal_velocity - th(cond_vap_idx) = sqrt(8.0_r8*boltz*t0/(pi*molecularweight*aunit)) ! thermal velocity for H2SO4 in air (m/s) - - ! Radius of molecul (straight forward assuming spherical) - radmol=(3.0_r8*molecularWeight*aunit/(4.0_r8*pi*rho))**aThird ! molecule radius - - Mdual=2.0_r8/(1.0_r8/Mair+1.0_r8/molecularWeight) !factor of [1/m_1 + 1_m2] - - ! calculating microphysical parameters from equations in Ch. 8 of Seinfeld & Pandis (1998): - ! mean free path for molec in air (m) - mfv(cond_vap_idx)=1.0_r8/(pi*sqrt(1.0_r8+MolecularWeight/Mair)*(radair+radmol)**2*p0/(boltz*t0)) - - ! Solve eqn 11-4.4 in Poling et al - ! (A bit hard to follow units here, but result in the book is in cm2/s).. - ! so scale by "cm2Tom2" to get m2/sec - diff(cond_vap_idx) = cm2Tom2*0.00143_r8*t0**1.75_r8/((p0/1.0e5_r8)*sqrt(Mdual) & - *(((Vad(cond_vap_idx))**aThird+(Vadair)**aThird)**2)) - end do - - do cond_vap_idx = 1, N_COND_VAP - do imode = 0, nmodes !all modes receive condensation - do nsiz = 1, nBinsTab !aerotab sizes - !Correct for non-continuum effects, formula is from - !Chuang and Penner, Tellus, 1995, sticking coeffient from - !Vignati et al, JGR, 2004 - !fxm: make "diff ==> diff (cond_vap_idx) - DiffusionCoefficient(nsiz,imode,cond_vap_idx) = diff(cond_vap_idx) & !original diffusion coefficient - /( & - rBinMidPoint(nsiz)/(rBinMidPoint(nsiz)+mfv(cond_vap_idx)) & !non-continuum correction factor - +4.0_r8*diff(cond_vap_idx)/(stickingCoefficient(imode,cond_vap_idx)*th(cond_vap_idx)*rBinMidPoint(nsiz)) & - ) - enddo - end do !receiver modes - end do - - normalizedCondensationSink(:,:) = 0.0_r8 - !Find sink per particle in mode "imode" - !Eqn 13 in Kulmala et al, Tellus 53B, 2001, pp 479 - !http://onlinelibrary.wiley.com/doi/10.1034/j.1600-0889.2001.530411.x/abstract - do cond_vap_idx =1, N_COND_VAP - do imode = 0, nmodes - do nsiz = 1, nBinsTab - normalizedCondensationSink(imode,cond_vap_idx) = & - normalizedCondensationSink(imode,cond_vap_idx) & - + 4.0_r8*pi & - * DiffusionCoefficient(nsiz,imode,cond_vap_idx) & ![m2/s] diffusion coefficient - * rBinMidPoint(nsiz) & ![m] look up table radius - * normnk(imode,nsiz) ![frc] - end do - end do - end do - - !Initialize output - call phys_getopts(history_aerosol_out = history_aerosol) - - isAlreadyOnList(:) = .FALSE. - do iChem = 1,gas_pcnst - !Does this tracer have a receiver? If yes: It participate in condensation tendencies - if(lifeCycleReceiver(iChem) .gt. 0)then - unit = "kg/m2/s" - fieldname_donor = trim(solsym(iChem))//"condTend" - fieldname_receiver = trim(solsym(lifeCycleReceiver(iChem)))//"condTend" - if(.not. isAlreadyOnList(lifeCycleReceiver(iChem)))then - call addfld( fieldname_receiver, horiz_only, "A", unit, "condensation tendency" ) - isAlreadyOnList(lifeCycleReceiver(iChem))=.TRUE. - end if - call addfld( fieldname_donor, horiz_only, "A", unit, "condensation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - call add_default( fieldname_donor , 1, ' ') - end if - end if - end do - - !Need to add so4_a1, soa_na, so4_na, soa_a1 also (which are not parts of the donor-receiver stuff) - fieldname_receiver = trim(solsym(chemistryIndex(l_so4_a1)))//"condTend" - call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency") - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - end if - - fieldname_receiver = trim(solsym(chemistryIndex(l_soa_a1)))//"condTend" - call addfld( fieldname_receiver, horiz_only, "A", unit, "condensation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - end if - - fieldname_receiver = trim(solsym(chemistryIndex(l_so4_na)))//"condTend" - call addfld( fieldname_receiver, horiz_only, 'A', unit , "condensation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - end if - - fieldname_receiver = trim(solsym(chemistryIndex(l_soa_na)))//"condTend" - call addfld( fieldname_receiver, horiz_only, 'A', unit, "condensation tendency" ) - if(history_aerosol)then - call add_default( fieldname_receiver, 1, ' ' ) - end if - - end subroutine initializeCondensation - - !=============================================================================== - - subroutine condtend(lchnk, q, cond_vap_gasprod, temperature, & - pmid, pdel, dt, ncol, pblh, zm, qh20) - - ! Calculate the sulphate nucleation rate, and condensation rate of - ! aerosols used for parameterising the transfer of externally mixed - ! aitken mode particles into an internal mixture. - ! Note the parameterisation for conversion of externally mixed particles - ! used the h2so4 lifetime onto the particles, and not a given - ! increase in particle radius. Will be improved in future versions of the model - ! Added input for h2so4 and soa nucleation: soa_lv_gasprod, soa_sv_gasprod, pblh,zm,qh20 (cka) - - ! arguments - integer, intent(in) :: lchnk ! chunk identifier - real(r8), intent(inout) :: q(pcols,pver,gas_pcnst) ! TMR [kg/kg] including moisture - real(r8), intent(in) :: cond_vap_gasprod(pcols,pver,N_COND_VAP) ! TMR [kg/kg/sec]] production rate of H2SO4 (gas prod - aq phase uptake) - real(r8), intent(in) :: temperature(pcols,pver) ! Temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) ! [Pa] pressure at mid point - real(r8), intent(in) :: pdel(pcols,pver) ! [Pa] difference in grid cell - real(r8), intent(in) :: dt ! Time step - integer, intent(in) :: ncol ! number of columns - ! Needed for soa nucleation treatment - real(r8), intent(in) :: pblh(pcols) ! pbl height (m) - real(r8), intent(in) :: zm(pcols,pverp) ! midlayer geopotential height above the surface (m) (pver+1) - real(r8), intent(in) :: qh20(pcols,pver) ! specific humidity (kg/kg) - - ! local - character(len=fieldname_len+3) :: fieldname - integer :: i,k,nsiz - integer :: mode_index_donor ![idx] index of mode donating mass - integer :: mode_index_receiver ![idx] index of mode receiving mass - integer :: tracerIndex - integer :: l_donor - integer :: l_receiver - integer :: iDonor ![idx] counter for externally mixed modes - real(r8) :: condensationSink(0:nmodes, N_COND_VAP) ![1/s] loss rate per mode (mixture) - real(r8) :: condensationSinkFraction(pcols,pver,numberOfExternallyMixedModes,N_COND_VAP) ![frc] - real(r8) :: sumCondensationSink(pcols,pver, N_COND_VAP) ![1/s] sum of condensation sink - real(r8) :: totalLoss(pcols,pver,gas_pcnst) ![kg/kg] tracer lost - real(r8) :: numberConcentration(0:nmodes) ![#/m3] number concentration - real(r8) :: numberConcentrationExtMix(pcols,pver,numberOfExternallyMixedModes) - real(r8) :: coltend(pcols, gas_pcnst) - real(r8) :: tracer_coltend(pcols) - real(r8) :: intermediateConcentration(pcols,pver,N_COND_VAP) - real(r8) :: rhoAir(pcols,pver) ![kg/m3] density of air - - ! Volume of added material from condensate; surface area of core particle; - real(r8) :: volume_shell, area_core,vol_monolayer - real (r8) :: frac_transfer ! Fraction of hydrophobic material converted to an internally mixed mode - logical :: history_aerosol - character(128) :: long_name ! [-] needed for diagnostics - - ! needed for h2so4 and soa nucleation treatment - integer :: modeIndexReceiverCoag ! Index of modes receiving coagulate - integer :: iCoagReceiver ! counter for species receiving coagulate - real(r8) :: coagulationSink(pcols,pver) ! [1/s] coaglation loss for SO4_n and soa_n - real(r8), parameter :: lvocfrac=0.5 ! Fraction of organic oxidation products with low enough - - !volatility to enter nucleation mode particles (1-24 nm) - real(r8) :: soa_lv_forNucleation(pcols,pver) ![kg/kg] soa gas available for nucleation - real(r8) :: gasLost(pcols,pver,N_COND_VAP) ![kg/kg] budget terms on H2SO4 (gas) - real(r8) :: fracNucl(pcols,pver,N_COND_VAP) ![frc] fraction of gas nucleated - real(r8) :: firstOrderLossRateNucl(pcols,pver,N_COND_VAP) ![1/s] first order loss rate due to nucleation - real(r8) :: nuclso4(pcols,pver) ![kg/kg/s] Nucleated so4 mass tendency from RM's parameterization - real(r8) :: nuclsoa(pcols,pver) ![kg/kg/s] Nucleated soa mass tendency from RM's parameterization - integer :: cond_vap_idx - - !Initialize h2so4 and soa nucl variables - coagulationSink(:,:)=0.0_r8 - condensationSinkFraction(:,:,:,:) = 0.0_r8 !Sink to the coming "receiver" of any vapour - numberConcentrationExtMix(:,:,:) = 0.0_r8 - - do k=1,pver - do i=1,ncol - - condensationSink(:,:) = 0.0_r8 !Sink to the coming "receiver" of any vapour - - !NB: The following is duplicated code, coordinate with oslo_aero_coag! - !Initialize number concentration for this receiver - - !Air density - rhoAir(i,k) = pmid(i,k)/rair/temperature(i,k) - - numberConcentration(:) = 0.0_r8 - - !Go though all modes receiving condensation - do mode_index_receiver = 0, nmodes - - !Go through all core species in that mode - do tracerIndex = 1, getNumberOfBackgroundTracersInMode(mode_index_receiver) - - !Find the lifecycle-specie receiving the condensation - l_receiver = getTracerIndex(mode_index_receiver, tracerIndex, .true.) - - !Add up the number concentration of the receiving mode [#/m3] - numberConcentration(mode_index_receiver) = numberConcentration(mode_index_receiver) & !previous value - + q(i,k,l_receiver) & !kg/kg - / rhopart(physicsIndex(l_receiver)) & !m3/kg ==> m3_{aer}/kg_{air} - * volumeToNumber(mode_index_receiver) & !#/m3 ==> #/kg_{air} - * rhoAir(i,k) !kg/m3 ==> #/m3_{air} - end do !Lifecycle "core" species in this mode - enddo - - - !All modes are condensation receivers - do cond_vap_idx=1,N_COND_VAP - do mode_index_receiver = 0, nmodes - - !This is the loss rate a gas molecule will see due to aerosol surface area - condensationSink(mode_index_receiver,cond_vap_idx) = & !==> [1/s] - normalizedCondensationSink(mode_index_receiver,cond_vap_idx) & ![m3/#/s] - * numberConcentration(mode_index_receiver) ![#/m3] - - end do !Loop over receivers - end do - - !Find concentration after condensation of all condenseable vapours - do cond_vap_idx=1,N_COND_VAP - - !sum of cond. sink for this vapour [1/s] - sumCondensationSink(i,k,cond_vap_idx) = sum(condensationSink(:,cond_vap_idx)) - - !Solve the intermediate (end of timestep) concentration using - !euler backward solution C_{old} + P *dt - L*C_{new}*dt = C_{new} ==> - !Cnew -Cold = prod - loss ==> - intermediateConcentration(i,k,cond_vap_idx) = & - ( q(i,k,cond_vap_map(cond_vap_idx)) + cond_vap_gasprod(i,k,cond_vap_idx)*dt ) & - / (1.0_r8 + sumCondensationSink(i,k,cond_vap_idx)*dt) - end do - - !Save the fraction of condensation sink for the externally mixed modes - !(Needed below to find volume shell) - do cond_vap_idx=1,N_COND_VAP - - do iDonor = 1,numberOfExternallyMixedModes - !Find the mode in question - mode_index_donor = externallyMixedMode(iDonor) - - !Remember fraction of cond sink for this mode - condensationSinkFraction(i,k,iDonor,cond_vap_idx) = & - condensationSink(mode_index_donor,cond_vap_idx) / sumCondensationSink(i,k,cond_vap_idx) - - !Remember number concentration in this mode - numberConcentrationExtMix(i,k,iDonor) = numberConcentration(mode_index_donor) - end do - end do - - ! Assume only a fraction of ORG_LV left can contribute to nucleation - ! fraction of soa_lv left that is assumend to have low enough volatility to nucleate. - soa_lv_forNucleation(i,k) = lvocfrac*intermediateConcentration(i,k,COND_VAP_ORG_LV) - - !Sum coagulation sink for nucleated so4 and soa particles over all receivers of coagulate. Needed for RM's nucleation code - !OBS - looks like RM's coagulation sink is multiplied by 10^-12?? - modeIndexReceiverCoag = 0 - do iCoagReceiver = 1, numberOfCoagulationReceivers - - modeIndexReceiverCoag = receiverMode(iCoagReceiver) - - coagulationSink(i,k) = & ![1/s] - coagulationSink(i,k) + & ![1/] previous value - normalizedCoagulationSink(modeIndexReceiverCoag,MODE_IDX_SO4SOA_AIT) & ![m3/#/s] - * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) - end do !coagulation sink - - !Sum coagulation sink for nucleated so4 and soa particles over all additional - !receivers od coagulate (not directly affecting the life-cycle). - do iCoagReceiver = 1, numberOfAddCoagReceivers - - modeIndexReceiverCoag = addReceiverMode(iCoagReceiver) - - coagulationSink(i,k) = & ![1/s] - coagulationSink(i,k) + & ![1/] previous value - normCoagSinkAdd(iCoagReceiver) & ![m3/#/s] - * numberConcentration(modeIndexReceiverCoag) !numberConcentration (#/m3) - end do !coagulation sink - - end do !index i - end do !index k - - !Calculate nucleated masses of so4 and soa (nuclso4, nuclsoa) - !following RM's parameterization (cka) - call aeronucl(lchnk,ncol,temperature, pmid, qh20, & - intermediateConcentration(:,:,COND_VAP_H2SO4), soa_lv_forNucleation, & - coagulationSink, nuclso4, nuclsoa, zm, pblh) - - - firstOrderLossRateNucl(:,:,:)=0.0_r8 - do k=1,pver - do i=1,ncol - - !First order loss rate (1/s) for nucleation - firstOrderLossRateNucl(i,k,COND_VAP_H2SO4) = nuclSo4(i,k)/intermediateConcentration(i,k,COND_VAP_H2SO4) - - !First order loss rate (1/s) for nucleation - firstOrderLossRateNucl(i,k,COND_VAP_ORG_LV) = nuclSOA(i,k)/intermediateConcentration(i,k,COND_VAP_ORG_LV) - - do cond_vap_idx = 1,N_COND_VAP - !Solve implicitly (again) - !C_new - C_old = PROD_{gas} - CS*C_new*dt - LR_{nucl}*C_new => - intermediateConcentration(i,k,cond_vap_idx) = & - ( q(i,k,cond_vap_map(cond_vap_idx)) + cond_vap_gasprod(i,k,cond_vap_idx)*dt ) & - / (1.0_r8 + sumCondensationSink(i,k,cond_vap_idx)*dt + firstOrderLossRateNucl(i,k,cond_vap_idx)*dt) - - !fraction nucleated - fracNucl(i,k,cond_vap_idx) = firstOrderLossRateNucl(i,k,cond_vap_idx) & - /(firstOrderLossRateNucl(i,k,cond_vap_idx) + sumCondensationSink(i,k,cond_vap_idx)) - !From budget, we get: lost = prod -cnew + cold - gasLost(i,k,cond_vap_idx) = cond_vap_gasprod(i,k,cond_vap_idx)*dt & !Produced - + q(i,k,cond_vap_map(cond_vap_idx)) & !cold - - intermediateConcentration(i,k,cond_vap_idx) !cnew - - end do !cond_vap_idx - - !Add nuceated mass to so4_na mode - q(i,k,chemistryIndex(l_so4_na)) = q(i,k,chemistryIndex(l_so4_na)) & - + gasLost(i,k,COND_VAP_H2SO4)*fracNucl(i,k,COND_VAP_H2SO4) - - !H2SO4 condensate - q(i,k,chemistryIndex(l_so4_a1)) = q(i,k,chemistryIndex(l_so4_a1)) & - + gasLost(i,k,COND_VAP_H2SO4)*(1.0_r8-fracNucl(i,k,COND_VAP_H2SO4)) - - !Add nucleated mass to soa_na mode - q(i,k,chemistryIndex(l_soa_na)) = q(i,k,chemistryIndex(l_soa_na)) & - + gasLost(i,k,COND_VAP_ORG_LV)*fracNucl(i,k,COND_VAP_ORG_LV) - - !Organic condensate (from both soa_lv and soa_sv) goes to the soaCondensateReceiver tracer (cka) - q(i,k,chemistryIndex(l_soa_a1)) = q(i,k,chemistryIndex(l_soa_a1)) & - + gasLost(i,k,COND_VAP_ORG_SV) & ! "semi volatile" can not nucleate - + gasLost(i,k,COND_VAP_ORG_LV)*(1.0_r8-fracNucl(i,k,COND_VAP_ORG_LV)) ! part of low volatile which does not nucleate - - !condenseable vapours - q(i,k,chemistryIndex(l_h2so4)) = intermediateConcentration(i,k,COND_VAP_H2SO4) - q(i,k,chemistryIndex(l_soa_lv)) = intermediateConcentration(i,k,COND_VAP_ORG_LV) - q(i,k,chemistryIndex(l_soa_sv)) = intermediateConcentration(i,k,COND_VAP_ORG_SV) - - - !Condensation transfers mass from externally mixed to internally mixed modes - do iDonor = 1,numberOfExternallyMixedModes - - !Find the mode in question - mode_index_donor = externallyMixedMode(iDonor) - - if(getNumberOfTracersInMode(mode_index_donor) .eq. 0)then - cycle - end if - - volume_shell = 0.0_r8 - do cond_vap_idx = 1, N_COND_VAP - - !Add up volume shell for this - !condenseable vapour - volume_shell = volume_shell & - + condensationSinkFraction(i,k,iDonor,cond_vap_idx) & ![frc] - * gasLost(i,k,cond_vap_idx)*(1.0_r8-fracNucl(i,k,cond_vap_idx)) & ![kg/kg] - * invRhoPart(physicsIndex(cond_vap_map(cond_vap_idx))) & !*[m3/kg] ==> [m3/kg_{air} - * rhoAir(i,k) !*[kg/m3] ==> m3/m3 - - end do - - area_core=numberConcentrationExtMix(i,k,iDonor)*numberToSurface(mode_index_donor) !#/m3 * m2/# ==> m2/m3 - vol_monolayer=area_core*dr_so4_monolayers_age - - ! Small fraction retained to avoid numerical irregularities - frac_transfer=min((volume_shell/vol_monolayer),0.999_r8) - - !How many tracers exist in donor mode? - !The "donor" is the externally mixed mode which will soon - !become internally mixed. The externally mixed is donating mass - !and the internally mixed is receiving... - do tracerIndex = 1, getNumberOfTracersInMode(mode_index_donor) - - !Indexes here are in "chemistry space" - l_donor = getTracerIndex(mode_index_donor, tracerIndex,.true.) - l_receiver = lifeCycleReceiver(l_donor) - - if( l_receiver .le. 0)then - stop !something wrong - endif - - !Transfer from donor to receiver takes into account - !fraction transferred - totalLoss(i,k,l_donor) = frac_transfer*q(i,k,l_donor) - q(i,k,l_donor) = q(i,k,l_donor) - totalLoss(i,k,l_donor) - q(i,k,l_receiver) = q(i,k,l_receiver) + totalLoss(i,k,l_donor) - end do !tracers in mode - end do !loop over receivers - end do !physical index k - end do !physical index i - - !Output for diagnostics - call phys_getopts(history_aerosol_out = history_aerosol) - - if(history_aerosol)then - coltend(:ncol,:) = 0.0_r8 - do i=1,gas_pcnst - !Check if species contributes to condensation - if(lifeCycleReceiver(i) .gt. 0)then - !Loss from the donor specie - tracer_coltend(:ncol) = sum(totalLoss(:ncol, :,i)*pdel(:ncol,:),2)/gravit/dt - coltend(:ncol,i) = coltend(:ncol,i) - tracer_coltend(:ncol) !negative (loss for donor) - coltend(:ncol,lifeCycleReceiver(i)) = coltend(:ncol,lifeCycleReceiver(i)) + tracer_coltend(:ncol) - endif - end do - - ! Remove so4_n ---> directly into so4_na - coltend(:ncol,chemistryIndex(l_so4_na)) = coltend(:ncol,chemistryIndex(l_so4_na)) + & - sum( & - gasLost(:ncol,:,COND_VAP_H2SO4) & - *fracNucl(:ncol,:,COND_VAP_H2SO4)*pdel(:ncol,:) , 2 & - )/gravit/dt - - !Take into account H2SO4 (gas) condensed in budget - coltend(:ncol,chemistryIndex(l_so4_a1)) = coltend(:ncol,chemistryIndex(l_so4_a1)) + & - sum( & - gasLost(:ncol,:,COND_VAP_H2SO4) & - *(1.0_r8 - fracNucl(:ncol,:,COND_VAP_H2SO4))*pdel(:ncol,:) , 2 & - )/gravit/dt - - !Take into account soa_lv (gas) nucleated in budget - coltend(:ncol,chemistryIndex(l_soa_na)) = coltend(:ncol,chemistryIndex(l_soa_na)) + & - sum( & - gasLost(:ncol,:,COND_VAP_ORG_LV) & - *fracNucl(:ncol,:,COND_VAP_ORG_LV)*pdel(:ncol,:) , 2 & - )/gravit/dt - - !Take into account soa gas condensed in the budget (both LV and SV) - coltend(:ncol,chemistryIndex(l_soa_a1)) = coltend(:ncol,chemistryIndex(l_soa_a1)) + & - sum( & - gasLost(:ncol,:,COND_VAP_ORG_LV) & - *(1.0_r8 - fracNucl(:ncol,:,COND_VAP_ORG_LV))*pdel(:ncol,:) , 2 & - )/gravit/dt & - + & - sum( & - gasLost(:ncol,:,COND_VAP_ORG_SV)*pdel(:ncol,:) , 2 & - )/gravit/dt - - do i=1,gas_pcnst - if(lifeCycleReceiver(i) .gt. 0 )then - long_name= trim(solsym(i))//"condTend" - call outfld(long_name, coltend(:ncol,i), pcols, lchnk) - long_name= trim(solsym(lifeCycleReceiver(i)))//"condTend" - call outfld(long_name, coltend(:ncol,lifeCycleReceiver(i)),pcols,lchnk) - end if - end do - long_name=trim(solsym(chemistryIndex(l_so4_a1)))//"condTend" - call outfld(long_name, coltend(:ncol,chemistryIndex(l_so4_a1)),pcols,lchnk) - long_name=trim(solsym(chemistryIndex(l_soa_a1)))//"condTend" - call outfld(long_name, coltend(:ncol,chemistryIndex(l_soa_a1)),pcols,lchnk) - long_name=trim(solsym(chemistryIndex(l_so4_na)))//"condTend" - call outfld(long_name, coltend(:ncol,chemistryIndex(l_so4_na)),pcols,lchnk) - long_name=trim(solsym(chemistryIndex(l_soa_na)))//"condTend" - call outfld(long_name, coltend(:ncol,chemistryIndex(l_soa_na)),pcols,lchnk) - - endif - - end subroutine condtend - - !=============================================================================== - - subroutine aeronucl(lchnk, ncol, t, pmid, h2ommr, h2so4pc, oxidorg, coagnuc, nuclso4, nuclorg, zm, pblht) - - ! Subroutine to calculate nucleation (formation) rates of new particles - ! At the moment, the final nucleation rate consists of - ! (1) Binary sulphuric acid-water nucleation in whole atmosphere (Vehkamaki et al., 2002, JGR) - ! JGR, vol 107, No D22, http://onlinelibrary.wiley.com/doi/10.1029/2002JD002184/abstract - ! (2) Boundary-layer nucleation - ! Paasonen et al (2010), ACP, vol 10, pp 11223: http://www.atmos-chem-phys.net/10/11223/2010/acp-10-11223-2010.html - ! (3) First version published ACP (Risto Makkonen) - ! ACP, vol 14, no 10, pp 5127 http://www.atmos-chem-phys.net/14/5127/2014/acp-14-5127-2014.html - ! Modified Spring 2015, cka - - !-- Arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric column - real(r8), intent(in) :: pmid(pcols,pver) ! layer pressure (Pa) - real(r8), intent(in) :: h2ommr(pcols,pver) ! layer specific humidity - real(r8), intent(in) :: t(pcols,pver) ! Temperature (K) - real(r8), intent(in) :: h2so4pc(pcols,pver) ! Sulphuric acid concentration (kg kg-1) - real(r8), intent(in) :: oxidorg(pcols,pver) ! Organic vapour concentration (kg kg-1) - real(r8), intent(in) :: coagnuc(pcols,pver) ! Coagulation sink for nucleating particles [1/s] - real(r8), intent(out) :: nuclorg(pcols,pver) ! Nucleated mass (ORG) - real(r8), intent(out) :: nuclso4(pcols,pver) ! Nucleated mass (H2SO4) - real(r8), intent(in) :: zm(pcols,pver) ! Height at layer midpoints (m) - real(r8), intent(in) :: pblht(pcols) ! Planetary boundary layer height (m) - - !-- Local variables - - real(r8), parameter :: pi=3.141592654_r8 - !cka+ - real(r8), parameter :: gasconst_R=8.314472_r8 ! universal gas constant [J mol-1 K-1] - real(r8), parameter :: h2so4_dens=1841._r8 ! h2so4 density [kg m-3] - real(r8), parameter :: org_dens=2000._r8 ! density of organics [kg m-3], based on RM assumptions - !cka - - - integer :: i,k - real(r8) :: qs(pcols,pver) ! Saturation specific humidity - real(r8) :: relhum(pcols,pver) ! Relative humidity - real(r8) :: h2so4(pcols,pver) ! Sulphuric acid concentration [#/cm3] - real(r8) :: nuclvolume(pcols,pver) ! [m3/m3/s] Nucleated mass (SO4+ORG) - real(r8) :: rhoair(pcols,pver) ! density of air [kg/m3] !cka - real(r8) :: pblht_lim(pcols) ! Planetary boundary layer height (m) (500mzm(i,k) .AND. pbl_nucleation>0) then - - if(pbl_nucleation .EQ. 1) then - - !-- Paasonen et al. (2010), eqn 10, Table 4 - nuclrate_pbl(i,k)=(1.7E-6_r8)*h2so4(i,k) - - else if(pbl_nucleation .EQ. 2) then - - !-- Paasonen et al. (2010) - !values from Table 3 in Paasonen et al (2010), modified version of eqn 14 - nuclrate_pbl(i,k)=(6.1E-7_r8)*h2so4(i,k)+(0.39E-7_r8)*orgforgrowth(i,k) - - end if - - nuclrate_pbl(i,k)=MAX(MIN(nuclrate_pbl(i,k),1.E10_r8),0._r8) - - else !Not using PBL-nucleation - nuclrate_pbl(i,k)=0._r8 - end if - !Size [nm] of particles in PBL - nuclsize_pbl(i,k)=2._r8 - - end do !horizontal points - end do !levels - - !-- Calculate total nucleated mass - do k=1,pver - do i=1,ncol - - ! Molecular speed and growth rate: H2SO4. Eq. 21 in Kerminen and Kulmala 2002 - vmolh2so4=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_h2so4*1.E-3_r8)) - grh2so4(i,k)=(3.E-9_r8/h2so4_dens)*(vmolh2so4*molmass_h2so4*h2so4(i,k)) - grh2so4(i,k)=MAX(MIN(grh2so4(i,k),10000._r8),1.E-10_r8) - - ! Molecular speed and growth rate: ORG. Eq. 21 in Kerminen and Kulmala 2002 - vmolorg=SQRT(8._r8*gasconst_R*t(i,k)/(pi*molmass_soa*1.E-3_r8)) - grorg(i,k)=(3.E-9_r8/org_dens)*(vmolorg*molmass_soa*orgforgrowth(i,k)) - grorg(i,k)=MAX(MIN(grorg(i,k),10000._r8),1.E-10_r8) - - ! Combined growth rate (cka) - gr(i,k)=grh2so4(i,k)+grorg(i,k) - - !-- Lehtinen 2007 parameterization for apparent formation rate - ! diameters in nm, growth rate in nm h-1, coagulation in s-1 - - call appformrate(nuclsize_bin(i,k), d_form*1.E9_r8, nuclrate_bin(i,k), formrate_bin(i,k), coagnuc(i,k), gr(i,k)) - call appformrate(nuclsize_pbl(i,k), d_form*1.E9_r8, nuclrate_pbl(i,k), formrate_pbl(i,k), coagnuc(i,k), gr(i,k)) - - formrate_bin(i,k)=MAX(MIN(formrate_bin(i,k),1.E3_r8),0._r8) - formrate_pbl(i,k)=MAX(MIN(formrate_pbl(i,k),1.E3_r8),0._r8) - - ! Number of mol nucleated per g air per second. - nuclvolume(i,k) = (formrate_bin(i,k) + formrate_pbl(i,k)) & ![particles/cm3] - *1.0e6_r8 & !==> [particles / m3 /] - /volumeToNumber(MODE_IDX_SO4SOA_AIT) & !==> [m3_{aer} / m3_{air} / sec] - / rhoair(i,k) !==> m3_{aer} / kg_{air} /sec - - !Estimate how much is organic based on growth-rate - if(gr(i,k)>1.E-10_r8) then - frach2so4=grh2so4(i,k)/gr(i,k) - else - frach2so4=1._r8 - end if - - ! Nucleated so4 and soa mass mixing ratio per second [kg kg-1 s-1] - ! used density of particle phase, not of condensing gas - nuclso4(i,k)=rhopart(l_so4_na)*nuclvolume(i,k)*frach2so4 - nuclorg(i,k)=rhopart(l_soa_na)*nuclvolume(i,k)*(1.0_r8-frach2so4) - - end do - end do - - !-- Diagnostic output - call outfld('NUCLRATE', nuclrate_bin+nuclrate_pbl, pcols ,lchnk) - call outfld('FORMRATE', formrate_bin+formrate_pbl, pcols ,lchnk) - call outfld('COAGNUCL', coagnuc, pcols ,lchnk) - call outfld('GRH2SO4', grh2so4, pcols ,lchnk) - call outfld('GRSOA', grorg, pcols ,lchnk) - call outfld('GR', gr, pcols ,lchnk) - - return - end subroutine aeronucl - - !=============================================================================== - - subroutine appformrate(d1, dx, j1, jx, CoagS_dx, gr) - !-- appformrate calculates the formation rate jx of dx sized particles from the nucleation rate j1 (d1 sized particles) - !-- Formation rate is parameterized according to Lehtinen et al. (2007), JAS 38:988-994 - !-- Parameterization takes into account the loss of particles due to coagulation - !-- Growth by self-coagulation is not accounted for - !-- Typically, 1% of 1 nm nuclei make it to 12 nm - !-- Written by Risto Makkonen - ! First estimate: 99% of particles are lost during growth from 1 nm to 12 nm - - !-- Arguments - - real(r8), intent(in) :: d1 ! Size of nucleation-sized particles (nm) - real(r8), intent(in) :: dx ! Size of calculated apparent formation rate (nm) - real(r8), intent(in) :: j1 ! Nucleation rate of d1 sized particles (# cm-3 s-1) - real(r8), intent(out) :: jx ! Formation rate of dx sized particles (# cm-3 s-1) - real(r8), intent(in) :: CoagS_dx ! Coagulation term for nucleating particles (s-1) - real(r8), intent(in) :: gr ! Particle growth rate (nm h-1) - - !-- Local variables - - real(r8) :: m - real(r8) :: gamma - real(r8) :: CoagS_d1 ! Coagulation term for nucleating particles, calculated from CoagS_dx - - ! In Hyytiala, typically 80% of the nuclei are scavenged onto larger background particles while they grow from 1 to 3 nm - - !-- (Eq. 6) Exponent m, depends on background distribution - ! m=log(CoagS_dx/CoagS_d1)/log(dx/d1) - ! Or, if we dont want to calculate CoagS_d1, lets assume a typical value for m (-1.5 -- -1.9) and calculate CoagS_d1 from Eq.5 - m=-1.6_r8 - CoagS_d1=CoagS_dx*(d1/dx)**m - CoagS_d1=MAX(MIN(CoagS_d1,1.E2_r8),1.E-10_r8) - - gamma=(1._r8/(m+1._r8))*((dx/d1)**(m+1._r8)-1._r8) - gamma=MAX(MIN(gamma,1.E2_r8),1.E-10_r8) - - !-- (Eq. 7) CoagS_d1 is multiplied with 3600 to get units h-1 - jx=j1*exp(-gamma*d1*CoagS_d1*3600._r8/gr) - - end subroutine appformrate - -end module oslo_aero_condtend diff --git a/src/chemistry/oslo_aero/oslo_aero_const.F90 b/src/chemistry/oslo_aero/oslo_aero_const.F90 deleted file mode 100644 index 12e111eb17..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_const.F90 +++ /dev/null @@ -1,32 +0,0 @@ -module oslo_aero_const - - !----------------------------------------------------------------------------- - ! Module containing oslo_aero constants - !----------------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - use oslo_aero_params, only: nmodes - use physconst, only: pi - ! - implicit none - public - - real(r8), parameter :: smallNumber = 1.e-100_r8 - real(r8), parameter :: rTabMin = 1.e-9_r8 ![m] smallest lookup table size - real(r8), parameter :: rTabMax = 20.e-6_r8 ![m] largest lookup table size - integer, parameter :: nBinsTab = 44 ![nbr] number of tabulated bins - real(r8), parameter :: rMinAquousChemistry = 0.05e-6_r8 ! Smallest particle which can receive aquous chemistry mass - real(r8), parameter :: sq2pi = 1._r8/sqrt(2.0_r8*pi) - - real(r8) :: nk(0:nmodes,nbinsTab) !dN/dlogr for modes - real(r8) :: normnk(0:nmodes,nbinsTab) !dN for modes (sums to one over size range) - real(r8) :: rBinEdge(nBinsTab+1) - real(r8) :: rBinMidpoint(nBinsTab) - real(r8) :: volumeToNumber(0:nmodes) !m3 ==> # - real(r8) :: numberToSurface(0:nmodes) !# ==> m2 - -end module oslo_aero_const - - - - diff --git a/src/chemistry/oslo_aero/oslo_aero_control.F90 b/src/chemistry/oslo_aero/oslo_aero_control.F90 deleted file mode 100644 index 02c3bf373e..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_control.F90 +++ /dev/null @@ -1,190 +0,0 @@ -module oslo_aero_control - - !----------------------------------------------------------------------- - ! Provides a control interface to CAM-Oslo packages - !----------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - use spmd_utils, only: masterproc - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - - implicit none - private - - public :: oslo_aero_ctl_readnl ! read namelist from file - public :: oslo_aero_getopts ! generic query method - - ! Private module data - character(len=16), parameter :: unset_str = 'UNSET' - integer, parameter :: unset_int = huge(1) - integer, parameter, public :: dir_string_length=256 - - ! Namelist variables: - real(r8) :: volc_fraction_coarse = 0.0_r8 !Fraction of volcanic aerosols in coarse mode - character(len=dir_string_length) :: aerotab_table_dir = unset_str - - ! DMS/Ocean namelist variables - character(len=20) :: dms_source = unset_str - character(len=32) :: dms_source_type = unset_str - character(len=20) :: opom_source = unset_str - character(len=32) :: opom_source_type = unset_str - character(len=dir_string_length) :: ocean_filename = unset_str - character(len=dir_string_length) :: ocean_filepath = unset_str - integer :: dms_cycle_year = 0 ! =unset_int? - integer :: opom_cycle_year = 0 ! =unset_int? - -!======================================================================= -contains -!======================================================================= - - subroutine oslo_aero_ctl_readnl(nlfile) - - use namelist_utils, only: find_group_name - use mpishorthand - - ! arguments - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'oslo_ctl_readnl' - logical :: dirExists=.FALSE. - logical :: fileExists=.FALSE. - - namelist /oslo_ctl_nl/ volc_fraction_coarse, aerotab_table_dir, dms_source, & - dms_source_type, opom_source, opom_source_type, & - ocean_filename, ocean_filepath, dms_cycle_year, opom_cycle_year - !----------------------------------------------------------------------------- - - if (masterproc) then - open (newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'oslo_ctl_nl', status=ierr) - if (ierr == 0) then - read(unitn, oslo_ctl_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - end if -#ifdef SPMD - ! Broadcast namelist variables - call mpibcast(volc_fraction_coarse, 1 , mpir8, 0, mpicom) - call mpibcast(aerotab_table_dir, len(aerotab_table_dir) , mpichar, 0, mpicom) - - ! dms variables - call mpibcast(dms_source, len(dms_source), mpichar, 0, mpicom) - call mpibcast(dms_source_type, len(dms_source_type) , mpichar, 0, mpicom) - call mpibcast(dms_cycle_year, 1 , mpiint, 0, mpicom) - - ! opom variables - call mpibcast(opom_source, len(opom_source), mpichar, 0, mpicom) - call mpibcast(opom_source_type, len(opom_source_type), mpichar, 0, mpicom) - call mpibcast(opom_cycle_year, 1, mpiint, 0, mpicom) - - ! ocean variables - call mpibcast(ocean_filename, len(ocean_filename), mpichar, 0, mpicom) - call mpibcast(ocean_filepath, len(ocean_filepath), mpichar, 0, mpicom) -#endif - - ! Error checking: - - ! Defaults for PBL and microphysics are set in build-namelist. Check here that - ! values have been set to guard against problems with hand edited namelists. - if(volc_fraction_coarse .lt. 0.0_r8 .OR. volc_fraction_coarse .gt. 1.0_r8)then - write(iulog,*)'cam_oslo: illegal value of volc_fraction_coarse', volc_fraction_coarse - call endrun('cam_oslo: illegal value of volc_fraction_coarse') - end if - -#if defined CPRGNU || defined __GFORTRAN__ - inquire( file=trim(aerotab_table_dir), exist=dirExists ) -#elif defined CPRINTEL - inquire( directory=trim(aerotab_table_dir), exist=dirExists ) -#else - !Don't know how to check this on other compilres.. Assume exists - !and let crash later.. - dirExists = .true. -#endif - if(.not. dirExists)then - call endrun("cam_oslo: can not find aerotab table directory "//trim(aerotab_table_dir)) - else - write(iulog,*)"Reading aerosol tables from : " // trim(aerotab_table_dir) - endif - - ! Error check for OCEAN file - ! can ocean file be found? - inquire( file=trim(ocean_filepath)//'/'//trim(ocean_filename), exist=fileExists ) - if(.not. fileExists)then - call endrun("oslo_aero_control: can not find ocean file "//trim(ocean_filepath)//'/'//trim(ocean_filename)) - else - write(iulog,*)"Reading ocean tracers from : " // trim(ocean_filepath)//'/'//trim(ocean_filename) - endif - - ! Error check for dms_source from namelist - if (dms_source=='ocean_flux')then - ! TODO: need to reimplement this so that index_x2a_Faoo_fdms is not used - this is only valid for mct - ! if (index_x2a_Faoo_fdms_ocn == 0) then - ! call endrun("cam_oslo: dms source set to "//trim(dms_source)//" but bgc is off") - ! else - ! write(iulog,*)"DMS emission source is : "// trim(dms_source) - ! endif - elseif (dms_source=='kettle' .or. dms_source=='lana' .or. dms_source=='emission_file')then - if (masterproc) then - write(iulog,*)"DMS emission source is : "// trim(dms_source) - end if - else - call endrun("oslo_aero_control: no valid dms source from namelist: " //trim(dms_source)) - endif - - ! Error check for opom_source from namelist - if(opom_source=='no_file' .or. opom_source=='nilsson' .or. opom_source=='odowd')then - write(iulog,*)"Ocean POM emission source is : "// trim(opom_source) - else - call endrun("oslo_aero_control: no valid opom source from namelist: " //trim(opom_source)) - endif - - end subroutine oslo_aero_ctl_readnl - - !========================================================================== - subroutine oslo_aero_getopts( & - volc_fraction_coarse_out, & - aerotab_table_dir_out, & - dms_source_out, & - dms_source_type_out, & - opom_source_out, & - opom_source_type_out, & - ocean_filename_out, & - ocean_filepath_out, & - opom_cycle_year_out, & - dms_cycle_year_out ) - - !----------------------------------------------------------------------- - ! Purpose: Return runtime settings - !----------------------------------------------------------------------- - - real(r8) , intent(out), optional :: volc_fraction_coarse_out - character(len=dir_string_length) , intent(out), optional :: aerotab_table_dir_out - character(len=dir_string_length) , intent(out), optional :: ocean_filename_out - character(len=dir_string_length) , intent(out), optional :: ocean_filepath_out - character(len=20) , intent(out), optional :: dms_source_out - character(len=32) , intent(out), optional :: dms_source_type_out - integer , intent(out), optional :: dms_cycle_year_out - character(len=20) , intent(out), optional :: opom_source_out - character(len=32) , intent(out), optional :: opom_source_type_out - integer , intent(out), optional :: opom_cycle_year_out - - if ( present(volc_fraction_coarse_out ) ) volc_fraction_coarse_out = volc_fraction_coarse - if ( present(aerotab_table_dir_out ) ) aerotab_table_dir_out = aerotab_table_dir - if ( present(ocean_filename_out ) ) ocean_filename_out = ocean_filename - if ( present(ocean_filepath_out ) ) ocean_filepath_out = ocean_filepath - if ( present(dms_source_out ) ) dms_source_out = dms_source - if ( present(dms_source_type_out ) ) dms_source_type_out = dms_source_type - if ( present(dms_cycle_year_out ) ) dms_cycle_year_out = dms_cycle_year - if ( present(opom_source_out ) ) opom_source_out = opom_source - if ( present(opom_source_type_out ) ) opom_source_type_out= opom_source_type - if ( present(opom_cycle_year_out ) ) opom_cycle_year_out = opom_cycle_year - - end subroutine oslo_aero_getopts - -end module oslo_aero_control diff --git a/src/chemistry/oslo_aero/oslo_aero_depos.F90 b/src/chemistry/oslo_aero/oslo_aero_depos.F90 deleted file mode 100644 index e967c27243..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_depos.F90 +++ /dev/null @@ -1,1987 +0,0 @@ -module oslo_aero_depos - - !------------------------------------------------------------------------------------------------ - ! Compute the contributions from oslo aero modal components of wet and dry - ! deposition at the surface into the fields passed to the coupler. - ! Wet deposition routines for both aerosols and gas phase constituents. - !------------------------------------------------------------------------------------------------ - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver, pverp, begchunk, endchunk - use constituents, only: pcnst, cnst_name, cnst_get_ind - use phys_control, only: phys_getopts, cam_physpkg_is - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use camsrfexch, only: cam_in_t, cam_out_t - use time_manager, only: is_first_step - use aerodep_flx, only: aerodep_flx_prescribed - use mo_drydep, only: n_land_type, fraction_landuse - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_get_field, pbuf_get_index - use physics_buffer, only: pbuf_old_tim_idx - use physconst, only: gravit, rair, rhoh2o, boltz, pi, tmelt - use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only - use ref_pres, only: top_lev => clim_modal_aero_top_lev - ! - use oslo_aero_dust_sediment, only: oslo_aero_dust_sediment_tend, oslo_aero_dust_sediment_vel - use oslo_aero_params - use oslo_aero_share - ! use oslo_aero_share, only: l_bc_n,l_bc_ax,l_bc_ni,l_bc_a,l_bc_ai,l_bc_ac - ! use oslo_aero_share, only: l_om_ni,l_om_ai,l_om_ac,l_dst_a2,l_dst_a3 - - implicit none - private ! Make default type private to the module - - ! Public interfaces - public :: oslo_aero_depos_init - public :: oslo_aero_depos_dry ! dry deposition - public :: oslo_aero_depos_wet ! wet deposition - public :: oslo_aero_wetdep_init - - ! Private interfaces - private :: oslo_aero_depvel_part - private :: oslo_set_srf_drydep - private :: oslo_set_srf_wetdep - private :: calcram - private :: wetdep_inputs_t - private :: wetdep_inputs_set - private :: wetdepa_v2 ! scavenging codes for very soluble aerosols -- CAM5 version - private :: wetdepg ! scavenging of gas phase constituents by henry's law - private :: clddiag ! calc of cloudy volume and rain mixing ratio - - real(r8), public :: sol_facti_cloud_borne - - real(r8), parameter :: cmftau = 3600._r8 - real(r8), parameter :: rhoh2o = 1000._r8 ! density of water - real(r8), parameter :: molwta = 28.97_r8 ! molecular weight dry air gm/mole - - type wetdep_inputs_t - real(r8), pointer :: cldt(:,:) => null() ! cloud fraction - real(r8), pointer :: qme(:,:) => null() - real(r8), pointer :: prain(:,:) => null() - real(r8), pointer :: evapr(:,:) => null() - real(r8) :: cldcu(pcols,pver) ! convective cloud fraction, currently empty - real(r8) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation - real(r8) :: cmfdqr(pcols,pver) ! convective production of rain - real(r8) :: conicw(pcols,pver) ! convective in-cloud water - real(r8) :: totcond(pcols, pver) ! total condensate - real(r8) :: cldv(pcols,pver) ! cloudy volume undergoing wet chem and scavenging - real(r8) :: cldvcu(pcols,pver) ! Convective precipitation area at the top interface of current layer - real(r8) :: cldvst(pcols,pver) ! Stratiform precipitation area at the top interface of current layer - end type wetdep_inputs_t - - logical :: convproc_do_aer = .FALSE. - logical :: drydep_lq(pcnst) - logical :: wetdep_lq(pcnst) - - integer :: fracis_idx = 0 - integer :: prain_idx = 0 - integer :: cld_idx = 0 - integer :: qme_idx = 0 - integer :: nevapr_idx = 0 - integer :: icwmrdp_idx = 0 - integer :: icwmrsh_idx = 0 - integer :: rprddp_idx = 0 - integer :: rprdsh_idx = 0 - integer :: sh_frac_idx = 0 - integer :: dp_frac_idx = 0 - integer :: nevapr_shcu_idx = 0 - integer :: nevapr_dpcu_idx = 0 - integer :: ixcldice, ixcldliq - -!=============================================================================== -contains -!=============================================================================== - - subroutine oslo_aero_depos_init( pbuf2d ) - - ! Set oslo aeroslo deposition history output - - ! arguments - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local variables - integer :: m, l, i - integer :: lchnk - integer :: tracerIndex - integer :: astat, id - real(r8), pointer :: qqcw(:,:) - logical :: history_aerosol ! Output the aerosol tendencies - character(len=2) :: unit_basename='kg' ! Units 'kg' or '1' - character(len=100) :: aName ! tracer name - logical :: is_in_output(pcnst) - !----------------------------------------------------------------------- - - fracis_idx = pbuf_get_index('FRACIS') - prain_idx = pbuf_get_index('PRAIN') - nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') - - call phys_getopts( history_aerosol_out = history_aerosol ) - - is_in_output(:) =.false. - drydep_lq(:) =.false. - wetdep_lq(:) =.false. - - ! Mode 0 is not subject to wet deposition? (check noresm1 code..) - do m=0,nmodes - do l=1,getNumberOfTracersInMode(m) - - tracerIndex = getTracerIndex(m,l,.false.) - drydep_lq(tracerIndex)=.true. - wetdep_lq(tracerIndex)=.true. - - if(is_in_output(tracerIndex))then - cycle - endif - - aName = cnst_name(tracerIndex) - - call addfld (trim(aName)//'SFWET',horiz_only, 'A', unit_basename//'/m2/s', & - 'Wet deposition flux at surface') - call addfld (trim(aName)//'SFSIC',horiz_only, 'A', unit_basename//'/m2/s ', & - 'Wet deposition flux (incloud, convective) at surface') - call addfld (trim(aName)//'SFSIS',horiz_only, 'A', unit_basename//'/m2/s ', & - 'Wet deposition flux (incloud, stratiform) at surface') - call addfld (trim(aName)//'SFSBC',horiz_only, 'A', unit_basename//'/m2/s ', & - 'Wet deposition flux (belowcloud, convective) at surface') - call addfld (trim(aName)//'SFSBS',horiz_only, 'A', unit_basename//'/m2/s ', & - 'Wet deposition flux (belowcloud, stratiform) at surface') - call addfld (trim(aName)//'WET',(/'lev'/), 'A', unit_basename//'/kg/s ','wet deposition tendency') - call addfld (trim(aName)//'SIC',(/'lev'/), 'A', unit_basename//'/kg/s ', & - trim(aName)//' ic wet deposition') - call addfld (trim(aName)//'SIS',(/'lev'/), 'A', unit_basename//'/kg/s ', & - trim(aName)//' is wet deposition') - call addfld (trim(aName)//'SBC',(/'lev'/), 'A', unit_basename//'/kg/s ', & - trim(aName)//' bc wet deposition') - call addfld (trim(aName)//'SBS',(/'lev'/), 'A', unit_basename//'/kg/s ', & - trim(aName)//' bs wet deposition') - - ! Extra wd ouptut - if ( history_aerosol ) then - call add_default (trim(aName)//'SFWET', 1, ' ') - call add_default (trim(aName)//'SFSIC', 1, ' ') - call add_default (trim(aName)//'SFSIS', 1, ' ') - call add_default (trim(aName)//'SFSBC', 1, ' ') - call add_default (trim(aName)//'SFSBS', 1, ' ') - endif - - ! Dry deposition fluxes and velocity - call addfld (trim(aName)//'DDF',horiz_only, 'A', unit_basename//'/m2/s ', & - trim(aName)//' dry deposition flux at bottom (grav + turb)') - call addfld (trim(aName)//'TBF',horiz_only, 'A' ,unit_basename//'/m2/s', & - trim(aName)//' turbulent dry deposition flux') - call addfld (trim(aName)//'GVF',horiz_only, 'A', unit_basename//'/m2/s ', & - trim(aName)//' gravitational dry deposition flux') - call addfld (trim(aName)//'DTQ',(/'lev'/), 'A', unit_basename//'/kg/s ', & - trim(aName)//' dry deposition') - call addfld (trim(aName)//'DDV',(/'lev'/), 'A', 'm/s', & - trim(aName)//' deposition velocity') - - ! extra drydep output - if ( history_aerosol ) then - call add_default (trim(aName)//'DDF', 1, ' ') - call add_default (trim(aName)//'TBF', 1, ' ') - call add_default (trim(aName)//'GVF', 1, ' ') - !call add_default (trim(aName)//'DDV', 1, ' ') - endif - - ! some tracers are not in cloud water - if(getCloudTracerIndexDirect(tracerIndex) .lt. 0)then - cycle - endif - - aName = trim(getCloudTracerName(tracerIndex)) - - ! Cloud water fields (from mo_chm_diags.F90) - call addfld (trim(aName)//'SFWET', horiz_only, 'A', unit_basename//'/m2/s', & - trim(aName)//' wet deposition flux at surface') - call addfld (trim(aName)//'SFSIC', horiz_only, 'A',unit_basename//'/m2/s ', & - trim(aName)//' wet deposition flux (incloud, convective) at surface') - call addfld (trim(aName)//'SFSIS', horiz_only, 'A', unit_basename//'/m2/s ', & - trim(aName)//' wet deposition flux (incloud, stratiform) at surface') - call addfld (trim(aName)//'SFSBC', horiz_only, 'A', unit_basename//'/m2/s ' , & - trim(aName)//' wet deposition flux (belowcloud, convective) at surface') - call addfld (trim(aName)//'SFSBS', horiz_only, 'A', unit_basename//'/m2/s ' , & - trim(aName)//' wet deposition flux (belowcloud, stratiform) at surface') - - ! dry deposition - call addfld (trim(aName)//'DDF', horiz_only, 'A', unit_basename//'/m2/s ', & - trim(aName)//' dry deposition flux at bottom (grav + turb)') - call addfld (trim(aName)//'TBF', horiz_only, 'A', unit_basename//'/m2/s ', & - trim(aName)//' turbulent dry deposition flux') - call addfld (trim(aName)//'GVF', horiz_only, 'A', unit_basename//'/m2/s ', & - trim(aName)//' gravitational dry deposition flux') - - is_in_output(tracerIndex) = .true. - - end do !tracers - enddo !modes - - !initialize cloud concentrations (initialize cloud bourne constituents in physics buffer) - if (is_first_step()) then - do i = 1, pcnst - do lchnk = begchunk, endchunk - qqcw => qqcw_get_field(pbuf_get_chunk(pbuf2d,lchnk), i) - if (associated(qqcw)) then - qqcw = 1.e-38_r8 - end if - end do - end do - end if - - end subroutine oslo_aero_depos_init - - !=============================================================================== - subroutine oslo_aero_depos_dry ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend, & - dgncur_awet, wetdens, dgncur_awet_processmode, wetdens_processmode, cflx) - - ! Arguments: - type(physics_state), intent(in) :: state ! Physics state variables - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: obklen(:) - real(r8), intent(in) :: ustar(:) ! sfc fric vel - type(cam_in_t), target, intent(in) :: cam_in ! import state - real(r8), intent(in) :: dt ! time step - type(cam_out_t), intent(inout) :: cam_out ! export state - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - real(r8), intent(in) :: dgncur_awet(pcols,pver,0:nmodes) - real(r8), intent(in) :: wetdens(pcols,pver,0:nmodes) - real(r8), intent(in) :: dgncur_awet_processmode(pcols, pver, numberOfProcessModeTracers) - real(r8), intent(in) :: wetdens_processmode(pcols, pver, numberOfProcessModeTracers) - real(r8), intent(in) :: cflx(pcols,pcnst) ! Surface fluxes - - ! local vars - real(r8), pointer :: landfrac(:) ! land fraction - real(r8), pointer :: icefrac(:) ! ice fraction - real(r8), pointer :: ocnfrac(:) ! ocean fraction - real(r8), pointer :: fvin(:) ! - real(r8), pointer :: ram1in(:) ! for dry dep velocities from land model for progseasalts - - real(r8) :: fv(pcols) ! for dry dep velocities, from land modified over ocean & ice - real(r8) :: ram1(pcols) ! for dry dep velocities, from land modified over ocean & ice - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: jvlc ! index for last dimension of vlc_xxx arrays - integer :: lphase ! index for interstitial / cloudborne aerosol - integer :: lspec ! index for aerosol number / chem-mass / water-mass - integer :: m ! aerosol mode index - integer :: mm ! tracer index - integer :: i - - real(r8) :: tvs(pcols,pver) - real(r8) :: rho(pcols,pver) ! air density in kg/m3 - real(r8) :: sflx(pcols) ! deposition flux - real(r8):: dep_trb(pcols) !kg/m2/s - real(r8):: dep_grv(pcols) !kg/m2/s (total of grav and trb) - real(r8) :: pvmzaer(pcols,pverp) ! sedimentation velocity in Pa - real(r8) :: dqdt_tmp(pcols,pver) ! temporary array to hold tendency for 1 species - - real(r8) :: rad_drop(pcols,pver) - real(r8) :: dens_drop(pcols,pver) - real(r8) :: sg_drop(pcols,pver) - real(r8) :: rad_aer(pcols,pver) - real(r8) :: dens_aer(pcols,pver) - real(r8) :: sg_aer(pcols,pver) - - real(r8) :: vlc_dry(pcols,pver,4) ! dep velocity - real(r8) :: vlc_grv(pcols,pver,4) ! dep velocity - real(r8):: vlc_trb(pcols,4) ! dep velocity - real(r8) :: aerdepdryis(pcols,pcnst) ! aerosol dry deposition (interstitial) - real(r8) :: aerdepdrycw(pcols,pcnst) ! aerosol dry deposition (cloud water) - real(r8), pointer :: fldcw(:,:) - - ! oslo aerosols - real(r8) :: interfaceTendToLowestLayer(pcols) - real(r8) :: deltaH(pcols) - real(r8) :: massLostDD(pcols) - real(r8) :: MMRNew(pcols) - real(r8) :: lossRate(pcols) - real(r8) :: totalProd(pcols) - - real(r8) :: logSigma - logical :: is_done(pcnst,2) - !----------------------------------------------------------------------- - - landfrac => cam_in%landfrac(:) - icefrac => cam_in%icefrac(:) - ocnfrac => cam_in%ocnfrac(:) - fvin => cam_in%fv(:) - ram1in => cam_in%ram1(:) - - lchnk = state%lchnk - ncol = state%ncol - aerdepdryis(:,:)=0._r8 - aerdepdrycw(:,:)=0._r8 - - ! calc ram and fv over ocean and sea ice ... - call calcram( ncol,landfrac,icefrac,ocnfrac,obklen, & - ustar,ram1in,ram1,state%t(:,pver),state%pmid(:,pver), & - state%pdel(:,pver),fvin,fv) - - call outfld( 'airFV', fv(:), pcols, lchnk ) - call outfld( 'RAM1', ram1(:), pcols, lchnk ) - - ! note that tendencies are not only in sfc layer (because of sedimentation) - ! and that ptend is updated within each subroutine for different species - - call physics_ptend_init(ptend, state%psetcols, 'aero_model_drydep', lq=drydep_lq) - - tvs(:ncol,:) = state%t(:ncol,:)!*(1+state%q(:ncol,k) - rho(:ncol,:)= state%pmid(:ncol,:)/(rair*state%t(:ncol,:)) - is_done(:,:) = .false. - - ! calc settling/deposition velocities for cloud droplets (and cloud-borne aerosols) - ! *** mean drop radius should eventually be computed from ndrop and qcldwtr - rad_drop(:,:) = 5.0e-6_r8 - dens_drop(:,:) = rhoh2o - sg_drop(:,:) = 1.46_r8 - - !jvlc = 3 - !call oslo_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & - ! vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - ! rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 0, lchnk) - - jvlc = 4 - call oslo_aero_depvel_part( ncol,state%t(:,:), state%pmid(:,:), ram1, fv, & - vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_drop(:,:), dens_drop(:,:), sg_drop(:,:), 3, lchnk) - - !At this point we really need to distribute the lifecycle-tracers over - !the actual modes (maybe according to surface available of background tracers?) - - !in mam3, jvlc = 1 means number-concentration - !in oslo_aero, jvlc = 1 means process-modes - !The following logic is based on that process-mode tracers - !always follow AFTER the actual tracers!! - - dens_aer(:,:) = 0._r8 - do m = 0, nmodes ! main loop over aerosol modes - - do lphase = 1, 2 ! loop over interstitial / cloud-borne forms - - if (lphase == 1) then ! interstial aerosol - calc settling/dep velocities of mode - logSigma = log(lifeCycleSigma(m)) - - ! rad_aer = volume mean wet radius (m) - ! dgncur_awet = geometric mean wet diameter for number distribution (m) - if(top_lev .gt. 1) then - rad_aer(1:ncol,:top_lev-1) = 0._r8 - end if - rad_aer(1:ncol,top_lev:) = 0.5_r8*dgncur_awet(1:ncol,top_lev:,m) *exp(1.5_r8*(logSigma)) - - ! dens_aer(1:ncol,:) = wet density (kg/m3) - if(top_lev.gt.1)then - dens_aer(1:ncol,:top_lev-1) = 0._r8 - end if - dens_aer(1:ncol,top_lev:) = wetdens(1:ncol,top_lev:,m) - - sg_aer(1:ncol,:) = lifecycleSigma(m) - - jvlc = 2 - call oslo_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & - vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) - end if - - do lspec = 1, getNumberOfTracersInMode(m) ! loop over number + constituents - - mm = getTracerIndex(m,lspec,.false.) - if(is_done(mm,lphase)) then - cycle - endif - is_done(mm,lphase)=.true. - - if (lphase == 1) then - jvlc = 2 !mass in clean air tracers - - !Process tracers have their own velocity based on fixed size / density - !Calculate the velocity to use for this specie.. - if ( is_process_mode(mm, .false.) ) then - jvlc = 1 - logSigma = log(processModeSigma(processModeMap(mm))) - if(top_lev.gt.1)then - rad_aer(1:ncol, top_lev-1) = 0.0_r8 - end if - rad_aer(1:ncol,top_lev:) = 0.5_r8*dgncur_awet_processmode(1:ncol,top_lev:,processModeMap(mm)) & - *exp(1.5_r8*(logSigma)) - - call oslo_aero_depvel_part( ncol, state%t(:,:), state%pmid(:,:), ram1, fv, & - vlc_dry(:,:,jvlc), vlc_trb(:,jvlc), vlc_grv(:,:,jvlc), & - rad_aer(:,:), dens_aer(:,:), sg_aer(:,:), 3, lchnk) - endif - - else - jvlc = 4 !mass in cloud tracers - endif - - if (mm <= 0) cycle - - if ((lphase == 1) .and. (lspec <= getNumberOfTracersInMode(m))) then - ptend%lq(mm) = .TRUE. - - ! use pvprogseasalts instead (means making the top level 0) - pvmzaer(:ncol,1)=0._r8 - pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) - - call outfld( trim(cnst_name(mm))//'DDV', pvmzaer(:,2:pverp), pcols, lchnk ) - - ! use phil's method - ! convert from meters/sec to pascals/sec, use density from layer above in conversion - pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit - - ! calculate the tendencies and sfc fluxes from the above velocities - call oslo_aero_dust_sediment_tend(ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t , & - state%q(:,:,mm), pvmzaer, ptend%q(:,:,mm), sflx, & - dusttend_to_ll_out=interfaceTendToLowestLayer) - - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - !%%%%%% FIX FOR SHORT DRYDEP LIFE-TIMES - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - !Some tracers have short lifetime with respect to dry dep: - !Solve implicitly for eqn for emission and dry dep in lowest layer - deltaH(:ncol)=state%pdel(:ncol,pver)/rho(:ncol,pver)/gravit ![m] height of layer - !print*, "deltaH", deltaH(:ncol) - - lossRate(:ncol) = vlc_dry(:ncol,pver,jvlc)/deltaH(:ncol) ![1/s] loss rate out of layer - !print*, "lossRate", lossRate(:ncol) - !print*, "interfaceFluxesToLowestLayer", interfaceFluxToLowestLayer(:ncol) - - !OBS OBS OBS DIRTY FIX but need approx 2-3 weeks for proper solution - !special treatment of BC_AX because BC_AX is not treated with - !boundary mixing in activation (is by definition not activated!) - !Therefor emissions are already added in "normal" boundary layer - !mixing routine.. - !The proper fix to this is to skip the special treatment of BC_AX - !and skip the index "0" for that mixture alltogether! - if(mm .eq. l_bc_ax) then - totalProd(:ncol) = interfaceTendToLowestLayer(:ncol) - else - totalProd(:ncol) = cflx(:ncol,mm)*gravit/state%pdel(:ncol,pver) + interfaceTendToLowestLayer(:ncol) - end if - - !Do solution - where(lossRate(:ncol)*dt .gt. 1.e-2_r8) - MMRNew(:ncol) = state%q(:ncol,pver,mm)*exp(-lossRate(:ncol)*dt) & - + totalProd(:ncol)/lossRate(:ncol)*(1.0_r8 - exp(-lossRate(:ncol)*dt)) - elsewhere - MMRNew(:ncol) = state%q(:ncol,pver,mm) & - + totalProd(:ncol)*dt & - - state%q(:ncol,pver,mm)*lossRate(:ncol)*dt - end where - - !C0 + Pdt -massLostDD = CNew ==> - massLostDD(:ncol) = state%q(:ncol,pver,mm) - MMRNew(:ncol) + totalProd(:ncol)*dt - - !Overwrite tendency in lowest layer to include emissions - !They are then not included in vertical diffusion!! - ptend%q(:ncol,pver,mm) = (MMRNew(:ncol)-state%q(:ncol,pver,mm))/dt - sflx(:ncol) = massLostDD(:ncol)*state%pdel(:ncol,pver) / gravit / dt - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - ! apportion dry deposition into turb and gravitational settling for tapes - dep_trb = 0._r8 - dep_grv = 0._r8 - do i=1,ncol - if (vlc_dry(i,pver,jvlc) /= 0._r8) then - dep_trb(i)=sflx(i)*vlc_trb(i,jvlc)/vlc_dry(i,pver,jvlc) - dep_grv(i)=sflx(i)*vlc_grv(i,pver,jvlc)/vlc_dry(i,pver,jvlc) - endif - enddo - - call outfld( trim(cnst_name(mm))//'DDF', sflx, pcols, lchnk) - call outfld( trim(cnst_name(mm))//'TBF', dep_trb, pcols, lchnk ) - call outfld( trim(cnst_name(mm))//'GVF', dep_grv, pcols, lchnk ) - call outfld( trim(cnst_name(mm))//'DTQ', ptend%q(:,:,mm), pcols, lchnk) - aerdepdryis(:ncol,mm) = sflx(:ncol) - - else ! lphase == 2 - - !Pick up the cloud tracers (oslo) - fldcw => qqcw_get_field(pbuf, mm) - if( .not. associated(fldcw))then - cycle - end if - - ! use pvprogseasalts instead (means making the top level 0) - pvmzaer(:ncol,1)=0._r8 - pvmzaer(:ncol,2:pverp) = vlc_dry(:ncol,:,jvlc) - - ! Hardwire the method from Phil - ! convert from meters/sec to pascals/sec - ! pvprogseasalts(:,1) is assumed zero, use density from layer above in conversion - pvmzaer(:ncol,2:pverp) = pvmzaer(:ncol,2:pverp) * rho(:ncol,:)*gravit - - ! calculate the tendencies and sfc fluxes from the above velocities - call oslo_aero_dust_sediment_tend(ncol, dt, state%pint(:,:), state%pmid, state%pdel, state%t, & - fldcw(:,:), pvmzaer, dqdt_tmp(:,:), sflx) - - ! apportion dry deposition into turb and gravitational settling for tapes - dep_trb = 0._r8 - dep_grv = 0._r8 - do i=1,ncol - if (vlc_dry(i,pver,jvlc) /= 0._r8) then - dep_trb(i)=sflx(i)*vlc_trb(i,jvlc)/vlc_dry(i,pver,jvlc) - dep_grv(i)=sflx(i)*vlc_grv(i,pver,jvlc)/vlc_dry(i,pver,jvlc) - end if - enddo - - fldcw(1:ncol,:) = fldcw(1:ncol,:) + dqdt_tmp(1:ncol,:) * dt - - call outfld( trim(getCloudTracerName(mm))//'DDF', sflx, pcols, lchnk) - call outfld( trim(getCloudTracerName(mm))//'TBF', dep_trb, pcols, lchnk ) - call outfld( trim(getCloudTracerName(mm))//'GVF', dep_grv, pcols, lchnk ) - aerdepdrycw(:ncol,mm) = sflx(:ncol) - - endif - - enddo ! lspec = 0, nspec_amode(m)+1 - enddo ! lphase = 1, 2 - enddo ! m = 1, ntot_amode - - ! if the user has specified prescribed aerosol dep fluxes then - ! do not set cam_out dep fluxes according to the prognostic aerosols - if (.not.aerodep_flx_prescribed()) then - call oslo_set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) - endif - - end subroutine oslo_aero_depos_dry - - !=============================================================================== - subroutine oslo_aero_depos_wet ( state, dt, dlf, cam_out, ptend, pbuf) - - type(physics_state), intent(in) :: state ! Physics state variables - real(r8), intent(in) :: dt ! time step - real(r8), intent(in) :: dlf(:,:) ! shallow+deep convective detrainment [kg/kg/s] - type(cam_out_t), intent(inout) :: cam_out ! export state - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - type(physics_buffer_desc), pointer :: pbuf(:) - - ! Local variables - integer :: m ! tracer index - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer :: i,k,mm - real(r8) :: iscavt(pcols, pver) - real(r8) :: icscavt(pcols, pver) - real(r8) :: isscavt(pcols, pver) - real(r8) :: bcscavt(pcols, pver) - real(r8) :: bsscavt(pcols, pver) - real(r8) :: sol_factb, sol_facti - real(r8) :: sol_factic(pcols,pver) - real(r8) :: sflx(pcols) ! deposition flux - real(r8) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1) - integer :: jnv ! index for scavcoefnv 3rd dimension - integer :: lphase ! index for interstitial / cloudborne aerosol - integer :: lspec ! index for aerosol number / chem-mass / water-mass - real(r8) :: dqdt_tmp(pcols,pver) ! temporary array to hold tendency for 1 species - real(r8) :: f_act_conv(pcols,pver) ! prescribed aerosol activation fraction for convective cloud ! rce 2010/05/01 - real(r8) :: f_act_conv_coarse(pcols,pver) ! similar but for coarse mode ! rce 2010/05/02 - real(r8) :: f_act_conv_coarse_dust, f_act_conv_coarse_nacl ! rce 2010/05/02 - real(r8) :: fracis_cw(pcols,pver) - real(r8) :: prec(pcols) ! precipitation rate - real(r8) :: q_tmp(pcols,pver) ! temporary array to hold "most current" mixing ratio for 1 species - real(r8) :: qqcw_tmp(pcols,pver) ! temporary array to hold qqcw ! rce 2010/05/01 - real(r8) :: scavcoefnv(pcols,pver,0:2) ! Dana and Hales coefficient (/mm) for - real(r8) :: water_old, water_new ! temporary old/new aerosol water mix-rat - logical :: isprx(pcols,pver) ! true if precipation - real(r8) :: aerdepwetis(pcols,pcnst) ! aerosol wet deposition (interstitial) - real(r8) :: aerdepwetcw(pcols,pcnst) ! aerosol wet deposition (cloud water) - real(r8) :: sflxic(pcols) ! deposition flux - real(r8) :: sflxbc(pcols) ! deposition flux - real(r8) :: rcscavt(pcols, pver) - real(r8) :: rsscavt(pcols, pver) - real(r8) :: qqcw_in(pcols,pver), qqcw_sav(pcols,pver,pcnst) ! temporary array to hold qqcw for the current mode - logical :: is_done(pcnst,2) - real(r8), target :: zeroAerosolConcentration(pcols,pver) - real(r8), pointer :: fldcw(:,:) - real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble - type(wetdep_inputs_t) :: dep_inputs - - lchnk = state%lchnk - ncol = state%ncol - - call physics_ptend_init(ptend, state%psetcols, 'aero_model_wetdep', lq=wetdep_lq) - - is_done(:,:) = .false. - - zeroAerosolConcentration(:,:)=0.0_r8 - - ! Wet deposition of mozart aerosol species. - ptend%name = ptend%name//'+mz_aero_wetdep' - - call wetdep_inputs_set( state, pbuf, dep_inputs ) - call pbuf_get_field(pbuf, fracis_idx, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) - - prec(:ncol)=0._r8 - do k=1,pver - where (prec(:ncol) >= 1.e-7_r8) - isprx(:ncol,k) = .true. - elsewhere - isprx(:ncol,k) = .false. - endwhere - prec(:ncol) = prec(:ncol) + & - (dep_inputs%prain(:ncol,k) + dep_inputs%cmfdqr(:ncol,k) - dep_inputs%evapr(:ncol,k)) *state%pdel(:ncol,k)/gravit - end do - - - ! calculate the mass-weighted sol_factic for coarse mode species - ! sol_factic_coarse(:,:) = 0.30_r8 ! tuned 1/4 - f_act_conv_coarse(:,:) = 0.60_r8 ! rce 2010/05/02 - f_act_conv_coarse_dust = 0.40_r8 ! rce 2010/05/02 - f_act_conv_coarse_nacl = 0.80_r8 ! rce 2010/05/02 - f_act_conv_coarse(:,:) = 0.5_r8 - - scavcoefnv(:,:,0) = 0.0_r8 ! below-cloud scavcoef = 0.0 for cloud-borne species - - do m = 0, nmodes ! main loop over aerosol modes - - do lphase = 1, 2 ! loop over interstitial (1) and cloud-borne (2) forms - - ! sol_factb and sol_facti values - ! sol_factb - currently this is basically a tuning factor - ! sol_facti & sol_factic - currently has a physical basis, and reflects activation fraction - ! - ! 2008-mar-07 rce - sol_factb (interstitial) changed from 0.3 to 0.1 - ! - sol_factic (interstitial, dust modes) changed from 1.0 to 0.5 - ! - sol_factic (cloud-borne, pcarb modes) no need to set it to 0.0 - ! because the cloud-borne pcarbon == 0 (no activation) - ! - ! rce 2010/05/02 - ! prior to this date, sol_factic was used for convective in-cloud wet removal, - ! and its value reflected a combination of an activation fraction (which varied between modes) - ! and a tuning factor - ! from this date forward, two parameters are used for convective in-cloud wet removal - ! f_act_conv is the activation fraction - ! note that "non-activation" of aerosol in air entrained into updrafts should - ! be included here - ! eventually we might use the activate routine (with w ~= 1 m/s) to calculate - ! this, but there is still the entrainment issue - ! sol_factic is strictly a tuning factor - ! - if (lphase == 1) then ! interstial aerosol - !hygro_sum_old(:,:) = 0.0_r8 - !hygro_sum_del(:,:) = 0.0_r8 - !call modal_aero_bcscavcoef_get( m, ncol, isprx, dgncur_awet, scavcoefnv(:,:,1), scavcoefnv(:,:,2) ) - - scavcoefnv(:,:,1) = 0.1_r8 !Used by MAM for number concentration - - sol_factb = 0.1_r8 ! all below-cloud scav ON (0.1 "tuning factor") - ! sol_factb = 0.03_r8 ! all below-cloud scav ON (0.1 "tuning factor") ! tuned 1/6 - - sol_facti = 0.0_r8 ! strat in-cloud scav totally OFF for institial - - sol_factic = 0.4_r8 ! xl 2010/05/20 - - !fxm: simplified relative to MAM - f_act_conv = 0.8 !ag: Introduce tuning per component later - else ! cloud-borne aerosol (borne by stratiform cloud drops) - !default 100 % is scavenged by cloud -borne - sol_facti_cloud_borne = 1.0_r8 - - sol_factb = 0.0_r8 ! all below-cloud scav OFF (anything cloud-borne is located "in-cloud") - sol_facti = sol_facti_cloud_borne ! strat in-cloud scav cloud-borne tuning factor - sol_factic = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean - ! that conv precip collects strat droplets) - f_act_conv = 0.0_r8 ! conv in-cloud scav OFF (having this on would mean - end if - - if (convproc_do_aer .and. lphase == 1) then - ! if modal aero convproc is turned on for aerosols, then - ! turn off the convective in-cloud removal for interstitial aerosols - ! (but leave the below-cloud on, as convproc only does in-cloud) - ! and turn off the outfld SFWET, SFSIC, SFSID, SFSEC, and SFSED calls - ! for (stratiform)-cloudborne aerosols, convective wet removal - ! (all forms) is zero, so no action is needed - sol_factic = 0.0_r8 - endif - - do lspec = 1,getNumberOfTracersInMode(m) ! loop over number + chem constituents + water - mm = getTracerIndex(m,lspec,.false.) - if(is_done(mm,lphase)) then - cycle - endif - is_done(mm,lphase)=.true. - - if (lphase == 1) then - jnv = 2 - !Set correct below cloud scaveing coefficients - !Hard-coded values per mode in NorESM - if(is_process_mode(mm,.FALSE.))then - scavcoefnv(:,:,jnv) = belowCloudScavengingCoefficientProcessModes(processModeMap(mm)) - else - scavcoefnv(:,:,jnv) = belowCloudScavengingCoefficient(m) - end if - else - jnv = 0 !==> below cloud scavenging coefficients are zero (see above) - endif - - if ((lphase == 1) .and. (lspec <= getNumberOfTracersInMode(m))) then - ptend%lq(mm) = .TRUE. - dqdt_tmp(:,:) = 0.0_r8 - ! q_tmp reflects changes from modal_aero_calcsize and is the "most current" q - q_tmp(1:ncol,:) = state%q(1:ncol,:,mm) + ptend%q(1:ncol,:,mm)*dt - if(convproc_do_aer) then - !Feed in the saved cloudborne mixing ratios from phase 2 - qqcw_in(:,:) = qqcw_sav(:,:,mm) - !Not implemented for oslo aerosols - else - fldcw => qqcw_get_field(pbuf, mm) - if(.not. associated(fldcw))then - qqcw_in(:,:) = zeroAerosolConcentration(:,:) - else - qqcw_in(:,:) = fldcw(:,:) - end if - endif - - call wetdepa_v2( state%pmid, state%q(:,:,1), state%pdel, & - dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & - dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & - dep_inputs%evapr, dep_inputs%totcond, q_tmp, dt, & - dqdt_tmp, iscavt, dep_inputs%cldvcu, dep_inputs%cldvst, & - dlf, fracis(:,:,mm), sol_factb, ncol, & - scavcoefnv(:,:,jnv), & - is_strat_cloudborne=.false., & - qqcw=qqcw_in(:,:), & - f_act_conv=f_act_conv, & - icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & - convproc_do_aer=.false., rcscavt=rcscavt, rsscavt=rsscavt, & - sol_facti_in=sol_facti, sol_factic_in=sol_factic ) - - ptend%q(1:ncol,:,mm) = ptend%q(1:ncol,:,mm) + dqdt_tmp(1:ncol,:) - - call outfld( trim(cnst_name(mm))//'WET', dqdt_tmp(:,:), pcols, lchnk) - call outfld( trim(cnst_name(mm))//'SIC', icscavt, pcols, lchnk) - call outfld( trim(cnst_name(mm))//'SIS', isscavt, pcols, lchnk) - call outfld( trim(cnst_name(mm))//'SBC', bcscavt, pcols, lchnk) - call outfld( trim(cnst_name(mm))//'SBS', bsscavt, pcols, lchnk) - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+dqdt_tmp(i,k)*state%pdel(i,k)/gravit - enddo - enddo - if (.not.convproc_do_aer) call outfld( trim(cnst_name(mm))//'SFWET', sflx, pcols, lchnk) - aerdepwetis(:ncol,mm) = sflx(:ncol) - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+icscavt(i,k)*state%pdel(i,k)/gravit - enddo - enddo - if (.not.convproc_do_aer) call outfld( trim(cnst_name(mm))//'SFSIC', sflx, pcols, lchnk) - if (convproc_do_aer) sflxic = sflx - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+isscavt(i,k)*state%pdel(i,k)/gravit - enddo - enddo - call outfld( trim(cnst_name(mm))//'SFSIS', sflx, pcols, lchnk) - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+bcscavt(i,k)*state%pdel(i,k)/gravit - enddo - enddo - call outfld( trim(cnst_name(mm))//'SFSBC', sflx, pcols, lchnk) - if (convproc_do_aer)sflxbc = sflx - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+bsscavt(i,k)*state%pdel(i,k)/gravit - enddo - enddo - call outfld( trim(cnst_name(mm))//'SFSBS', sflx, pcols, lchnk) - - else ! lphase == 2 - - dqdt_tmp(:,:) = 0.0_r8 - qqcw_tmp(:,:) = 0.0_r8 ! rce 2010/05/01 - - if (convproc_do_aer) then - fldcw => qqcw_get_field(pbuf,mm) - if (.not. associated(fldcw)) then - call endrun('attempt to access undefined qqcw_sav for fld_cw') - end if - qqcw_sav(1:ncol,:,mm) = fldcw(1:ncol,:) - !This option yet not implemented for OSLO_AERO - else - fldcw => qqcw_get_field(pbuf, mm) - if(.not. associated(fldcw))then - cycle - end if - endif - - call wetdepa_v2(state%pmid, state%q(:,:,1), state%pdel, & - dep_inputs%cldt, dep_inputs%cldcu, dep_inputs%cmfdqr, & - dep_inputs%evapc, dep_inputs%conicw, dep_inputs%prain, dep_inputs%qme, & - dep_inputs%evapr, dep_inputs%totcond, fldcw, dt, & - dqdt_tmp, iscavt, dep_inputs%cldvcu, dep_inputs%cldvst, & - dlf, fracis_cw, sol_factb, ncol, & - scavcoefnv(:,:,jnv), & - is_strat_cloudborne=.true., & - icscavt=icscavt, isscavt=isscavt, bcscavt=bcscavt, bsscavt=bsscavt, & - convproc_do_aer=.false., rcscavt=rcscavt, rsscavt=rsscavt, & - sol_facti_in=sol_facti, sol_factic_in=sol_factic ) - - fldcw(1:ncol,:) = fldcw(1:ncol,:) + dqdt_tmp(1:ncol,:) * dt - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+dqdt_tmp(i,k)*state%pdel(i,k)/gravit - enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFWET', sflx, pcols, lchnk) - aerdepwetcw(:ncol,mm) = sflx(:ncol) - - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+icscavt(i,k)*state%pdel(i,k)/gravit - enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFSIC', sflx, pcols, lchnk) - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+isscavt(i,k)*state%pdel(i,k)/gravit - enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFSIS', sflx, pcols, lchnk) - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+bcscavt(i,k)*state%pdel(i,k)/gravit - enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFSBC', sflx, pcols, lchnk) - sflx(:)=0._r8 - do k=1,pver - do i=1,ncol - sflx(i)=sflx(i)+bsscavt(i,k)*state%pdel(i,k)/gravit - enddo - enddo - call outfld( trim(getCloudTracerName(mm))//'SFSBS', sflx, pcols, lchnk) - - endif - - enddo ! lspec = 0, nspec_amode(m)+1 - enddo ! lphase = 1, 2 - enddo ! m = 1, ntot_amode - - ! if the user has specified prescribed aerosol dep fluxes then - ! do not set cam_out dep fluxes according to the prognostic aerosols - if (.not. aerodep_flx_prescribed()) then - call oslo_set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) - endif - - return - - end subroutine oslo_aero_depos_wet - - !=============================================================================== - subroutine oslo_aero_depvel_part( ncol, t, pmid, ram1, fv, vlc_dry, vlc_trb, vlc_grv, & - radius_part, density_part, sig_part, moment, lchnk ) - - ! calculates surface deposition velocity of particles - ! L. Zhang, S. Gong, J. Padro, and L. Barrie - ! A size-seggregated particle dry deposition scheme for an atmospheric aerosol module - ! Atmospheric Environment, 35, 549-560, 2001. - ! - ! Authors: X. Liu - - ! !ARGUMENTS: - real(r8), intent(in) :: t(pcols,pver) !atm temperature (K) - real(r8), intent(in) :: pmid(pcols,pver) !atm pressure (Pa) - real(r8), intent(in) :: fv(pcols) !friction velocity (m/s) - real(r8), intent(in) :: ram1(pcols) !aerodynamical resistance (s/m) - real(r8), intent(in) :: radius_part(pcols,pver) ! mean (volume/number) particle radius (m) - real(r8), intent(in) :: density_part(pcols,pver) ! density of particle material (kg/m3) - real(r8), intent(in) :: sig_part(pcols,pver) ! geometric standard deviation of particles - integer, intent(in) :: moment ! moment of size distribution (0 for number, 2 for surface area, 3 for volume) - integer, intent(in) :: ncol - integer, intent(in) :: lchnk - - real(r8), intent(out) :: vlc_trb(pcols) !Turbulent deposn velocity (m/s) - real(r8), intent(out) :: vlc_grv(pcols,pver) !grav deposn velocity (m/s) - real(r8), intent(out) :: vlc_dry(pcols,pver) !dry deposn velocity (m/s) - !------------------------------------------------------------------------ - - !------------------------------------------------------------------------ - ! Local Variables - integer :: m,i,k,ix !indices - real(r8) :: rho !atm density (kg/m**3) - real(r8) :: vsc_dyn_atm(pcols,pver) ![kg m-1 s-1] Dynamic viscosity of air - real(r8) :: vsc_knm_atm(pcols,pver) ![m2 s-1] Kinematic viscosity of atmosphere - real(r8) :: shm_nbr ![frc] Schmidt number - real(r8) :: stk_nbr ![frc] Stokes number - real(r8) :: mfp_atm(pcols,pver) ![m] Mean free path of air - real(r8) :: dff_aer ![m2 s-1] Brownian diffusivity of particle - real(r8) :: slp_crc(pcols,pver) ![frc] Slip correction factor - real(r8) :: rss_trb ![s m-1] Resistance to turbulent deposition - real(r8) :: rss_lmn ![s m-1] Quasi-laminar layer resistance - real(r8) :: brownian ! collection efficiency for Browning diffusion - real(r8) :: impaction ! collection efficiency for impaction - real(r8) :: interception ! collection efficiency for interception - real(r8) :: stickfrac ! fraction of particles sticking to surface - real(r8) :: radius_moment(pcols,pver) ! median radius (m) for moment - real(r8) :: lnsig ! ln(sig_part) - real(r8) :: dispersion ! accounts for influence of size dist dispersion on bulk settling velocity - ! assuming radius_part is number mode radius * exp(1.5 ln(sigma)) - integer :: lt - real(r8) :: lnd_frc - real(r8) :: wrk1, wrk2, wrk3 - - ! constants - real(r8) gamma(11) ! exponent of schmidt number - ! data gamma/0.54d+00, 0.56d+00, 0.57d+00, 0.54d+00, 0.54d+00, & - ! 0.56d+00, 0.54d+00, 0.54d+00, 0.54d+00, 0.56d+00, & - ! 0.50d+00/ - data gamma/0.56e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.56e+00_r8, 0.56e+00_r8, & - 0.56e+00_r8, 0.50e+00_r8, 0.54e+00_r8, 0.54e+00_r8, 0.54e+00_r8, & - 0.54e+00_r8/ - save gamma - - real(r8) alpha(11) ! parameter for impaction - ! data alpha/50.00d+00, 0.95d+00, 0.80d+00, 1.20d+00, 1.30d+00, & - ! 0.80d+00, 50.00d+00, 50.00d+00, 2.00d+00, 1.50d+00, & - ! 100.00d+00/ - data alpha/1.50e+00_r8, 1.20e+00_r8, 1.20e+00_r8, 0.80e+00_r8, 1.00e+00_r8, & - 0.80e+00_r8, 100.00e+00_r8, 50.00e+00_r8, 2.00e+00_r8, 1.20e+00_r8, & - 50.00e+00_r8/ - save alpha - - real(r8) radius_collector(11) ! radius (m) of surface collectors - ! data radius_collector/-1.00d+00, 5.10d-03, 3.50d-03, 3.20d-03, 10.00d-03, & - ! 5.00d-03, -1.00d+00, -1.00d+00, 10.00d-03, 10.00d-03, & - ! -1.00d+00/ - data radius_collector/10.00e-03_r8, 3.50e-03_r8, 3.50e-03_r8, 5.10e-03_r8, 2.00e-03_r8, & - 5.00e-03_r8, -1.00e+00_r8, -1.00e+00_r8, 10.00e-03_r8, 3.50e-03_r8, & - -1.00e+00_r8/ - save radius_collector - - integer :: iwet(11) ! flag for wet surface = 1, otherwise = -1 - ! data iwet/1, -1, -1, -1, -1, & - ! -1, -1, -1, 1, -1, & - ! 1/ - data iwet/-1, -1, -1, -1, -1, & - -1, 1, -1, 1, -1, & - -1/ - save iwet - - - !------------------------------------------------------------------------ - - if(top_lev.gt.1) then - vlc_grv(:ncol,:top_lev-1) = 0._r8 - vlc_dry(:ncol,:top_lev-1) = 0._r8 - endif - - do k=top_lev,pver - do i=1,ncol - - lnsig = log(sig_part(i,k)) - ! use a maximum radius of 50 microns when calculating deposition velocity - radius_moment(i,k) = min(50.0e-6_r8,radius_part(i,k))* & - exp((float(moment)-1.5_r8)*lnsig*lnsig) - dispersion = exp(2._r8*lnsig*lnsig) - - rho=pmid(i,k)/rair/t(i,k) - - ! Quasi-laminar layer resistance: call rss_lmn_get - ! Size-independent thermokinetic properties - vsc_dyn_atm(i,k) = 1.72e-5_r8 * ((t(i,k)/273.0_r8)**1.5_r8) * 393.0_r8 / & - (t(i,k)+120.0_r8) ![kg m-1 s-1] RoY94 p. 102 - mfp_atm(i,k) = 2.0_r8 * vsc_dyn_atm(i,k) / & ![m] SeP97 p. 455 - (pmid(i,k)*sqrt(8.0_r8/(pi*rair*t(i,k)))) - vsc_knm_atm(i,k) = vsc_dyn_atm(i,k) / rho ![m2 s-1] Kinematic viscosity of air - - slp_crc(i,k) = 1.0_r8 + mfp_atm(i,k) * & - (1.257_r8+0.4_r8*exp(-1.1_r8*radius_moment(i,k)/(mfp_atm(i,k)))) / & - radius_moment(i,k) ![frc] Slip correction factor SeP97 p. 464 - vlc_grv(i,k) = (4.0_r8/18.0_r8) * radius_moment(i,k)*radius_moment(i,k)*density_part(i,k)* & - gravit*slp_crc(i,k) / vsc_dyn_atm(i,k) ![m s-1] Stokes' settling velocity SeP97 p. 466 - vlc_grv(i,k) = vlc_grv(i,k) * dispersion - - vlc_dry(i,k)=vlc_grv(i,k) - enddo - enddo - k=pver ! only look at bottom level for next part - do i=1,ncol - dff_aer = boltz * t(i,k) * slp_crc(i,k) / & ![m2 s-1] - (6.0_r8*pi*vsc_dyn_atm(i,k)*radius_moment(i,k)) !SeP97 p.474 - shm_nbr = vsc_knm_atm(i,k) / dff_aer ![frc] SeP97 p.972 - - wrk2 = 0._r8 - wrk3 = 0._r8 - do lt = 1,n_land_type - lnd_frc = fraction_landuse(i,lt,lchnk) - if ( lnd_frc /= 0._r8 ) then - brownian = shm_nbr**(-gamma(lt)) - if (radius_collector(lt) > 0.0_r8) then - ! vegetated surface - stk_nbr = vlc_grv(i,k) * fv(i) / (gravit*radius_collector(lt)) - interception = 2.0_r8*(radius_moment(i,k)/radius_collector(lt))**2.0_r8 - else - ! non-vegetated surface - stk_nbr = vlc_grv(i,k) * fv(i) * fv(i) / (gravit*vsc_knm_atm(i,k)) ![frc] SeP97 p.965 - interception = 0.0_r8 - endif - impaction = (stk_nbr/(alpha(lt)+stk_nbr))**2.0_r8 - - if (iwet(lt) > 0) then - stickfrac = 1.0_r8 - else - stickfrac = exp(-sqrt(stk_nbr)) - if (stickfrac < 1.0e-10_r8) stickfrac = 1.0e-10_r8 - endif - rss_lmn = 1.0_r8 / (3.0_r8 * fv(i) * stickfrac * (brownian+interception+impaction)) - rss_trb = ram1(i) + rss_lmn + ram1(i)*rss_lmn*vlc_grv(i,k) - - wrk1 = 1.0_r8 / rss_trb - wrk2 = wrk2 + lnd_frc*( wrk1 ) - wrk3 = wrk3 + lnd_frc*( wrk1 + vlc_grv(i,k) ) - endif - enddo ! n_land_type - vlc_trb(i) = wrk2 - vlc_dry(i,k) = wrk3 - enddo !ncol - - end subroutine oslo_aero_depvel_part - - !=============================================================================== - subroutine oslo_set_srf_wetdep(aerdepwetis, aerdepwetcw, cam_out) - - ! Set surface wet deposition fluxes passed to coupler. - - ! Arguments: - real(r8), intent(in) :: aerdepwetis(:,:) ! aerosol wet deposition (interstitial) - real(r8), intent(in) :: aerdepwetcw(:,:) ! aerosol wet deposition (cloud water) - type(cam_out_t), intent(inout) :: cam_out ! cam export state - - ! Local variables: - integer :: i - integer :: ncol ! number of columns - !---------------------------------------------------------------------------- - - cam_out%bcphiwet(:) = 0._r8 - cam_out%ocphiwet(:) = 0._r8 - - ! derive cam_out variables from deposition fluxes - ! note: wet deposition fluxes are negative into surface, - ! dry deposition fluxes are positive into surface. - ! srf models want positive definite fluxes. - ncol = cam_out%ncol - do i = 1,ncol - - ! black carbon fluxes - ! djlo : added bc_n and bc_ax contribution - ! djlo : bc_ax is assumed not to exist in cloud water - cam_out%bcphiwet(i) = -(aerdepwetis(i,l_bc_ni)+aerdepwetcw(i,l_bc_ni)+ & - aerdepwetis(i,l_bc_ai)+aerdepwetcw(i,l_bc_ai)+ & - aerdepwetis(i,l_bc_a )+aerdepwetcw(i,l_bc_a )+ & - aerdepwetis(i,l_bc_ac)+aerdepwetcw(i,l_bc_ac)+ & - aerdepwetis(i,l_bc_n )+aerdepwetcw(i,l_bc_n )+ & - aerdepwetis(i,l_bc_ax)) - - ! organic carbon fluxes - cam_out%ocphiwet(i) = -(aerdepwetis(i,l_om_ni)+aerdepwetcw(i,l_om_ni)+ & - aerdepwetis(i,l_om_ai)+aerdepwetcw(i,l_om_ai)+ & - aerdepwetis(i,l_om_ac)+aerdepwetcw(i,l_om_ac)) - - ! dust fluxes - ! - ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: - cam_out%dstwet1(i) = -(aerdepwetis(i,l_dst_a2)+aerdepwetcw(i,l_dst_a2)) - - ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: - cam_out%dstwet2(i) = 0._r8 - cam_out%dstwet3(i) = -(aerdepwetis(i,l_dst_a3)+aerdepwetcw(i,l_dst_a3)) - cam_out%dstwet4(i) = 0._r8 - - enddo - - end subroutine oslo_set_srf_wetdep - - !=============================================================================== - subroutine oslo_set_srf_drydep(aerdepdryis, aerdepdrycw, cam_out) - - ! Set surface dry deposition fluxes passed to coupler. - - ! Arguments: - real(r8), intent(in) :: aerdepdryis(:,:) ! aerosol dry deposition (interstitial) - real(r8), intent(in) :: aerdepdrycw(:,:) ! aerosol dry deposition (cloud water) - type(cam_out_t), intent(inout) :: cam_out ! cam export state - - ! Local variables: - integer :: i, idx - integer :: ncol ! number of columns - !---------------------------------------------------------------------------- - - cam_out%bcphidry(:) = 0._r8 - cam_out%bcphodry(:) = 0._r8 - cam_out%ocphidry(:) = 0._r8 - cam_out%ocphodry(:) = 0._r8 - - ! derive cam_out variables from deposition fluxes - ! note: wet deposition fluxes are negative into surface, - ! dry deposition fluxes are positive into surface. - ! srf models want positive definite fluxes. - ncol = cam_out%ncol - do i = 1, ncol - ! black carbon fluxes - cam_out%bcphidry(i) = aerdepdryis(i,l_bc_ni)+aerdepdrycw(i,l_bc_ni)+ & - aerdepdryis(i,l_bc_ai)+aerdepdrycw(i,l_bc_ai)+ & - aerdepdryis(i,l_bc_a )+aerdepdrycw(i,l_bc_a )+ & - aerdepdryis(i,l_bc_ac)+aerdepdrycw(i,l_bc_ac) - cam_out%bcphodry(i) = aerdepdryis(i,l_bc_n )+aerdepdrycw(i,l_bc_n )+ & - aerdepdryis(i,l_bc_ax)+aerdepdrycw(i,l_bc_ax) - - ! organic carbon fluxes - ! djlo : skipped the bc_a contribution (was about om !) - cam_out%ocphidry(i) = aerdepdryis(i,l_om_ni)+aerdepdrycw(i,l_om_ni)+ & - aerdepdryis(i,l_om_ai)+aerdepdrycw(i,l_om_ai)+ & - aerdepdryis(i,l_om_ac)+aerdepdrycw(i,l_om_ac) - cam_out%ocphidry(i) = 0._r8 - cam_out%ocphodry(i) = 0._r8 - - ! dust fluxes - ! bulk bin1 (fine) dust deposition equals accumulation mode deposition: - cam_out%dstdry1(i) = aerdepdryis(i,l_dst_a2)+aerdepdrycw(i,l_dst_a2) - - ! Two options for partitioning deposition into bins 2-4: - ! A. Simple: Assign all coarse-mode dust to bulk size bin 3: - cam_out%dstdry2(i) = 0._r8 - cam_out%dstdry3(i) = aerdepdryis(i,l_dst_a3)+aerdepdrycw(i,l_dst_a3) - cam_out%dstdry4(i) = 0._r8 - enddo - - end subroutine oslo_set_srf_drydep - - !=============================================================================== - subroutine calcram(ncol, landfrac, icefrac, ocnfrac, obklen, & - ustar, ram1in, ram1, t, pmid, pdel, fvin, fv) - - ! Calc aerodynamic resistance over oceans and sea ice (comes in from land model) - ! from Seinfeld and Pandis, p.963. Author: Natalie Mahowald - - integer , intent(in) :: ncol - real(r8) , intent(in) :: ram1in(pcols) ! aerodynamical resistance (s/m) - real(r8) , intent(in) :: fvin(pcols) ! sfc frc vel from land - real(r8) , intent(out) :: ram1(pcols) ! aerodynamical resistance (s/m) - real(r8) , intent(out) :: fv(pcols) ! sfc frc vel from land - real(r8) , intent(in) :: obklen(pcols) ! obklen - real(r8) , intent(in) :: ustar(pcols) ! sfc fric vel - real(r8) , intent(in) :: landfrac(pcols) ! land fraction - real(r8) , intent(in) :: icefrac(pcols) ! ice fraction - real(r8) , intent(in) :: ocnfrac(pcols) ! ocean fraction - real(r8) , intent(in) :: t(pcols) ! atm temperature (K) - real(r8) , intent(in) :: pmid(pcols) ! atm pressure (Pa) - real(r8) , intent(in) :: pdel(pcols) ! atm pressure (Pa) - - ! local variables - real(r8), parameter :: zzocen = 0.0001_r8 ! Ocean aerodynamic roughness length - real(r8), parameter :: zzsice = 0.0400_r8 ! Sea ice aerodynamic roughness length - real(r8), parameter :: xkar = 0.4_r8 ! Von Karman constant - real(r8) :: z,psi,psi0,nu,nu0,temp,ram - integer :: i - - do i = 1,ncol - z=pdel(i)*rair*t(i)/pmid(i)/gravit/2.0_r8 !use half the layer height like Ganzefeld and Lelieveld, 1995 - if(obklen(i).eq.0) then - psi=0._r8 - psi0=0._r8 - else - psi=min(max(z/obklen(i),-1.0_r8),1.0_r8) - psi0=min(max(zzocen/obklen(i),-1.0_r8),1.0_r8) - endif - temp=z/zzocen - if(icefrac(i) > 0.5_r8) then - if(obklen(i).gt.0) then - psi0=min(max(zzsice/obklen(i),-1.0_r8),1.0_r8) - else - psi0=0.0_r8 - endif - temp=z/zzsice - endif - if(psi> 0._r8) then - ram=1/xkar/ustar(i)*(log(temp)+4.7_r8*(psi-psi0)) - else - nu=(1.00_r8-15.000_r8*psi)**(.25_r8) - nu0=(1.000_r8-15.000_r8*psi0)**(.25_r8) - if(ustar(i).ne.0._r8) then - ram=1/xkar/ustar(i)*(log(temp) & - +log(((nu0**2+1.00_r8)*(nu0+1.0_r8)**2)/((nu**2+1.0_r8)*(nu+1.00_r8)**2)) & - +2.0_r8*(atan(nu)-atan(nu0))) - else - ram=0._r8 - endif - endif - if(landfrac(i) < 0.000000001_r8) then - fv(i)=ustar(i) - ram1(i)=ram - else - fv(i)=fvin(i) - ram1(i)=ram1in(i) - endif - enddo - - ! fvitt -- fv == 0 causes a floating point exception in dry dep of sea salts and dust - where ( fv(:ncol) == 0._r8 ) - fv(:ncol) = 1.e-12_r8 - endwhere - end subroutine calcram - - !============================================================================== - subroutine oslo_aero_wetdep_init() - - ! Initialize module variables for wet deposition - - cld_idx = pbuf_get_index('CLD') - qme_idx = pbuf_get_index('QME') - prain_idx = pbuf_get_index('PRAIN') - nevapr_idx = pbuf_get_index('NEVAPR') - - icwmrdp_idx = pbuf_get_index('ICWMRDP') - rprddp_idx = pbuf_get_index('RPRDDP') - icwmrsh_idx = pbuf_get_index('ICWMRSH') - rprdsh_idx = pbuf_get_index('RPRDSH') - sh_frac_idx = pbuf_get_index('SH_FRAC' ) - dp_frac_idx = pbuf_get_index('DP_FRAC') - nevapr_shcu_idx = pbuf_get_index('NEVAPR_SHCU') - nevapr_dpcu_idx = pbuf_get_index('NEVAPR_DPCU') - - call cnst_get_ind('CLDICE', ixcldice) - call cnst_get_ind('CLDLIQ', ixcldliq) - - endsubroutine oslo_aero_wetdep_init - - !============================================================================== - subroutine wetdep_inputs_set( state, pbuf, inputs ) - - ! gather up the inputs needed for the wetdepa routines - - ! arguments - type(physics_state), intent(in ) :: state ! physics state - type(physics_buffer_desc), pointer :: pbuf(:) ! physics buffer - type(wetdep_inputs_t), intent(out) :: inputs ! collection of wetdepa inputs - - ! local variables - real(r8), pointer :: icwmrdp(:,:) ! in cloud water mixing ratio, deep convection - real(r8), pointer :: rprddp(:,:) ! rain production, deep convection - real(r8), pointer :: icwmrsh(:,:) ! in cloud water mixing ratio, deep convection - real(r8), pointer :: rprdsh(:,:) ! rain production, deep convection - real(r8), pointer :: sh_frac(:,:) ! Shallow convective cloud fraction - real(r8), pointer :: dp_frac(:,:) ! Deep convective cloud fraction - real(r8), pointer :: evapcsh(:,:) ! Evaporation rate of shallow convective precipitation >=0. - real(r8), pointer :: evapcdp(:,:) ! Evaporation rate of deep convective precipitation >=0. - real(r8) :: rainmr(pcols,pver) ! mixing ratio of rain within cloud volume - real(r8) :: cldst(pcols,pver) ! Stratiform cloud fraction - integer :: itim, ncol - - ncol = state%ncol - itim = pbuf_old_tim_idx() - - call pbuf_get_field(pbuf, cld_idx, inputs%cldt, start=(/1,1,itim/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, qme_idx, inputs%qme ) - call pbuf_get_field(pbuf, prain_idx, inputs%prain ) - call pbuf_get_field(pbuf, nevapr_idx, inputs%evapr ) - call pbuf_get_field(pbuf, icwmrdp_idx, icwmrdp ) - call pbuf_get_field(pbuf, icwmrsh_idx, icwmrsh ) - call pbuf_get_field(pbuf, rprddp_idx, rprddp ) - call pbuf_get_field(pbuf, rprdsh_idx, rprdsh ) - call pbuf_get_field(pbuf, sh_frac_idx, sh_frac ) - call pbuf_get_field(pbuf, dp_frac_idx, dp_frac ) - call pbuf_get_field(pbuf, nevapr_shcu_idx, evapcsh ) - call pbuf_get_field(pbuf, nevapr_dpcu_idx, evapcdp ) - - inputs%cldcu(:ncol,:) = dp_frac(:ncol,:) + sh_frac(:ncol,:) - cldst(:ncol,:) = inputs%cldt(:ncol,:) - inputs%cldcu(:ncol,:) ! Stratiform cloud fraction - inputs%evapc(:ncol,:) = evapcsh(:ncol,:) + evapcdp(:ncol,:) - inputs%cmfdqr(:ncol,:) = rprddp(:ncol,:) + rprdsh(:ncol,:) - - ! sum deep and shallow convection contributions - if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then - inputs%conicw(:ncol,:) = (icwmrdp(:ncol,:)*dp_frac(:ncol,:) + icwmrsh(:ncol,:)*sh_frac(:ncol,:))/ & - max(0.01_r8, sh_frac(:ncol,:) + dp_frac(:ncol,:)) - else - inputs%conicw(:ncol,:) = icwmrdp(:ncol,:) + icwmrsh(:ncol,:) - end if - - inputs%totcond(:ncol,:) = state%q(:ncol,:,ixcldliq) + state%q(:ncol,:,ixcldice) - - call clddiag( state%t, state%pmid, state%pdel, inputs%cmfdqr, inputs%evapc, & - inputs%cldt, inputs%cldcu, cldst, inputs%qme, inputs%evapr, & - inputs%prain, inputs%cldv, inputs%cldvcu, inputs%cldvst, rainmr, state%ncol ) - - end subroutine wetdep_inputs_set - - !============================================================================== - subroutine clddiag(t, pmid, pdel, cmfdqr, evapc, & - cldt, cldcu, cldst, cme, evapr, & - prain, cldv, cldvcu, cldvst, rain, ncol) - - ! ------------------------------------------------------------------------------------ - ! Estimate the cloudy volume which is occupied by rain or cloud water as - ! the max between the local cloud amount or the - ! sum above of (cloud*positive precip production) sum total precip from above - ! ---------------------------------- x ------------------------ - ! sum above of (positive precip ) sum positive precip from above - ! Author: P. Rasch, Sungsu Park. Mar.2010 - ! ------------------------------------------------------------------------------------ - - ! Input arguments: - real(r8) , intent(in) :: t(pcols,pver) ! temperature (K) - real(r8) , intent(in) :: pmid(pcols,pver) ! pressure at layer midpoints - real(r8) , intent(in) :: pdel(pcols,pver) ! pressure difference across layers - real(r8) , intent(in) :: cmfdqr(pcols,pver) ! dq/dt due to convective rainout - real(r8) , intent(in) :: evapc(pcols,pver) ! Evaporation rate of convective precipitation ( >= 0 ) - real(r8) , intent(in) :: cldt(pcols,pver) ! total cloud fraction - real(r8) , intent(in) :: cldcu(pcols,pver) ! Cumulus cloud fraction - real(r8) , intent(in) :: cldst(pcols,pver) ! Stratus cloud fraction - real(r8) , intent(in) :: cme(pcols,pver) ! rate of cond-evap within the cloud - real(r8) , intent(in) :: evapr(pcols,pver) ! rate of evaporation of falling precipitation (kg/kg/s) - real(r8) , intent(in) :: prain(pcols,pver) ! rate of conversion of condensate to precipitation (kg/kg/s) - integer , intent(in) :: ncol - - ! Output arguments: - real(r8), intent(out) :: cldv(pcols,pver) ! fraction occupied by rain or cloud water - real(r8), intent(out) :: cldvcu(pcols,pver) ! Convective precipitation volume - real(r8), intent(out) :: cldvst(pcols,pver) ! Stratiform precipitation volume - real(r8), intent(out) :: rain(pcols,pver) ! mixing ratio of rain (kg/kg) - - ! Local variables: - integer i, k - real(r8) convfw ! used in fallspeed calculation; taken from findmcnew - real(r8) sumppr(pcols) ! precipitation rate (kg/m2-s) - real(r8) sumpppr(pcols) ! sum of positive precips from above - real(r8) cldv1(pcols) ! precip weighted cloud fraction from above - real(r8) lprec ! local production rate of precip (kg/m2/s) - real(r8) lprecp ! local production rate of precip (kg/m2/s) if positive - real(r8) rho ! air density - real(r8) vfall - real(r8) sumppr_cu(pcols) ! Convective precipitation rate (kg/m2-s) - real(r8) sumpppr_cu(pcols) ! Sum of positive convective precips from above - real(r8) cldv1_cu(pcols) ! Convective precip weighted convective cloud fraction from above - real(r8) lprec_cu ! Local production rate of convective precip (kg/m2/s) - real(r8) lprecp_cu ! Local production rate of convective precip (kg/m2/s) if positive - real(r8) sumppr_st(pcols) ! Stratiform precipitation rate (kg/m2-s) - real(r8) sumpppr_st(pcols) ! Sum of positive stratiform precips from above - real(r8) cldv1_st(pcols) ! Stratiform precip weighted stratiform cloud fraction from above - real(r8) lprec_st ! Local production rate of stratiform precip (kg/m2/s) - real(r8) lprecp_st ! Local production rate of stratiform precip (kg/m2/s) if positive - ! ----------------------------------------------------------------------- - - convfw = 1.94_r8*2.13_r8*sqrt(rhoh2o*gravit*2.7e-4_r8) - do i=1,ncol - sumppr(i) = 0._r8 - cldv1(i) = 0._r8 - sumpppr(i) = 1.e-36_r8 - sumppr_cu(i) = 0._r8 - cldv1_cu(i) = 0._r8 - sumpppr_cu(i) = 1.e-36_r8 - sumppr_st(i) = 0._r8 - cldv1_st(i) = 0._r8 - sumpppr_st(i) = 1.e-36_r8 - end do - - do k = 1,pver - do i = 1,ncol - cldv(i,k) = & - max(min(1._r8, & - cldv1(i)/sumpppr(i) & - )*sumppr(i)/sumpppr(i), & - cldt(i,k) & - ) - lprec = pdel(i,k)/gravit * (prain(i,k)+cmfdqr(i,k)-evapr(i,k)) - lprecp = max(lprec,1.e-30_r8) - cldv1(i) = cldv1(i) + cldt(i,k)*lprecp - sumppr(i) = sumppr(i) + lprec - sumpppr(i) = sumpppr(i) + lprecp - - ! For convective precipitation volume at the top interface of each layer. Neglect the current layer. - cldvcu(i,k) = max(min(1._r8,cldv1_cu(i)/sumpppr_cu(i))*(sumppr_cu(i)/sumpppr_cu(i)),0._r8) - lprec_cu = (pdel(i,k)/gravit)*(cmfdqr(i,k)-evapc(i,k)) - lprecp_cu = max(lprec_cu,1.e-30_r8) - cldv1_cu(i) = cldv1_cu(i) + cldcu(i,k)*lprecp_cu - sumppr_cu(i) = sumppr_cu(i) + lprec_cu - sumpppr_cu(i) = sumpppr_cu(i) + lprecp_cu - - ! For stratiform precipitation volume at the top interface of each layer. Neglect the current layer. - cldvst(i,k) = max(min(1._r8,cldv1_st(i)/sumpppr_st(i))*(sumppr_st(i)/sumpppr_st(i)),0._r8) - lprec_st = (pdel(i,k)/gravit)*(prain(i,k)-evapr(i,k)) - lprecp_st = max(lprec_st,1.e-30_r8) - cldv1_st(i) = cldv1_st(i) + cldst(i,k)*lprecp_st - sumppr_st(i) = sumppr_st(i) + lprec_st - sumpppr_st(i) = sumpppr_st(i) + lprecp_st - - rain(i,k) = 0._r8 - if(t(i,k) .gt. tmelt) then - rho = pmid(i,k)/(rair*t(i,k)) - vfall = convfw/sqrt(rho) - rain(i,k) = sumppr(i)/(rho*vfall) - if (rain(i,k).lt.1.e-14_r8) rain(i,k) = 0._r8 - endif - end do - end do - - end subroutine clddiag - - !============================================================================== - subroutine wetdepa_v2( & - p, q, pdel, cldt, cldc, & - cmfdqr, evapc, conicw, precs, conds, & - evaps, cwat, tracer, deltat, scavt, & - iscavt, cldvcu, cldvst, dlf, fracis, & - sol_fact, ncol, scavcoef, is_strat_cloudborne, qqcw, & - f_act_conv, icscavt, isscavt, bcscavt, bsscavt, & - convproc_do_aer, rcscavt, rsscavt, & - sol_facti_in, sol_factic_in ) - - !----------------------------------------------------------------------- - ! scavenging code for very soluble aerosols - ! This is the CAM5 version of wetdepa. - !----------------------------------------------------------------------- - - real(r8), intent(in) ::& - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - evapc(pcols,pver), &! Evaporation rate of convective precipitation - conicw(pcols,pver), &! convective cloud water - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - conds(pcols,pver), &! rate of production of condensate - evaps(pcols,pver), &! rate of evaporation of precip - cldvcu(pcols,pver), &! Convective precipitation area at the top interface of each layer - cldvst(pcols,pver), &! Stratiform precipitation area at the top interface of each layer - dlf(pcols,pver), &! Detrainment of convective condensate [kg/kg/s] - deltat, &! time step - tracer(pcols,pver) ! trace species - - ! If subroutine is called with just sol_fact: - ! sol_fact is used for both in- and below-cloud scavenging - ! If subroutine is called with optional argument sol_facti_in: - ! sol_fact is used for below cloud scavenging - ! sol_facti is used for in cloud scavenging - - real(r8), intent(in) :: sol_fact - integer, intent(in) :: ncol - real(r8), intent(in) :: scavcoef(pcols,pver) ! Dana and Hales coefficient (/mm) (0.1 if not MODAL_AERO) - real(r8), intent(out) :: scavt(pcols,pver) ! scavenging tend - real(r8), intent(out) :: iscavt(pcols,pver) ! incloud scavenging tends - real(r8), intent(out) :: fracis(pcols,pver) ! fraction of species not scavenged - - ! Setting is_strat_cloudborne=.true. indicates that tracer is stratiform-cloudborne aerosol. - ! This is only used by MAM code. The optional args qqcw and f_act_conv are not referenced - ! in this case. - ! Setting is_strat_cloudborne=.false. is being used to indicate that the tracers are the - ! interstitial modal aerosols. In this case the optional qqcw (the cloud borne mixing ratio - ! corresponding to the interstitial aerosol) must be provided, as well as the optional f_act_conv. - - logical, intent(in), optional :: is_strat_cloudborne - real(r8), intent(in), optional :: qqcw(pcols,pver) - real(r8), intent(in), optional :: f_act_conv(pcols,pver) - - real(r8), intent(in), optional :: sol_facti_in ! solubility factor (frac of aerosol scavenged in cloud) - real(r8), intent(in), optional :: sol_factic_in(pcols,pver) ! sol_facti_in for convective clouds - - real(r8), intent(out), optional :: icscavt(pcols,pver) ! incloud, convective - real(r8), intent(out), optional :: isscavt(pcols,pver) ! incloud, stratiform - real(r8), intent(out), optional :: bcscavt(pcols,pver) ! below cloud, convective - real(r8), intent(out), optional :: bsscavt(pcols,pver) ! below cloud, stratiform - - ! Setting convproc_do_aer=.true. removes the resuspension term from bcscavt and - ! bsscavt and returns those terms as rcscavt and rsscavt respectively. - logical, intent(in), optional :: convproc_do_aer - real(r8), intent(out), optional :: rcscavt(pcols,pver) ! resuspension, convective - real(r8), intent(out), optional :: rsscavt(pcols,pver) ! resuspension, stratiform - - ! local variables - integer :: i, k - logical :: out_resuspension - real(r8) :: omsm ! 1 - (a small number) - real(r8) :: clds(pcols) ! stratiform cloud fraction - real(r8) :: fracev(pcols) ! fraction of precip from above that is evaporating - real(r8) :: fracev_cu(pcols) ! Fraction of convective precip from above that is evaporating - real(r8) :: fracp(pcols) ! fraction of cloud water converted to precip - real(r8) :: pdog(pcols) ! work variable (pdel/gravit) - real(r8) :: rpdog(pcols) ! work variable (gravit/pdel) - real(r8) :: precabc(pcols) ! conv precip from above (work array) - real(r8) :: precabs(pcols) ! strat precip from above (work array) - real(r8) :: rat(pcols) ! ratio of amount available to amount removed - real(r8) :: scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) :: scavabc(pcols) ! scavenged tracer flux from above (work array) - real(r8) :: srcc(pcols) ! tend for convective rain - real(r8) :: srcs(pcols) ! tend for stratiform rain - real(r8) :: srct(pcols) ! work variable - - real(r8) :: fins(pcols) ! fraction of rem. rate by strat rain - real(r8) :: finc(pcols) ! fraction of rem. rate by conv. rain - real(r8) :: conv_scav_ic(pcols) ! convective scavenging incloud - real(r8) :: conv_scav_bc(pcols) ! convective scavenging below cloud - real(r8) :: st_scav_ic(pcols) ! stratiform scavenging incloud - real(r8) :: st_scav_bc(pcols) ! stratiform scavenging below cloud - - real(r8) :: odds(pcols) ! limit on removal rate (proportional to prec) - real(r8) :: dblchek(pcols) - logical :: found - - real(r8) :: trac_qqcw(pcols) - real(r8) :: tracer_incu(pcols) - real(r8) :: tracer_mean(pcols) - - ! For stratiform cloud, cloudborne aerosol is treated explicitly, - ! and sol_facti is 1.0 for cloudborne, 0.0 for interstitial. - ! For convective cloud, cloudborne aerosol is not treated explicitly, - ! and sol_factic is 1.0 for both cloudborne and interstitial. - - real(r8) :: sol_facti ! in cloud fraction of aerosol scavenged - real(r8) :: sol_factb ! below cloud fraction of aerosol scavenged - real(r8) :: sol_factic(pcols,pver) ! in cloud fraction of aerosol scavenged for convective clouds - - real(r8) :: rdeltat - ! ------------------------------------------------------------------------ - - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - - ! default (if other sol_facts aren't in call, set all to required sol_fact) - sol_facti = sol_fact - sol_factb = sol_fact - - if ( present(sol_facti_in) ) sol_facti = sol_facti_in - - sol_factic = sol_facti - if ( present(sol_factic_in ) ) sol_factic = sol_factic_in - - ! Determine whether resuspension fields are output. - out_resuspension = .false. - if (present(convproc_do_aer)) then - if (convproc_do_aer) then - if (present(bcscavt) .and. present(bsscavt) .and. & - present(rcscavt) .and. present(rsscavt) ) then - out_resuspension = .true. - else - call endrun('wetdepa_v2: bcscavt, bsscavt, rcscavt, rsscavt'// & - ' must be present when convproc_do_aero true') - end if - end if - end if - - ! this section of code is for highly soluble aerosols, - ! the assumption is that within the cloud that - ! all the tracer is in the cloud water - ! - ! for both convective and stratiform clouds, - ! the fraction of cloud water converted to precip defines - ! the amount of tracer which is pulled out. - - precabs(:ncol) = 0.0_r8 - precabc(:ncol) = 0.0_r8 - scavab(:ncol) = 0.0_r8 - scavabc(:ncol) = 0.0_r8 - - do k = 1, pver - do i = 1, ncol - - clds(i) = cldt(i,k) - cldc(i,k) - pdog(i) = pdel(i,k)/gravit - rpdog(i) = gravit/pdel(i,k) - rdeltat = 1.0_r8/deltat - - ! ****************** Evaporation ************************** - ! calculate the fraction of strat precip from above - ! which evaporates within this layer - fracev(i) = evaps(i,k)*pdog(i) & - /max(1.e-12_r8,precabs(i)) - - ! trap to ensure reasonable ratio bounds - fracev(i) = max(0._r8,min(1._r8,fracev(i))) - - ! Same as above but convective precipitation part - fracev_cu(i) = evapc(i,k)*pdog(i)/max(1.e-12_r8,precabc(i)) - fracev_cu(i) = max(0._r8,min(1._r8,fracev_cu(i))) - - ! ****************** Convection *************************** - ! - ! set odds proportional to fraction of the grid box that is swept by the - ! precipitation =precabc/rhoh20*(area of sphere projected on plane - ! /volume of sphere)*deltat - ! assume the radius of a raindrop is 1 e-3 m from Rogers and Yau, - ! unless the fraction of the area that is cloud is less than odds, in which - ! case use the cloud fraction (assumes precabs is in kg/m2/s) - ! is really: precabs*3/4/1000./1e-3*deltat - ! here I use .1 from Balkanski - ! - ! use a local rate of convective rain production for incloud scav - ! - ! Fraction of convective cloud water converted to rain. This version is used - ! in 2 of the 3 branches below before fracp is reused in the stratiform calc. - ! NB: In below formula for fracp conicw is a LWC/IWC that has already - ! precipitated out, i.e., conicw does not contain precipitation - - fracp(i) = cmfdqr(i,k)*deltat / & - max( 1.e-12_r8, cldc(i,k)*conicw(i,k) + (cmfdqr(i,k)+dlf(i,k))*deltat ) - fracp(i) = max( min( 1._r8, fracp(i)), 0._r8 ) - - if ( present(is_strat_cloudborne) ) then - - if ( is_strat_cloudborne ) then - - ! convective scavenging - - conv_scav_ic(i) = 0._r8 - - conv_scav_bc(i) = 0._r8 - - ! stratiform scavenging - - fracp(i) = precs(i,k)*deltat / & - max( 1.e-12_r8, cwat(i,k) + precs(i,k)*deltat ) - fracp(i) = max( 0._r8, min(1._r8, fracp(i)) ) - st_scav_ic(i) = sol_facti *fracp(i)*tracer(i,k)*rdeltat - - st_scav_bc(i) = 0._r8 - - else - - ! convective scavenging - - trac_qqcw(i) = min(qqcw(i,k), & - tracer(i,k)*( clds(i)/max( 0.01_r8, 1._r8-clds(i) ) ) ) - - tracer_incu(i) = f_act_conv(i,k)*(tracer(i,k) + trac_qqcw(i)) - - conv_scav_ic(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer_incu(i)*rdeltat - - tracer_mean(i) = tracer(i,k)*(1._r8 - cldc(i,k)*f_act_conv(i,k)) - & - cldc(i,k)*f_act_conv(i,k)*trac_qqcw(i) - tracer_mean(i) = max(0._r8,tracer_mean(i)) - - odds(i) = precabc(i)/max(cldvcu(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - conv_scav_bc(i) = sol_factb *cldvcu(i,k)*odds(i)*tracer_mean(i)*rdeltat - - - ! stratiform scavenging - - st_scav_ic(i) = 0._r8 - - odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - st_scav_bc(i) = sol_factb *cldvst(i,k)*odds(i)*tracer_mean(i)*rdeltat - - end if - - else - - ! convective scavenging - - conv_scav_ic(i) = sol_factic(i,k)*cldc(i,k)*fracp(i)*tracer(i,k)*rdeltat - - odds(i) = precabc(i)/max(cldvcu(i,k), 1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max( min(1._r8, odds(i)), 0._r8) - conv_scav_bc(i) = sol_factb*cldvcu(i,k)*odds(i)*tracer(i,k)*rdeltat - - ! stratiform scavenging - - ! fracp is the fraction of cloud water converted to precip - ! NB: In below formula for fracp cwat is a LWC/IWC that has already - ! precipitated out, i.e., cwat does not contain precipitation - fracp(i) = precs(i,k)*deltat / & - max( 1.e-12_r8, cwat(i,k) + precs(i,k)*deltat ) - fracp(i) = max( 0._r8, min( 1._r8, fracp(i) ) ) - - ! assume the corresponding amnt of tracer is removed - st_scav_ic(i) = sol_facti*clds(i)*fracp(i)*tracer(i,k)*rdeltat - - odds(i) = precabs(i)/max(cldvst(i,k),1.e-5_r8)*scavcoef(i,k)*deltat - odds(i) = max(min(1._r8,odds(i)),0._r8) - st_scav_bc(i) =sol_factb*(cldvst(i,k)*odds(i)) *tracer(i,k)*rdeltat - - end if - - ! total convective scavenging - srcc(i) = conv_scav_ic(i) + conv_scav_bc(i) - finc(i) = conv_scav_ic(i)/(srcc(i) + 1.e-36_r8) - - ! total stratiform scavenging - srcs(i) = st_scav_ic(i) + st_scav_bc(i) - fins(i) = st_scav_ic(i)/(srcs(i) + 1.e-36_r8) - - ! make sure we dont take out more than is there - ! ratio of amount available to amount removed - rat(i) = tracer(i,k)/max(deltat*(srcc(i)+srcs(i)),1.e-36_r8) - if (rat(i).lt.1._r8) then - srcs(i) = srcs(i)*rat(i) - srcc(i) = srcc(i)*rat(i) - endif - srct(i) = (srcc(i)+srcs(i))*omsm - - - ! fraction that is not removed within the cloud - ! (assumed to be interstitial, and subject to convective transport) - fracp(i) = deltat*srct(i)/max(cldvst(i,k)*tracer(i,k),1.e-36_r8) ! amount removed - fracp(i) = max(0._r8,min(1._r8,fracp(i))) - fracis(i,k) = 1._r8 - fracp(i) - - ! tend is all tracer removed by scavenging, plus all re-appearing from evaporation above - ! Sungsu added cumulus contribution in the below 3 blocks - scavt(i,k) = -srct(i) + (fracev(i)*scavab(i)+fracev_cu(i)*scavabc(i))*rpdog(i) - iscavt(i,k) = -(srcc(i)*finc(i) + srcs(i)*fins(i))*omsm - - if ( present(icscavt) ) icscavt(i,k) = -(srcc(i)*finc(i)) * omsm - if ( present(isscavt) ) isscavt(i,k) = -(srcs(i)*fins(i)) * omsm - - if (.not. out_resuspension) then - if (present(bcscavt)) bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm + & - fracev_cu(i)*scavabc(i)*rpdog(i) - - if (present(bsscavt)) bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm + & - fracev(i)*scavab(i)*rpdog(i) - else - bcscavt(i,k) = -(srcc(i) * (1-finc(i))) * omsm - rcscavt(i,k) = fracev_cu(i)*scavabc(i)*rpdog(i) - - bsscavt(i,k) = -(srcs(i) * (1-fins(i))) * omsm - rsscavt(i,k) = fracev(i)*scavab(i)*rpdog(i) - end if - - dblchek(i) = tracer(i,k) + deltat*scavt(i,k) - - ! now keep track of scavenged mass and precip - scavab(i) = scavab(i)*(1-fracev(i)) + srcs(i)*pdog(i) - precabs(i) = precabs(i) + (precs(i,k) - evaps(i,k))*pdog(i) - scavabc(i) = scavabc(i)*(1-fracev_cu(i)) + srcc(i)*pdog(i) - precabc(i) = precabc(i) + (cmfdqr(i,k) - evapc(i,k))*pdog(i) - - end do ! End of i = 1, ncol - - found = .false. - do i = 1,ncol - if ( dblchek(i) < 0._r8 ) then - found = .true. - exit - end if - end do - - if ( found ) then - do i = 1,ncol - if (dblchek(i) .lt. 0._r8) then - write(iulog,*) ' wetdapa: negative value ', i, k, tracer(i,k), & - dblchek(i), scavt(i,k), srct(i), rat(i), fracev(i) - endif - end do - endif - - end do ! End of k = 1, pver - - end subroutine wetdepa_v2 - - !============================================================================== - subroutine wetdepg( t, p, q, pdel, & - cldt, cldc, cmfdqr, evapc, precs, evaps, & - rain, cwat, tracer, deltat, molwt, & - solconst, scavt, iscavt, cldv, icwmr1, & - icwmr2, fracis, ncol ) - - !----------------------------------------------------------------------- - ! scavenging of gas phase constituents by henry's law ( Author: P. Rasch) - !----------------------------------------------------------------------- - - real(r8), intent(in) ::& - t(pcols,pver), &! temperature - p(pcols,pver), &! pressure - q(pcols,pver), &! moisture - pdel(pcols,pver), &! pressure thikness - cldt(pcols,pver), &! total cloud fraction - cldc(pcols,pver), &! convective cloud fraction - cmfdqr(pcols,pver), &! rate of production of convective precip - rain (pcols,pver), &! total rainwater mixing ratio - cwat(pcols,pver), &! cloud water amount - precs(pcols,pver), &! rate of production of stratiform precip - evaps(pcols,pver), &! rate of evaporation of precip - evapc(pcols,pver), &! Rate of evaporation of convective precipitation - cldv(pcols,pver), &! estimate of local volume occupied by clouds - icwmr1 (pcols,pver), &! in cloud water mixing ration for zhang scheme - icwmr2 (pcols,pver), &! in cloud water mixing ration for hack scheme - deltat, &! time step - tracer(pcols,pver), &! trace species - molwt ! molecular weights - - integer, intent(in) :: ncol - - real(r8) & - solconst(pcols,pver) ! Henry's law coefficient - - real(r8), intent(out) ::& - scavt(pcols,pver), &! scavenging tend - iscavt(pcols,pver), &! incloud scavenging tends - fracis(pcols, pver) ! fraction of constituent that is insoluble - - ! local variables - integer i ! x index - integer k ! z index - real(r8) adjfac ! factor stolen from cmfmca - real(r8) aqfrac ! fraction of tracer in aqueous phase - real(r8) cwatc ! local convective total water amount - real(r8) cwats ! local stratiform total water amount - real(r8) cwatl ! local cloud liq water amount - real(r8) cwatp ! local water amount falling from above precip - real(r8) cwatpl ! local water amount falling from above precip (liq) - real(r8) cwatt ! local sum of strat + conv total water amount - real(r8) cwatti ! cwatt/cldv = cloudy grid volume mixing ratio - real(r8) fracev ! fraction of precip from above that is evaporating - real(r8) fracp ! fraction of cloud water converted to precip - real(r8) gafrac ! fraction of tracer in gas phasea - real(r8) hconst ! henry's law solubility constant when equation is expressed - ! in terms of mixing ratios - real(r8) mpla ! moles / liter H2O entering the layer from above - real(r8) mplb ! moles / liter H2O leaving the layer below - real(r8) omsm ! 1 - (a small number) - real(r8) part ! partial pressure of tracer in atmospheres - real(r8) patm ! total pressure in atmospheres - real(r8) pdog ! work variable (pdel/gravit) - real(r8) precab(pcols) ! precip from above (work array) - real(r8) precbl ! precip work variable - real(r8) precxx ! precip work variable - real(r8) precxx2 ! - real(r8) precic ! precip work variable - real(r8) rat ! ratio of amount available to amount removed - real(r8) scavab(pcols) ! scavenged tracer flux from above (work array) - real(r8) scavabc(pcols) ! scavenged tracer flux from above (work array) - - real(r8) scavmax ! an estimate of the max tracer avail for removal - real(r8) scavbl ! flux removed at bottom of layer - real(r8) fins ! in cloud fraction removed by strat rain - real(r8) finc ! in cloud fraction removed by conv rain - real(r8) rate ! max removal rate estimate - real(r8) scavlimt ! limiting value 1 - real(r8) scavt1 ! limiting value 2 - real(r8) scavin ! scavenging by incloud processes - real(r8) scavbc ! scavenging by below cloud processes - real(r8) tc - real(r8) weight ! ice fraction - real(r8) wtpl ! work variable - real(r8) cldmabs(pcols) ! maximum cloud at or above this level - real(r8) cldmabc(pcols) ! maximum cloud at or above this level - !----------------------------------------------------------- - - omsm = 1._r8-2*epsilon(1._r8) ! used to prevent roundoff errors below zero - - adjfac = deltat/(max(deltat,cmftau)) ! adjustment factor from hack scheme - - ! zero accumulators - do i = 1,pcols - precab(i) = 1.e-36_r8 - scavab(i) = 0._r8 - cldmabs(i) = 0._r8 - end do - - do k = 1,pver - do i = 1,ncol - tc = t(i,k) - tmelt - weight = max(0._r8,min(-tc*0.05_r8,1.0_r8)) ! fraction of condensate that is ice - - cldmabs(i) = max(cldmabs(i),cldt(i,k)) - - ! partitioning coefs for gas and aqueous phase - ! take as a cloud water amount, the sum of the stratiform amount - ! plus the convective rain water amount - - ! convective amnt is just the local precip rate from the hack scheme - ! since there is no storage of water, this ignores that falling from above - cwatc = (icwmr1(i,k) + icwmr2(i,k)) * (1._r8-weight) - - ! strat cloud water amount and also ignore the part falling from above - cwats = cwat(i,k) - - ! cloud water as liq - cwatl = (1._r8-weight)*cwats - - ! cloud water as ice total suspended condensate as liquid - cwatt = cwatl + rain(i,k) - - ! incloud version - cwatti = cwatt/max(cldv(i,k), 0.00001_r8) + cwatc - - ! partitioning terms - patm = p(i,k)/1.013e5_r8 ! pressure in atmospheres - hconst = molwta*patm*solconst(i,k)*cwatti/rhoh2o - aqfrac = hconst/(1._r8+hconst) - gafrac = 1/(1._r8+hconst) - fracis(i,k) = gafrac - - ! partial pressure of the tracer in the gridbox in atmospheres - part = patm*gafrac*tracer(i,k)*molwta/molwt - - ! use henrys law to give moles tracer /liter of water in this volume - ! then convert to kg tracer /liter of water (kg tracer / kg water) - mplb = solconst(i,k)*part*molwt/1000._r8 - - pdog = pdel(i,k)/gravit - - ! this part of precip will be carried downward but at a new molarity of mpl - precic = pdog*(precs(i,k) + cmfdqr(i,k)) - - ! we cant take out more than entered, plus that available in the cloud - scavmax = scavab(i)+tracer(i,k)*cldv(i,k)/deltat*pdog - - ! flux of tracer by incloud processes - scavin = precic*(1._r8-weight)*mplb - - ! fraction of precip which entered above that leaves below - if (cam_physpkg_is('cam5') .or. cam_physpkg_is('cam6')) then - ! Sungsu added evaporation of convective precipitation below. - precxx = precab(i)-pdog*(evaps(i,k)+evapc(i,k)) - else - precxx = precab(i)-pdog*evaps(i,k) - end if - precxx = max (precxx,0.0_r8) - - ! flux of tracer by below cloud processes - if (tc.gt.0) then - scavbc = precxx*mplb ! if liquid - else - precxx2=max(precxx,1.e-36_r8) - scavbc = scavab(i)*precxx2/(precab(i)) ! if ice - endif - - scavbl = min(scavbc + scavin, scavmax) - - ! first guess assuming that henries law works - scavt1 = (scavab(i)-scavbl)/pdog*omsm - - ! pjr this should not be required, but we put it in to make sure we cant remove too much - ! remember, scavt1 is generally negative (indicating removal) - scavt1 = max(scavt1,-tracer(i,k)*cldv(i,k)/deltat) - - ! instead just set scavt to scavt1 - scavt(i,k) = scavt1 - - ! now update the amount leaving the layer - scavbl = scavab(i) - scavt(i,k)*pdog - - ! in cloud amount is that formed locally over the total flux out bottom - fins = scavin/(scavin + scavbc + 1.e-36_r8) - iscavt(i,k) = scavt(i,k)*fins - - scavab(i) = scavbl - precab(i) = max(precxx + precic,1.e-36_r8) - - end do - end do - - end subroutine wetdepg - -end module oslo_aero_depos diff --git a/src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 b/src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 deleted file mode 100644 index 480ace2042..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_diurnal_var.F90 +++ /dev/null @@ -1,488 +0,0 @@ -module oslo_aero_diurnal_var - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only : pcols, pver - use phys_grid, only : get_rlat_all_p, get_rlon_all_p - use chem_mods, only : nfs - use physconst, only : pi - use time_manager, only : get_curr_date - use mo_chem_utls, only : get_inv_ndx - - implicit none - private - - public :: set_diurnal_invariants - - private :: sunrisesetxx , srisesetxx - - integer, pointer :: id_oh,id_no3,id_ho2 - logical :: inv_oh,inv_ho2,inv_no3 - -contains - - subroutine set_diurnal_invariants(invariants,dtc,ncol,lchnk,inv_oh,inv_ho2,id_oh,id_ho2, inv_no3, id_no3) - - real(r8) , intent(in) :: dtc ! Time step - integer , intent(in) :: ncol - integer , intent(in) :: lchnk ! chunk id - logical , intent(in) :: inv_oh, inv_ho2, inv_no3 - integer , intent(in) :: id_oh, id_ho2, id_no3 - real(r8) , intent(inout) :: invariants(ncol,pver,nfs) - - integer :: i ! column index - integer :: k ! height index - integer :: iriseset ! sunrise/set flag - integer :: day, mon, yr, jyr ! date stuff - integer :: j ! working var - integer :: ncsec ! time stuff - real(r8) :: deglat, deglon ! lat and long (degrees) - real(r8) :: solardec ! solar declination (degrees) - real(r8) :: sum ! working vars - real(r8) :: trise, tset ! sunrise and set times (h then d) - real(r8) :: tlight ! amount of daylight (d) - real(r8) :: trisej, tsetj ! working vars - real(r8) :: t1, t2, ta, tb ! working vars - real(r8) :: rlats(pcols), rlons(pcols) ! latitude & longitude (radians) - real(r8) :: fdiurn_oxid - real(r8) :: fdiurn_no3oxid - - call get_curr_date(yr, mon, day, ncsec) - call get_rlat_all_p( lchnk, ncol, rlats ) - call get_rlon_all_p( lchnk, ncol, rlons ) - - ! jyr = mod( yr, 100 ) + 1900 - ! if (jyr < 1950) jyr = jyr + 100 - ! if (jyr > 2049) jyr = jyr - 100 - jyr=2000 - ! Assume the daily cycle to follow year 2000. The subroutine is - ! at any rate only valid between 1950 and 2050, so important years e.g. 1850 - ! is out of boundary - - do i=1,ncol - - fdiurn_oxid=1._r8 - fdiurn_no3oxid=1._r8 - - deglat = rlats(i)*180._r8/pi - deglat = max( -89.9999_r8, min( +89.9999_r8, deglat ) ) - deglon = rlons(i)*180._r8/pi - - ! get sunrise and sunset times in UTC hours - call sunrisesetxx( deglon, deglat, jyr, mon, day, iriseset, trise, tset, solardec ) - - ! convert rise/set times to days - ! compute tlight = amount of daylight - ! handle case of all day or night - if (iriseset > 0) then - trise = trise/24._r8 - tset = tset/24._r8 - tlight = tset - trise - if (tlight < 0._r8) then - tset = tset + 1.0_r8 - tlight = tlight + 1._r8 - end if - else - trise = 0._r8 - if (abs(deglat+solardec) .ge. 90._r8) then - tset = 1._r8 - else - tset = 0._r8 - end if - tlight = tset - trise !length of light period in a day - end if - - ! if all day or all night (or very close to it), set fdiurn = 1.0 - ! Also in periods with all night, we put the mean value for all night steps - if ((tlight .ge. 0.99_r8) .or. (tlight .le. 0.01_r8)) then - fdiurn_oxid = 1._r8 - fdiurn_no3oxid = 1._r8 !++IH - ! otherwise determine overlap between current timestep and daylight times - ! to account for all overlap possibilities, need to try this - ! with rise/set times shifted by +/- 1 day - else !==> There is diurnal cycle - t1 = ncsec/86400._r8 !start of timestep (days) - t2 = t1 + dtc/86400._r8 !end of timestep (days) - sum = 0._r8 - do j = -1, 1 - trisej = trise + dfloat(j) !one day before sunrise, sunrise, one day after runrise - tsetj = trisej + tlight !time of sunset given "j" - ta = max( t1, trisej ) !start or sunrise (if later) - tb = min( t2, tsetj ) !end of step or sunset (if earlier) - sum = sum + max( tb-ta, 0._r8 ) - - end do - - ! sum is length of timestep (in days) which has light - ! "sum"/(t1-t2) is fraction of timestep which has light - ! "tlight is fraction of day which has light - ! if fraction of dt is higher than avg fraction during day ==> increase oxidants - ! if fraction of dt is lower than avg fraction during day ==> decrease oxidants - - if (inv_oh .or. inv_ho2) then - fdiurn_oxid = max(1.0e-3_r8, sum/(t2-t1)/tlight) - end if - if (inv_no3) then - fdiurn_no3oxid = max(1.0e-3_r8, (1._r8 - (sum/(t2-t1))) / (1._r8 - tlight)) - ! (1._r8 - (sum/(t2-t1))) is the fraction of timestep WITHOUT light - ! (1._r8 - tlight) is the fraction of day WITHOUT light - end if - end if - - if (inv_oh) then - do k=1,pver - invariants(i,k,id_oh)=invariants(i,k,id_oh)*fdiurn_oxid - end do - end if - if (inv_ho2) then - do k=1,pver - invariants(i,k,id_ho2)=invariants(i,k,id_ho2)*fdiurn_oxid - end do - end if - if (inv_no3) then - do k=1,pver - invariants(i,k,id_no3)=invariants(i,k,id_no3)*fdiurn_no3oxid - end do - end if - - end do ! i= 1,ncol - end subroutine set_diurnal_invariants - - - !-------------------------------------------------------------------- - subroutine sunrisesetxx( xlong, ylat, iyear, imonth, iday, & - iflag, trise, tset, solardec ) - ! - ! input parameters - ! xlong - longitude in degrees (east longitudes are positive) - ! ylat - latitude in degrees (north latitudes are positive) - ! iyear - year - ! imonth - month - ! iday - day - ! output parameters - ! iflag - status flag - ! +1 - OK and there is a sunrise and sunset - ! 0 - OK but no sunrise or sunset - ! -1 = input parameters (date or position) are bad - ! trise - time of sunrise in UT hours - ! tset - time of sunset in UT hours - ! solardec - apparent solar declination in degrees - ! - ! written 17-aug-93 by r.c.easter - ! Rewritten into fortran 90 by Seland - - ! arguments - real(r8) ,intent(in) :: xlong - real(r8) ,intent(in) :: ylat - integer ,intent(in) :: iyear - integer ,intent(in) :: imonth - integer ,intent(in) :: iday - integer ,intent(out) :: iflag - real(r8) ,intent(out) :: trise - real(r8) ,intent(out) :: tset - real(r8) ,intent(out) :: solardec - - ! local - real(r8) :: sunrise, sunset, ap_dec - real(r8) :: xlongb - integer :: iriseset,i - - ! need xlong between -180 and +180 - xlongb = xlong - - if (xlongb .lt. -180.) then - xlongb = xlongb + 360._r8 - else if (xlongb .gt. 180._r8) then - xlongb = xlongb - 360._r8 - end if - - call srisesetxx( iyear, imonth, iday, ylat, xlongb, iriseset,sunrise, sunset, ap_dec) - - iflag = iriseset - if (iflag .eq. 0) then - iflag = 1 - if (abs(sunrise+100_r8) .le. 0.01_r8) iflag = 0 - end if - trise = sunrise - tset = sunset - solardec = ap_dec - - end subroutine sunrisesetxx - - !*************************************************************************** - subroutine srisesetxx(iyear, month, iday, rlat, rlong, iriseset,sunrise, sunset,ap_dec) - - integer ,intent(in) :: iyear - integer ,intent(in) :: month - integer ,intent(in) :: iday - real(r8) ,intent(in) :: rlat - real(r8) ,intent(in) :: rlong - integer ,intent(out) :: iriseset - real(r8) ,intent(out) :: sunrise - real(r8) ,intent(out) :: sunset - real(r8) ,intent(out) :: ap_dec - - !local - integer :: jday - integer :: iimonth(12), iimonthleap(12) - logical :: leapyr - - ! math definitions. - real(r8), parameter :: twopi = 2._r8*pi - real(r8), parameter :: deg_rad = 0.017453292519943295_r8 - real(r8), parameter :: rad_deg = 57.295779513082323_r8 - - ! local variables - real(r8) :: mean_anomaly, mean_longitude, mean_obliquity - real(r8) :: year - real(r8) :: delta_years,delta_days,days_j2000 - real(r8) :: cent_j2000,f_mean_anomaly,f_mean_longitude - real(r8) :: ecliptic_long,f_ap_ra, ap_ra,f_gmst0h - real(r8) :: gmst0h,rlat_r,tan_lat,tan_dec,tangterm - real(r8) :: timeterm - - data iimonth /0,31,59,90,120,151,181,212,243,273,304,334/ - data iimonthleap /0,31,60,91,121,152,182,213,244,274,305,335/ - leapyr = .false. - - ! "sunriseset.c" contains the integer function sunriseset() for calculating - ! the rising and setting times of the Sun as seen from a place on Earth on a - ! specific date. - ! - ! Version 1.0 - April 6, 1992. - ! (This code was adapted from "solarpos.c" Version 3.1.) - ! - ! sunriseset() employs the low precision formulas for the Sun's coordinates - ! given in the "Astronomical Almanac" of 1990 to compute the Sun's apparent - ! right ascension, apparent declination, and Greenwich mean sidereal time at - ! 0 hours Universal Time, and then the rising and setting times of the Sun. - ! The "Astronomical Almanac" (A. A.) states a precision of 0.01 degree for the - ! apparent coordinates between the years 1950 and 2050. - ! - ! The following assumptions and simplifications are made: - ! -> diurnal parallax is ignored, resulting in 0 to 9 arc seconds error in - ! apparent position. - ! -> diurnal aberration is also ignored, resulting in 0 to 0.02 second error - ! in right ascension and 0 to 0.3 arc second error in declination. - ! -> geodetic site coordinates are used, without correction for polar motion - ! (maximum amplitude of 0.3 arc second) and local gravity anomalies. - ! -> the formulas ignore atmospheric refraction, semi-diameter, and changes - ! in right ascension and declination over the course of a day; the - ! accuracies of sunrise and sunset are about 2 and 7 minutes for latitude - ! and longitude of 0 degrees, but accuracy degrades significantly for high - ! latitudes. - ! - ! - ! The necessary input parameters are: - ! -> the UT date, specified in one of three ways: - ! 1) year, month, day.fraction - ! 2) year, daynumber.fraction - ! 3) days.fraction elapsed since January 0, 1900. - ! Note: in GChM application, only specification #1 is currently valid - ! -> site geodetic (geographic) latitude and longitude. - ! - ! Refer to the function declaration for the parameter type specifications and - ! formats. - ! - ! sunriseset() returns -1 if an input parameter is out of bounds, or 0 if - ! values were written to the locations specified by the output parameters. - ! Sunrise and sunset times are in UT hours; if there is no sunrise or sunset - ! the values are -1.0. - ! - ! Author: Nels Larson - ! Pacific Northwest Lab. - ! P.O. Box 999 - ! Richland, WA 99352 - ! U.S.A. - ! - !-------------------------------------------------------------------------- - ! modifications for gchm application by eg chapman - ! 1. translated from c language to fortran - ! 2. input date must be in year, month, day.fraction format; other input - ! code eliminated. - ! 3. added indicator iriseset. when equal to -1, indicates location - ! or date is out of range. - ! - !--------------------------------------------------------------------------- - - !------------------------------------------------------------------------- - ! explanation of terms taken from c code - ! int iyear, Four digit year (Gregorian calendar). - ! [1950 through 2049; 0 if using days_1900] - ! month; Month number. - ! [1 through 12; 0 if using daynumber for day] - ! - ! day, /* Calendar day.fraction, or daynumber.fraction. - ! * [If month is NOT 0: - ! - ! * 0 through 32; 31st @ 18:10:00 UT = 31.75694 - ! * If month IS 0: - ! * 0 through 367; 366 @ 18:10:00 UT = 366.75694] */ - ! days_1900, /* Days since 1900 January 0 @ 00:00:00 UT. - ! * [18262.0 (1950/01/00) through 54788.0 (2049/12/32); - ! - ! * 1990/01/01 @ 18:10:00 UT = 32873.75694; - ! * 0.0 o.k. if using {year, month, day} or - ! * {year, daynumber}] */ - ! rlat Observation site geographic latitude. - ! [degrees.fraction, North positive] - ! rlong Observation site geographic longitude. - ! [degrees.fraction, East positive] - ! *ap_ra, /* Apparent solar right ascension. - ! * [hours; 0.0 <= *ap_ra < 24.0] */ - ! *ap_dec, /* Apparent solar declination. - ! * [degrees; -90.0 <= *ap_dec <= 90.0] */ - ! - ! *sunrise, /* Time of sunrise. - ! [UT hours.fraction; -1.0 if no sunrise or sunset] */ - ! *sunset; /* Time of sunset. - ! [UT hours.fraction; -1.0 if no sunset or sunrise] */ - ! int daynum(); /* Computes a sequential daynumber during a year. */ - ! int daynumber, /* Sequential daynumber during a year. */ - ! delta_days, /* Whole days since 2000 January 0. */ - ! delta_years; /* Whole years since 2000. */ - ! double cent_J2000, /* Julian centuries since epoch J2000.0 at 0h UT. */ - ! days_J2000, /* Days since epoch J2000.0. */ - ! ecliptic_long, /* Solar ecliptic longitude. */ - ! - ! gmst0h, /* Greenwich mean sidereal time at 0 hours UT. */ - ! integral, /* Integral portion of double precision number. */ - ! mean_anomaly, /* Earth mean anomaly. */ - ! mean_longitude, /* Solar mean longitude. */ - ! mean_obliquity, /* Mean obliquity of the ecliptic. */ - ! tan_dec, /* Tangent of apparent declination. */ - ! tan_lat, /* Tangent of latitude. */ - ! - ! tangterm, /* Tangent term of Sun rise/set equation. */ - ! timeterm; /* Time term of Sun rise/set equation. */ - !---------------------------------------------------------------------- - iriseset = 0 - - ! check latitude, longitude, dates for proper range before calculating dates. - if (((rlat .lt. -90._r8) .or. (rlat .gt. 90._r8)) .or. & - ((rlong .lt. -180._r8) .or. (rlong .gt. 180._r8))) then - iriseset = -1 - return - end if - - ! Year assumed to be betweeen 1950 and 2049. As the model is outside these - ! boundary in many cases. year 2000 is assumed for this version of the - ! model - ! if (iyear .lt. 1950 .or. iyear .gt. 2049) then - ! iriseset = -1 - ! return - ! end if - ! if (((month .lt. 1) .or. (month .gt. 12)) .or. & - ! ((iday .lt. 0) .or. (iday .gt. 32))) then - ! iriseset = -1 - ! return - ! end if - ! determine julian day number - - ! there is no year 0 in the Gregorian calendar and the leap year cycle - ! changes for earlier years. - ! if (iyear .lt. 1) then - ! iriseset = -1 - ! return - ! end if - ! leap years are divisible by 4, except for centurial years not divisible by 400. - - ! year = real (iyear) - ! if ((amod(year,4.) .eq. 0.0) .and. (amod(year,100.) .ne. 0.0)) & - ! leapyr = 1 - ! if(amod(year,400.) .eq. 0.0) leapyr = 1 - - jday = iimonth(month) + iday - ! if ((leapyr .eq. 1) .and. (month .gt. 2)) jday = jday + 1 - - ! construct Julian centuries since J2000 at 0 hours UT of date, - ! days.fraction since J2000, and UT hours. - delta_years = iyear - 2000._r8 - - ! delta_days is days from 2000/01/00 (1900's are negative). - delta_days = delta_years * 365._r8 + delta_years / 4._r8 + jday - if (iyear .gt. 2000) delta_days = delta_days + 1._r8 - - ! J2000 is 2000/01/01.5 - days_j2000 = delta_days - 1.5_r8 - cent_j2000 = days_j2000 / 36525._r8 - - ! compute solar position parameters. - ! A. A. 1990, C24. - f_mean_anomaly = (357.528_r8 + 0.9856003_r8 * days_j2000) - f_mean_longitude = (280.460_r8 + 0.9856474_r8 * days_j2000) - - ! put mean_anomaly and mean_longitude in the range 0 -> 2 pi. - mean_anomaly = (f_mean_anomaly / 360._r8 - int(f_mean_anomaly/360._r8)) * twopi - mean_longitude = (f_mean_longitude /360. - int(f_mean_longitude/360._r8)) * twopi - mean_obliquity = (23.439_r8 - 4.0e-7_r8 * days_j2000) * deg_rad - ecliptic_long = ((1.915_r8 * sin(mean_anomaly)) + (0.020_r8 * sin(2.0 * mean_anomaly))) * deg_rad + mean_longitude - - ! tangent of ecliptic_long separated into sine and cosine parts for ap_ra. - f_ap_ra = atan2(cos(mean_obliquity) * sin(ecliptic_long), cos(ecliptic_long)) - - ! change range of ap_ra from -pi -> pi to 0 -> 2 pi. - if (f_ap_ra .lt. 0.0) f_ap_ra = f_ap_ra + twopi - - ! put ap_ra in the range 0 -> 24 hours. - ap_ra = (f_ap_ra / twopi - int(f_ap_ra /twopi)) * 24._r8 - ap_dec = asin(sin(mean_obliquity) * sin(ecliptic_long)) - - ! calculate local mean sidereal time. - ! A. A. 1990, B6-B7. - ! horner's method of polynomial exponent expansion used for gmst0h. - f_gmst0h = 24110.54841_r8 + cent_j2000 * (8640184.812866_r8 & - +cent_j2000 * (0.093104_r8 - cent_j2000 * 6.2e-6_r8)) - - ! convert gmst0h from seconds to hours and put in the range 0 -> 24. - ! 24 hours = 86400 seconds - gmst0h = (f_gmst0h / 86400._r8 - int(f_gmst0h / 86400._r8)) * 24._r8 - if (gmst0h .lt. 0._r8) gmst0h = gmst0h + 24._r8 - - ! convert latitude to radians. - rlat_r = rlat * deg_rad - - ! avoid tangent overflow at +-90 degrees. - ! 1.57079615 radians is equal to 89.99999 degrees. - if (abs(rlat_r) .lt. 1.57079615_r8) then - tan_lat = tan(rlat_r) - else - tan_lat = 6.0e6_r8 - end if - if (abs(ap_dec) .lt. 1.57079615_r8) then - tan_dec = tan(ap_dec) - else - tan_dec = 6.0e6_r8 - end if - - ! compute UTs of sunrise and sunset. - ! A. A. 1990, A12. - tangterm = tan_lat * tan_dec - if (abs(tangterm) .gt. 1.0_r8) then - sunrise = -100._r8 - sunset = -100._r8 - else - ! compute angle of tangterm and convert to hours. - tangterm = acos(-tangterm) / twopi * 24._r8 - timeterm = ap_ra - rlong / 15._r8 - gmst0h - sunrise = timeterm - tangterm - sunset = timeterm + tangterm - - ! put sunrise and sunset in the range 0 to 24 hours. - !ec inserted following statement since in some latitudes timeterm - !ec minus tangterm is less than -25 - if (sunrise .le. -24._r8) sunrise = sunrise + 48._r8 - if (sunrise .lt. 0._r8) sunrise = sunrise + 24._r8 - if (sunrise .ge. 24._r8) sunrise = sunrise - 24._r8 - if (sunset .lt. 0._r8) sunset = sunset + 24._r8 - if (sunset .ge. 24._r8) sunset = sunset - 24._r8 - - ! mean sidereal day is 0.99727 mean solar days. - sunrise = sunrise * 0.99727_r8 - sunset = sunset * 0.99727_r8 - end if - ! convert ap_dec to degrees. - ap_dec = ap_dec * rad_deg - return - end subroutine srisesetxx - -end module oslo_aero_diurnal_var diff --git a/src/chemistry/oslo_aero/oslo_aero_dust.F90 b/src/chemistry/oslo_aero/oslo_aero_dust.F90 deleted file mode 100644 index 4c3302e98b..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_dust.F90 +++ /dev/null @@ -1,251 +0,0 @@ -module oslo_aero_dust - - ! Calculate emission of all dusts. - ! Note that the mobilization is calculated in the land model and - ! the soil erodibility factor is applied here. - - use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl - use ppgrid, only: pcols, begchunk, endchunk - use phys_grid, only: get_ncols_p, get_rlat_all_p, get_rlon_all_p - use physics_types, only: physics_state - use camsrfexch, only: cam_in_t - use spmd_utils, only: masterproc - use constituents, only: cnst_name - use interpolate_data, only: lininterp_init, lininterp, lininterp_finish, interp_type - use mo_constants, only: pi, d2r - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - use cam_pio_utils, only: cam_pio_openfile - use ioFileMod, only: getfil - use pio, only: file_desc_t,pio_inq_dimid,pio_inq_dimlen,pio_get_var,pio_inq_varid, PIO_NOWRITE - ! - use oslo_aero_share, only: l_dst_a2, l_dst_a3 - - implicit none - private - - ! public routines - public :: oslo_aero_dust_readnl - public :: oslo_aero_dust_init - public :: oslo_aero_dust_emis - - ! private routines (previously in soil_erod_mod in CAM) - private :: soil_erod_init - - character(len=6), public :: dust_names(10) - - integer , parameter :: numberOfDustModes = 2 !define in oslo_aero_share? - real(r8), parameter :: emis_fraction_in_mode(numberOfDustModes) = (/0.13_r8, 0.87_r8 /) - integer :: tracerMap(numberOfDustModes) = (/-99, -99/) !index of dust tracers in the modes - - integer , parameter, public :: dust_nbin = numberOfDustModes - - !Related to soil erodibility - real(r8) :: dust_emis_fact = -1.e36_r8 ! tuning parameter for dust emissions - character(len=cl) :: soil_erod_file = 'soil_erod_file' ! full pathname for soil erodibility dataset - - logical, parameter, public :: dust_active = .TRUE. - - real(r8), allocatable :: soil_erodibility(:,:) ! soil erodibility factor - real(r8) :: soil_erod_fact ! tuning parameter for dust emissions - -!=============================================================================== -contains -!=============================================================================== - - subroutine oslo_aero_dust_readnl(nlfile) - - use namelist_utils, only: find_group_name - use mpishorthand - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'dust_readnl' - - namelist /dust_nl/ dust_emis_fact, soil_erod_file - !----------------------------------------------------------------------------- - - ! Read namelist - if (masterproc) then - open( newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'dust_nl', status=ierr) - if (ierr == 0) then - read(unitn, dust_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - end if -#ifdef SPMD - ! Broadcast namelist variables - call mpibcast(dust_emis_fact, 1, mpir8, 0, mpicom) - call mpibcast(soil_erod_file, len(soil_erod_file), mpichar, 0, mpicom) -#endif - end subroutine oslo_aero_dust_readnl - - !=============================================================================== - subroutine oslo_aero_dust_init() - - ! local variables - integer :: i - - call soil_erod_init( dust_emis_fact, soil_erod_file ) - - ! Set module variables - tracerMap(1) = l_dst_a2 - tracerMap(2) = l_dst_a3 - - dust_names(:)=" " - do i=1,numberOfDustModes - dust_names(i) = cnst_name(tracerMap(i)) - end do - - end subroutine oslo_aero_dust_init - - !=============================================================================== - subroutine oslo_aero_dust_emis(state, cam_in) - - !----------------------------------------------------------------------- - ! Purpose: Interface to emission of all dusts. - ! Notice that the mobilization is calculated in the land model and - ! the soil erodibility factor is applied here. - !----------------------------------------------------------------------- - - ! Arguments: - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), target, intent(inout) :: cam_in ! import state - - ! Local variables - integer :: lchnk - integer :: ncol - integer :: i,n - real(r8) :: soil_erod_tmp(pcols) - real(r8) :: totalEmissionFlux(pcols) - real(r8), pointer :: cflx(:,:) - - lchnk = state%lchnk - ncol = state%ncol - - ! Filter away unreasonable values for soil erodibility - ! (using low values e.g. gives emissions in greenland..) - where(soil_erodibility(:,lchnk) .lt. 0.1_r8) - soil_erod_tmp(:)=0.0_r8 - elsewhere - soil_erod_tmp(:)=soil_erodibility(:,lchnk) - end where - - totalEmissionFlux(:) = 0.0_r8 - do i=1,ncol - totalEmissionFlux(i) = totalEmissionFlux(i) + sum(cam_in%dstflx(i,:)) - end do - - ! Note that following CESM use of "dust_emis_fact", the emissions are - ! scaled by the INVERSE of the factor!! - ! There is another random scale factor of 1.15 there. Adapting the exact - ! same formulation as MAM now and tune later - ! As of NE-380: Oslo dust emissions are 2/3 of CAM emissions - ! gives better AOD close to dust sources - - cflx => cam_in%cflx - do n = 1,numberOfDustModes - cflx(:ncol, tracerMap(n)) = -1.0_r8*emis_fraction_in_mode(n) & - *totalEmissionFlux(:ncol)*soil_erod_tmp(:ncol)/(dust_emis_fact)*1.15_r8 - end do - - end subroutine oslo_aero_dust_emis - - !============================================================================= - subroutine soil_erod_init( dust_emis_fact, soil_erod_file ) - - ! arguments - real(r8), intent(in) :: dust_emis_fact - character(len=*), intent(in) :: soil_erod_file - - ! localvaraibles - real(r8), allocatable :: soil_erodibility_in(:,:) - real(r8), allocatable :: dst_lons(:) - real(r8), allocatable :: dst_lats(:) - character(len=cl) :: infile - integer :: did, vid, nlat, nlon - type(file_desc_t) :: ncid - type(interp_type) :: lon_wgts, lat_wgts - real(r8) :: to_lats(pcols), to_lons(pcols) - integer :: c, ncols, ierr - real(r8), parameter :: zero=0._r8 - real(r8), parameter :: twopi=2._r8*pi - - soil_erod_fact = dust_emis_fact - - ! Summary to log file - if (masterproc) then - write(iulog,*) 'soil_erod_mod: soil erodibility dataset: ', trim(soil_erod_file) - write(iulog,*) 'soil_erod_mod: soil_erod_fact = ', soil_erod_fact - end if - - ! read in soil erodibility factors, similar to Zender's boundary conditions - - ! Get file name. - call getfil(soil_erod_file, infile, 0) - call cam_pio_openfile (ncid, trim(infile), PIO_NOWRITE) - - ! Get input data resolution. - ierr = pio_inq_dimid( ncid, 'lon', did ) - ierr = pio_inq_dimlen( ncid, did, nlon ) - - ierr = pio_inq_dimid( ncid, 'lat', did ) - ierr = pio_inq_dimlen( ncid, did, nlat ) - - allocate(dst_lons(nlon)) - allocate(dst_lats(nlat)) - allocate(soil_erodibility_in(nlon,nlat)) - - ierr = pio_inq_varid( ncid, 'lon', vid ) - ierr = pio_get_var( ncid, vid, dst_lons ) - - ierr = pio_inq_varid( ncid, 'lat', vid ) - ierr = pio_get_var( ncid, vid, dst_lats ) - - ierr = pio_inq_varid( ncid, 'mbl_bsn_fct_geo', vid ) - ierr = pio_get_var( ncid, vid, soil_erodibility_in ) - - ! convert to radians and setup regridding - dst_lats(:) = d2r * dst_lats(:) - dst_lons(:) = d2r * dst_lons(:) - - allocate( soil_erodibility(pcols,begchunk:endchunk), stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'soil_erod_init: failed to allocate soil_erodibility_in, ierr = ',ierr - call endrun('soil_erod_init: failed to allocate soil_erodibility_in') - end if - - soil_erodibility(:,:)=0._r8 - - ! regrid - do c=begchunk,endchunk - ncols = get_ncols_p(c) - call get_rlat_all_p(c, pcols, to_lats) - call get_rlon_all_p(c, pcols, to_lons) - - call lininterp_init(dst_lons, nlon, to_lons, ncols, 2, lon_wgts, zero, twopi) - call lininterp_init(dst_lats, nlat, to_lats, ncols, 1, lat_wgts) - - call lininterp(soil_erodibility_in(:,:), nlon, nlat, soil_erodibility(:,c), ncols, lon_wgts, lat_wgts) - - call lininterp_finish(lat_wgts) - call lininterp_finish(lon_wgts) - end do - deallocate( soil_erodibility_in, stat=ierr ) - if( ierr /= 0 ) then - write(iulog,*) 'soil_erod_init: failed to deallocate soil_erodibility_in, ierr = ',ierr - call endrun('soil_erod_init: failed to deallocate soil_erodibility_in') - end if - - deallocate( dst_lats ) - deallocate( dst_lons ) - - end subroutine soil_erod_init - -end module oslo_aero_dust diff --git a/src/chemistry/oslo_aero/oslo_aero_dust_sediment.F90 b/src/chemistry/oslo_aero/oslo_aero_dust_sediment.F90 deleted file mode 100644 index a2e305109c..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_dust_sediment.F90 +++ /dev/null @@ -1,424 +0,0 @@ -module oslo_aero_dust_sediment - - !--------------------------------------------------------------------------------- - ! Routines to compute tendencies from sedimentation of dust - ! Author: Phil Rasch - !--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8=>shr_kind_r8 - use ppgrid, only: pcols, pver, pverp - use physconst, only: gravit, rair - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - - implicit none - private - - ! public routines - public :: oslo_aero_dust_sediment_vel - public :: oslo_aero_dust_sediment_tend - - ! private routines - private :: getflx - private :: cfint2 - private :: cfdotmc_pro - - real (r8), parameter :: vland = 2.8_r8 ! dust fall velocity over land (cm/s) - real (r8), parameter :: vocean = 1.5_r8 ! dust fall velocity over ocean (cm/s) - real (r8), parameter :: mxsedfac = 0.99_r8 ! maximum sedimentation flux factor - -!=============================================================================== -contains -!=============================================================================== - - subroutine oslo_aero_dust_sediment_vel(ncol, icefrac, landfrac, ocnfrac, pmid, pdel, t, dustmr, pvdust) - - ! Compute gravitational sedimentation velocities for dust - ! note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) - - ! Arguments - integer, intent(in) :: ncol ! number of colums to process - real(r8), intent(in) :: icefrac (pcols) ! sea ice fraction (fraction) - real(r8), intent(in) :: landfrac(pcols) ! land fraction (fraction) - real(r8), intent(in) :: ocnfrac (pcols) ! ocean fraction (fraction) - real(r8), intent(in) :: pmid(pcols,pver) ! pressure of midpoint levels (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! pressure diff across layer (Pa) - real(r8), intent(in) :: t(pcols,pver) ! temperature (K) - real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) - real(r8), intent(out) :: pvdust (pcols,pverp) ! vertical velocity of dust (Pa/s) - - ! Local variables - real (r8) :: rho(pcols,pver) ! air density in kg/m3 - real (r8) :: vfall(pcols) ! settling velocity of dust particles (m/s) - integer :: i,k - real (r8) :: lbound, ac, bc, cc - - ! dust fall velocity - do k = 1,pver - do i = 1,ncol - ! merge the dust fall velocities for land and ocean (cm/s) SHOULD ALSO ACCOUNT FOR ICEFRAC - vfall(i) = vland*landfrac(i) + vocean*(1._r8-landfrac(i)) - - ! fall velocity (assume positive downward) - pvdust(i,k+1) = vfall(i) - end do - end do - end subroutine oslo_aero_dust_sediment_vel - - !=============================================================================== - subroutine oslo_aero_dust_sediment_tend ( ncol, dtime, pint, pmid, pdel, t, & - dustmr, pvdust, dusttend, sfdust, dusttend_to_ll_out ) - - !---------------------------------------------------------------------- - ! Apply Particle Gravitational Sedimentation - ! -> note that pvel is at the interfaces (loss from cell is based on pvel(k+1)) - !---------------------------------------------------------------------- - - ! Arguments - integer, intent(in) :: ncol ! number of colums to process - real(r8), intent(in) :: dtime ! time step - real(r8), intent(in) :: pint(pcols,pverp) ! interfaces pressure (Pa) - real(r8), intent(in) :: pmid(pcols,pver) ! midpoint pressures (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! pressure diff across layer (Pa) - real(r8), intent(in) :: t(pcols,pver) ! temperature (K) - real(r8), intent(in) :: dustmr(pcols,pver) ! dust (kg/kg) - real(r8), intent(in) :: pvdust (pcols,pverp) ! vertical velocity of dust drops (Pa/s) - real(r8), intent(out) :: dusttend(pcols,pver) ! dust tend - real(r8), intent(out) :: sfdust(pcols) ! surface flux of dust (rain, kg/m/s) - real(r8),intent(out),optional :: dusttend_to_ll_out(pcols) ! fluxes at the interfaces, dust (positive = down - - ! Local variables - integer :: i,k - real(r8) :: fxdust(pcols,pverp) ! fluxes at the interfaces, dust (positive = down) - !---------------------------------------------------------------------- - - ! initialize variables - fxdust (:ncol,:) = 0._r8 ! flux at interfaces (dust) - dusttend(:ncol,:) = 0._r8 ! tend (dust) - sfdust(:ncol) = 0._r8 ! sedimentation flux out bot of column (dust) - - ! fluxes at interior points - call getflx(ncol, pint, dustmr, pvdust, dtime, fxdust) - - ! calculate fluxes at boundaries - do i = 1,ncol - fxdust(i,1) = 0 - ! surface flux by upstream scheme - fxdust(i,pverp) = dustmr(i,pver) * pvdust(i,pverp) * dtime - end do - - ! filter out any negative fluxes from the getflx routine - do k = 2,pver - fxdust(:ncol,k) = max(0._r8, fxdust(:ncol,k)) - end do - - ! Limit the flux out of the bottom of each cell to the water content in each phase. - ! Apply mxsedfac to prevent generating very small negative cloud water/ice - ! NOTE, REMOVED CLOUD FACTOR FROM AVAILABLE WATER. ALL CLOUD WATER IS IN CLOUDS. - ! ***Should we include the flux in the top, to allow for thin surface layers? - ! ***Requires simple treatment of cloud overlap, already included below. - do k = 1,pver - do i = 1,ncol - fxdust(i,k+1) = min( fxdust(i,k+1), mxsedfac * dustmr(i,k) * pdel(i,k) ) - end do - end do - - ! Now calculate the tendencies - do k = 1,pver - do i = 1,ncol - ! net flux into cloud changes cloud dust/ice (all flux is out of cloud) - dusttend(i,k) = (fxdust(i,k) - fxdust(i,k+1)) / (dtime * pdel(i,k)) - end do - end do - - ! convert flux out the bottom to mass units Pa -> kg/m2/s - sfdust(:ncol) = fxdust(:ncol,pverp) / (dtime*gravit) - - ! fluxes at the interface - if(present(dusttend_to_ll_out))then - dusttend_to_ll_out(1:ncol) = fxdust(:ncol,pver)/(dtime*pdel(:ncol,pver)) - end if - - end subroutine oslo_aero_dust_sediment_tend - - !=============================================================================== - subroutine getflx(ncol, xw, phi, vel, deltat, flux) - - !.....xw1.......xw2.......xw3.......xw4.......xw5.......xw6 - !....psiw1.....psiw2.....psiw3.....psiw4.....psiw5.....psiw6 - !....velw1.....velw2.....velw3.....velw4.....velw5.....velw6 - !.........phi1......phi2.......phi3.....phi4.......phi5....... - - ! arguments - integer , intent(in) :: ncol ! number of colums to process - real(r8), intent(out) :: flux(pcols,pverp) - real(r8), intent(in) :: xw(pcols,pverp) - real(r8), intent(in) :: vel(pcols,pverp) - real(r8), intent(in) :: deltat - - ! local variables - integer :: i - integer :: k - real (r8) :: psi(pcols,pverp) - real (r8) :: phi(pcols,pverp-1) - real (r8) :: fdot(pcols,pverp) - real (r8) :: xx(pcols) - real (r8) :: fxdot(pcols) - real (r8) :: fxdd(pcols) - real (r8) :: psistar(pcols) - real (r8) :: xxk(pcols,pver) - - do i = 1,ncol - ! integral of phi - psi(i,1) = 0._r8 - ! fluxes at boundaries - flux(i,1) = 0 - flux(i,pverp) = 0._r8 - end do - - ! integral function - do k = 2,pverp - do i = 1,ncol - psi(i,k) = phi(i,k-1)*(xw(i,k)-xw(i,k-1)) + psi(i,k-1) - end do - end do - - ! calculate the derivatives for the interpolating polynomial - call cfdotmc_pro (ncol, xw, psi, fdot) - - ! calculate fluxes at interior pts - do k = 2,pver - do i = 1,ncol - xxk(i,k) = xw(i,k)-vel(i,k)*deltat - end do - end do - do k = 2,pver - call cfint2(ncol, xw, psi, fdot, xxk(1,k), fxdot, fxdd, psistar) - do i = 1,ncol - flux(i,k) = (psi(i,k)-psistar(i)) - end do - end do - - end subroutine getflx - - !=============================================================================== - subroutine cfint2 (ncol, x, f, fdot, xin, fxdot, fxdd, psistar) - - ! arguments - integer , intent(in) :: ncol ! number of colums to process - real (r8) , intent(in) :: x(pcols, pverp) - real (r8) , intent(in) :: f(pcols, pverp) - real (r8) , intent(out) :: fdot(pcols, pverp) - real (r8) , intent(in) :: xin(pcols) - real (r8) , intent(out) :: fxdot(pcols) - real (r8) , intent(out) :: fxdd(pcols) - real (r8) , intent(out) :: psistar(pcols) - - ! local variables - integer :: i - integer :: k - integer :: intz(pcols) - real (r8) :: dx - real (r8) :: s - real (r8) :: c2 - real (r8) :: c3 - real (r8) :: xx - real (r8) :: xinf - real (r8) :: psi1, psi2, psi3, psim - real (r8) :: cfint - real (r8) :: cfnew - real (r8) :: xins(pcols) - real (r8) :: a, b, c ! the minmod function - real (r8) :: minmod ! the minmod function - real (r8) :: medan ! the minmod function - - minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) - medan(a,b,c) = a + minmod(b-a,c-a) - - do i = 1,ncol - xins(i) = medan(x(i,1), xin(i), x(i,pverp)) - intz(i) = 0 - end do - - ! first find the interval - do k = 1,pverp-1 - do i = 1,ncol - if ((xins(i)-x(i,k))*(x(i,k+1)-xins(i)).ge.0._r8) then - intz(i) = k - endif - end do - end do - - do i = 1,ncol - if (intz(i).eq.0) then - write(iulog,*) ' interval was not found for col i ', i - call endrun('DUST_SEDIMENT_MOD:cfint2 -- interval was not found ') - endif - end do - - ! now interpolate - do i = 1,ncol - k = intz(i) - dx = (x(i,k+1)-x(i,k)) - s = (f(i,k+1)-f(i,k))/dx - c2 = (3*s-2*fdot(i,k)-fdot(i,k+1))/dx - c3 = (fdot(i,k)+fdot(i,k+1)-2*s)/dx**2 - xx = (xins(i)-x(i,k)) - fxdot(i) = (3*c3*xx + 2*c2)*xx + fdot(i,k) - fxdd(i) = 6*c3*xx + 2*c2 - cfint = ((c3*xx + c2)*xx + fdot(i,k))*xx + f(i,k) - - ! limit the interpolant - psi1 = f(i,k)+(f(i,k+1)-f(i,k))*xx/dx - if (k.eq.1) then - psi2 = f(i,1) - else - psi2 = f(i,k) + (f(i,k)-f(i,k-1))*xx/(x(i,k)-x(i,k-1)) - endif - if (k+1.eq.pverp) then - psi3 = f(i,pverp) - else - psi3 = f(i,k+1) - (f(i,k+2)-f(i,k+1))*(dx-xx)/(x(i,k+2)-x(i,k+1)) - endif - psim = medan(psi1, psi2, psi3) - cfnew = medan(cfint, psi1, psim) - if (abs(cfnew-cfint)/(abs(cfnew)+abs(cfint)+1.e-36_r8) .gt..03_r8) then - endif - psistar(i) = cfnew - end do - - end subroutine cfint2 - - !=============================================================================== - subroutine cfdotmc_pro (ncol, x, f, fdot) - - ! prototype version; eventually replace with final SPITFIRE scheme - ! calculate the derivative for the interpolating polynomial multi column version - ! assumed variable distribution - - ! x1.......x2.......x3.......x4.......x5.......x6 1,pverp points - ! f1.......f2.......f3.......f4.......f5.......f6 1,pverp points - ! ...sh1.......sh2......sh3......sh4......sh5.... 1,pver points - ! .........d2.......d3.......d4.......d5......... 2,pver points - ! .........s2.......s3.......s4.......s5......... 2,pver points - ! .............dh2......dh3......dh4............. 2,pver-1 points - ! .............eh2......eh3......eh4............. 2,pver-1 points - ! ..................e3.......e4.................. 3,pver-1 points - ! .................ppl3......ppl4................ 3,pver-1 points - ! .................ppr3......ppr4................ 3,pver-1 points - ! .................t3........t4.................. 3,pver-1 points - ! ................fdot3.....fdot4................ 3,pver-1 points - - - ! arguments - integer , intent(in) :: ncol ! number of colums to process - real (r8) , intent(in) :: x(pcols, pverp) - real (r8) , intent(in) :: f(pcols, pverp) - real (r8) , intent(out) :: fdot(pcols, pverp) ! derivative at nodes - - ! local variables - integer :: i,k - real(r8) :: a,b,c ! work vars - real(r8) :: s(pcols,pverp) ! first divided differences at nodes - real(r8) :: sh(pcols,pverp) ! first divided differences between nodes - real(r8) :: d(pcols,pverp) ! second divided differences at nodes - real(r8) :: dh(pcols,pverp) ! second divided differences between nodes - real(r8) :: e(pcols,pverp) ! third divided differences at nodes - real(r8) :: eh(pcols,pverp) ! third divided differences between nodes - real(r8) :: pp ! p prime - real(r8) :: ppl(pcols,pverp) ! p prime on left - real(r8) :: ppr(pcols,pverp) ! p prime on right - real(r8) :: qpl - real(r8) :: qpr - real(r8) :: ttt - real(r8) :: t - real(r8) :: tmin - real(r8) :: tmax - real(r8) :: delxh(pcols,pverp) - real(r8) :: minmod ! the minmod function - real(r8) :: medan ! the minmod function - - minmod(a,b) = 0.5_r8*(sign(1._r8,a) + sign(1._r8,b))*min(abs(a),abs(b)) - medan(a,b,c) = a + minmod(b-a,c-a) - - do k = 1,pver - ! first divided differences between nodes - do i = 1, ncol - delxh(i,k) = (x(i,k+1)-x(i,k)) - sh(i,k) = (f(i,k+1)-f(i,k))/delxh(i,k) - end do - - ! first and second divided differences at nodes - if (k.ge.2) then - do i = 1,ncol - d(i,k) = (sh(i,k)-sh(i,k-1))/(x(i,k+1)-x(i,k-1)) - s(i,k) = minmod(sh(i,k),sh(i,k-1)) - end do - endif - end do - - ! second and third divided diffs between nodes - do k = 2,pver-1 - do i = 1, ncol - eh(i,k) = (d(i,k+1)-d(i,k))/(x(i,k+2)-x(i,k-1)) - dh(i,k) = minmod(d(i,k),d(i,k+1)) - end do - end do - - ! treat the boundaries - do i = 1,ncol - e(i,2) = eh(i,2) - e(i,pver) = eh(i,pver-1) - ! outside level - fdot(i,1) = sh(i,1) - d(i,2)*delxh(i,1) - eh(i,2)*delxh(i,1)*(x(i,1)-x(i,3)) - fdot(i,1) = minmod(fdot(i,1),3*sh(i,1)) - fdot(i,pverp) = sh(i,pver) + d(i,pver)*delxh(i,pver) + eh(i,pver-1)*delxh(i,pver)*(x(i,pverp)-x(i,pver-1)) - fdot(i,pverp) = minmod(fdot(i,pverp),3*sh(i,pver)) - - ! one in from boundary - fdot(i,2) = sh(i,1) + d(i,2)*delxh(i,1) - eh(i,2)*delxh(i,1)*delxh(i,2) - fdot(i,2) = minmod(fdot(i,2),3*s(i,2)) - fdot(i,pver) = sh(i,pver) - d(i,pver)*delxh(i,pver) - eh(i,pver-1)*delxh(i,pver)*delxh(i,pver-1) - fdot(i,pver) = minmod(fdot(i,pver),3*s(i,pver)) - end do - - do k = 3,pver-1 - do i = 1,ncol - e(i,k) = minmod(eh(i,k),eh(i,k-1)) - end do - end do - - do k = 3,pver-1 - do i = 1,ncol - ! p prime at k-0.5 - ppl(i,k)=sh(i,k-1) + dh(i,k-1)*delxh(i,k-1) - - ! p prime at k+0.5 - ppr(i,k)=sh(i,k) - dh(i,k) *delxh(i,k) - t = minmod(ppl(i,k),ppr(i,k)) - - ! derivate from parabola thru f(i,k-1), f(i,k), and f(i,k+1) - pp = sh(i,k-1) + d(i,k)*delxh(i,k-1) - - ! quartic estimate of fdot - fdot(i,k) = pp - delxh(i,k-1)*delxh(i,k)*(eh(i,k-1)*(x(i,k+2)-x(i,k)) & - + eh(i,k )*(x(i,k )-x(i,k-2)))/(x(i,k+2)-x(i,k-2)) - - ! now limit it - qpl = sh(i,k-1) + delxh(i,k-1)*minmod(d(i,k-1)+ e(i,k-1)*(x(i,k)-x(i,k-2)), & - d(i,k) - e(i,k)*delxh(i,k)) - qpr = sh(i,k) + delxh(i,k )*minmod(d(i,k) + e(i,k)*delxh(i,k-1), & - d(i,k+1)+e(i,k+1)*(x(i,k)-x(i,k+2))) - - fdot(i,k) = medan(fdot(i,k), qpl, qpr) - - ttt = minmod(qpl, qpr) - tmin = min(0._r8,3*s(i,k),1.5_r8*t,ttt) - tmax = max(0._r8,3*s(i,k),1.5_r8*t,ttt) - fdot(i,k) = fdot(i,k) + minmod(tmin-fdot(i,k), tmax-fdot(i,k)) - end do - end do - - end subroutine cfdotmc_pro - -end module oslo_aero_dust_sediment diff --git a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 b/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 deleted file mode 100644 index f7ff34e929..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_hetfrz.F90 +++ /dev/null @@ -1,1467 +0,0 @@ -module oslo_aero_hetfrz - - !----------------------------------------------------------------------- - ! Calculate heterogeneous freezing rates from classical nucleation theory - ! - ! Author: - ! Corinna Hoose, UiO, May 2009 - ! Yong Wang and Xiaohong Liu, UWyo, 12/2012, - ! implement in CAM5 and constrain uncertain parameters using natural dust and - ! BC(soot) datasets. - ! Yong Wang and Xiaohong Liu, UWyo, 05/2013, implement the PDF-contact angle - ! approach: Y. Wang et al., Atmos. Chem. Phys., 2014. - ! Jack Chen, NCAR, 09/2015, modify calculation of dust activation fraction. - !--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8=>shr_kind_r8 - use shr_spfn_mod, only: erf => shr_spfn_erf - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, begchunk, endchunk - use physconst, only: rair, cpair, rh2o, rhoh2o, mwh2o, tmelt, pi - use constituents, only: cnst_get_ind, pcnst - use physics_types, only: physics_state - use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field - use physics_buffer, only: pbuf_add_field, dtype_r8 - use phys_control, only: phys_getopts, use_hetfrz_classnuc - use cam_history, only: addfld, add_default, outfld - use ref_pres, only: top_lev => trop_cloud_top_lev - use wv_saturation, only: svp_water, svp_ice - use cam_logfile, only: iulog - use error_messages, only: handle_errmsg, alloc_err - use cam_abortutils, only: endrun - ! - use oslo_aero_utils, only: CalculateNumberConcentration, calculateNumberMedianRadius - use oslo_aero_params, only: nmodes_oslo => nmodes - use oslo_aero_share, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_OMBC_INTMIX_COAT_AIT - use oslo_aero_share, only: getNumberOfTracersInMode, getTracerIndex - use oslo_aero_share, only: qqcw_get_field - use oslo_aero_share, only: l_dst_a2, l_dst_a3, l_bc_ai, l_bc_ac - use oslo_aero_share, only: lifeCycleNumberMedianRadius, lifeCycleSigma - - implicit none - private - - ! The following are called by microp_aero - public :: hetfrz_classnuc_oslo_readnl - public :: hetfrz_classnuc_oslo_register - public :: hetfrz_classnuc_oslo_init - public :: hetfrz_classnuc_oslo_calc - public :: hetfrz_classnuc_oslo_save_cbaero - - private :: get_aer_num - private :: hetfrz_classnuc_calc - private :: collkernel - private :: hetfrz_classnuc_init_pdftheta - - ! Namelist variables - logical :: hist_hetfrz_classnuc = .false. - - ! Vars set via init method. - real(r8) :: mincld ! minimum allowed cloud fraction - - ! constituent indices - integer :: cldliq_idx = -1 - integer :: cldice_idx = -1 - integer :: numliq_idx = -1 - integer :: numice_idx = -1 - - ! pbuf indices for fields provided by heterogeneous freezing - integer :: frzimm_idx - integer :: frzcnt_idx - integer :: frzdep_idx - - ! pbuf indices for fields needed by heterogeneous freezing - integer :: ast_idx = -1 - - ! Copy of cloud borne aerosols before modification by droplet nucleation - ! The basis is converted from mass to volume. - real(r8), allocatable :: aer_cb(:,:,:,:) - - ! PDF theta model - ! some variables for PDF theta model - ! immersion freezing - ! - ! With the original value of pdf_n_theta set to 101 the dust activation - ! fraction between -15 and 0 C could be overestimated. This problem was - ! eliminated by increasing pdf_n_theta to 301. To reduce the expense of - ! computing the dust activation fraction the integral is only evaluated - ! where dim_theta is non-zero. This was determined to be between - ! dim_theta index values of 53 through 113. These loop bounds are - ! hardcoded in the variables i1 and i2. - - integer, parameter :: pdf_n_theta = 301 - integer, parameter :: i1 = 53 - integer, parameter :: i2 = 113 - real(r8) :: dim_theta(pdf_n_theta) = 0.0_r8 - real(r8) :: pdf_imm_theta(pdf_n_theta) = 0.0_r8 - real(r8) :: pdf_d_theta - real(r8) :: dim_f_imm_dust_a1(pdf_n_theta) = 0.0_r8 - real(r8) :: dim_f_imm_dust_a3(pdf_n_theta) = 0.0_r8 - logical :: pdf_imm_in = .true. - -!=============================================================================== -contains -!=============================================================================== - - subroutine hetfrz_classnuc_oslo_readnl(nlfile) - - use namelist_utils, only: find_group_name - use mpishorthand - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'hetfrz_classnuc_cam_readnl' - - namelist /hetfrz_classnuc_nl/ hist_hetfrz_classnuc - !----------------------------------------------------------------------------- - - if (masterproc) then - open( newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'hetfrz_classnuc_nl', status=ierr) - if (ierr == 0) then - read(unitn, hetfrz_classnuc_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - end if -#ifdef SPMD - ! Broadcast namelist variables - call mpibcast(hist_hetfrz_classnuc, 1, mpilog, 0, mpicom) -#endif - - end subroutine hetfrz_classnuc_oslo_readnl - - !================================================================================================ - - subroutine hetfrz_classnuc_oslo_register() - - if (.not. use_hetfrz_classnuc) return - - ! pbuf fields provided by hetfrz_classnuc - call pbuf_add_field('FRZIMM', 'physpkg', dtype_r8, (/pcols,pver/), frzimm_idx) - call pbuf_add_field('FRZCNT', 'physpkg', dtype_r8, (/pcols,pver/), frzcnt_idx) - call pbuf_add_field('FRZDEP', 'physpkg', dtype_r8, (/pcols,pver/), frzdep_idx) - - end subroutine hetfrz_classnuc_oslo_register - - !================================================================================================ - - subroutine hetfrz_classnuc_oslo_init(mincld_in) - - real(r8), intent(in) :: mincld_in - - ! local variables - integer :: m, n, nspec - integer :: istat - real(r8) :: sigma_logr_aer - character(len=32) :: str32 - character(len=*), parameter :: routine = 'hetfrz_classnuc_cam_init' - !-------------------------------------------------------------------------------------------- - - ! This parameterization currently assumes that prognostic modal aerosols are on. Check... - - if (.not. use_hetfrz_classnuc) return - - mincld = mincld_in - - call cnst_get_ind('CLDLIQ', cldliq_idx) - call cnst_get_ind('CLDICE', cldice_idx) - call cnst_get_ind('NUMLIQ', numliq_idx) - call cnst_get_ind('NUMICE', numice_idx) - - ! pbuf fields used by hetfrz_classnuc - ast_idx = pbuf_get_index('AST') - - call addfld('bc_num', (/ 'lev' /), 'A', '#/cm3', 'total bc number') - call addfld('dst1_num', (/ 'lev' /), 'A', '#/cm3', 'total dst1 number') - call addfld('dst3_num', (/ 'lev' /), 'A', '#/cm3', 'total dst3 number') - call addfld('bcc_num', (/ 'lev' /), 'A', '#/cm3', 'coated bc number') - call addfld('dst1c_num', (/ 'lev' /), 'A', '#/cm3', 'coated dst1 number') - call addfld('dst3c_num', (/ 'lev' /), 'A', '#/cm3', 'coated dst3 number') - call addfld('bcuc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated bc number') - call addfld('dst1uc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated dst1 number') - call addfld('dst3uc_num', (/ 'lev' /), 'A', '#/cm3', 'uncoated dst3 number') - - call addfld('bc_a1_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial bc number') - call addfld('dst_a1_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial dst1 number') - call addfld('dst_a3_num', (/ 'lev' /), 'A', '#/cm3', 'interstitial dst3 number') - call addfld('bc_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne bc number') - call addfld('dst_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst1 number') - call addfld('dst_c3_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst3 number') - - call addfld('fn_bc_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne bc number derived from fn') - call addfld('fn_dst_c1_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst1 number derived from fn') - call addfld('fn_dst_c3_num', (/ 'lev' /), 'A', '#/cm3', 'cloud borne dst3 number derived from fn') - - call addfld('na500', (/ 'lev' /), 'A', '#/cm3', 'interstitial aerosol number with D>500 nm') - call addfld('totna500', (/ 'lev' /), 'A', '#/cm3', 'total aerosol number with D>500 nm') - - call addfld('FREQIMM', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of immersion freezing') - call addfld('FREQCNT', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of contact freezing') - call addfld('FREQDEP', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of deposition freezing') - call addfld('FREQMIX', (/ 'lev' /), 'A', 'fraction', 'Fractional occurance of mixed-phase clouds' ) - - call addfld('DSTFREZIMM', (/ 'lev' /), 'A', 'm-3s-1', 'dust immersion freezing rate') - call addfld('DSTFREZCNT', (/ 'lev' /), 'A', 'm-3s-1', 'dust contact freezing rate') - call addfld('DSTFREZDEP', (/ 'lev' /), 'A', 'm-3s-1', 'dust deposition freezing rate') - - call addfld('BCFREZIMM', (/ 'lev' /), 'A', 'm-3s-1', 'bc immersion freezing rate') - call addfld('BCFREZCNT', (/ 'lev' /), 'A', 'm-3s-1', 'bc contact freezing rate') - call addfld('BCFREZDEP', (/ 'lev' /), 'A', 'm-3s-1', 'bc deposition freezing rate') - - call addfld('NIMIX_IMM', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to het immersion freezing in Mixed Clouds') - call addfld('NIMIX_CNT', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to het contact freezing in Mixed Clouds') - call addfld('NIMIX_DEP', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to het deposition freezing in Mixed Clouds') - - call addfld('DSTNIDEP', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to dst dep freezing in Mixed Clouds') - call addfld('DSTNICNT', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to dst cnt freezing in Mixed Clouds') - call addfld('DSTNIIMM', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to dst imm freezing in Mixed Clouds') - - call addfld('BCNIDEP', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to bc dep freezing in Mixed Clouds') - call addfld('BCNICNT', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to bc cnt freezing in Mixed Clouds') - call addfld('BCNIIMM', (/ 'lev' /), 'A', '#/m3', & - 'Activated Ice Number Concentration due to bc imm freezing in Mixed Clouds') - - call addfld('NUMICE10s', (/ 'lev' /), 'A', '#/m3', & - 'Ice Number Concentration due to het freezing in Mixed Clouds during 10-s period') - call addfld('NUMIMM10sDST', (/ 'lev' /), 'A', '#/m3', & - 'Ice Number Concentration due to imm freezing by dst in Mixed Clouds during 10-s period') - call addfld('NUMIMM10sBC', (/ 'lev' /), 'A', '#/m3', & - 'Ice Number Concentration due to imm freezing by bc in Mixed Clouds during 10-s period') - - if (hist_hetfrz_classnuc) then - - call add_default('bc_num', 1, ' ') - call add_default('dst1_num', 1, ' ') - call add_default('dst3_num', 1, ' ') - call add_default('bcc_num', 1, ' ') - call add_default('dst1c_num', 1, ' ') - call add_default('dst3c_num', 1, ' ') - call add_default('bcuc_num', 1, ' ') - call add_default('dst1uc_num', 1, ' ') - call add_default('dst3uc_num', 1, ' ') - - call add_default('bc_a1_num', 1, ' ') - call add_default('dst_a1_num', 1, ' ') - call add_default('dst_a3_num', 1, ' ') - call add_default('bc_c1_num', 1, ' ') - call add_default('dst_c1_num', 1, ' ') - call add_default('dst_c3_num', 1, ' ') - - call add_default('fn_bc_c1_num', 1, ' ') - call add_default('fn_dst_c1_num', 1, ' ') - call add_default('fn_dst_c3_num', 1, ' ') - - call add_default('na500', 1, ' ') - call add_default('totna500', 1, ' ') - - call add_default('FREQIMM', 1, ' ') - call add_default('FREQCNT', 1, ' ') - call add_default('FREQDEP', 1, ' ') - call add_default('FREQMIX', 1, ' ') - - call add_default('DSTFREZIMM', 1, ' ') - call add_default('DSTFREZCNT', 1, ' ') - call add_default('DSTFREZDEP', 1, ' ') - - call add_default('BCFREZIMM', 1, ' ') - call add_default('BCFREZCNT', 1, ' ') - call add_default('BCFREZDEP', 1, ' ') - - call add_default('NIMIX_IMM', 1, ' ') - call add_default('NIMIX_CNT', 1, ' ') - call add_default('NIMIX_DEP', 1, ' ') - - call add_default('DSTNIDEP', 1, ' ') - call add_default('DSTNICNT', 1, ' ') - call add_default('DSTNIIMM', 1, ' ') - - call add_default('BCNIDEP', 1, ' ') - call add_default('BCNICNT', 1, ' ') - call add_default('BCNIIMM', 1, ' ') - - call add_default('NUMICE10s', 1, ' ') - call add_default('NUMIMM10sDST', 1, ' ') - call add_default('NUMIMM10sBC', 1, ' ') - - end if - - ! The following code sets indices of the mode specific species used - ! in the module. Having a list of the species needed allows us to - ! allocate temporary space for just those species rather than for all the - ! CAM species (pcnst) which may be considerably more than needed. - ! - ! The indices set below are for use with the CAM rad_constituents - ! interfaces. Using the rad_constituents interfaces isolates the physics - ! parameterization which requires constituent information from the chemistry - ! code which provides that information. - - ! Allocate space for copy of cloud borne aerosols before modification by droplet nucleation. - allocate(aer_cb(pcols,pver,pcnst,begchunk:endchunk), stat=istat) - call alloc_err(istat, routine, 'aer_cb', pcols*pver*pcnst*(endchunk-begchunk+1)) - - ! Initialize all the PDF theta variables: - ! With the original value of pdf_n_theta set to 101 the dust activation - ! fraction between -15 and 0 C could be overestimated. This problem was - ! eliminated by increasing pdf_n_theta to 301. To reduce the expense of - ! computing the dust activation fraction the integral is only evaluated - ! where dim_theta is non-zero. This was determined to be between - ! dim_theta index values of 53 through 113. These loop bounds are - ! hardcoded in the variables i1 and i2. - - if (pdf_imm_in) then - call hetfrz_classnuc_init_pdftheta() - end if - - end subroutine hetfrz_classnuc_oslo_init - - !================================================================================================ - - subroutine hetfrz_classnuc_oslo_calc( & - state, deltatin, factnum, pbuf, & - numberConcentration, volumeConcentration, & - f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & - hygroscopicity, lnsigma, cam, volumeCore, volumeCoat) - - ! arguments - type(physics_state), target, intent(in) :: state - real(r8), intent(in) :: deltatin ! time step (s) - real(r8), intent(in) :: factnum(:,:,:) ! activation fraction for aerosol number - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes_oslo) - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes_oslo) - real(r8), intent(in) :: f_acm(pcols,pver, nmodes_oslo) - real(r8), intent(in) :: f_bcm(pcols,pver, nmodes_oslo) - real(r8), intent(in) :: f_aqm(pcols, pver, nmodes_oslo) - real(r8), intent(in) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" - real(r8), intent(in) :: f_soam(pcols, pver, nmodes_oslo) - real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity - real(r8), intent(in) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma - real(r8), intent(in) :: cam(pcols,pver,nmodes_oslo) - real(r8), intent(in) :: volumeCore(pcols,pver,nmodes_oslo) - real(r8), intent(in) :: volumeCoat(pcols,pver,nmodes_oslo) - - ! local workspace - real(r8), pointer :: frzimm(:,:) ! output shared with the microphysics via the pbuf - real(r8), pointer :: frzcnt(:,:) ! output shared with the microphysics via the pbuf - real(r8), pointer :: frzdep(:,:) ! output shared with the microphysics via the pbuf - real(r8), pointer :: ast(:,:) - integer :: itim_old - integer :: i, k, n, m, kk - real(r8) :: rho(pcols,pver) ! air density (kg m-3) - real(r8) :: lcldm(pcols,pver) - real(r8) :: fn(3) - real(r8) :: awcam(pcols,pver,3) - real(r8) :: awfacm(pcols,pver,3) - real(r8) :: hetraer(pcols,pver,3) - real(r8) :: dstcoat(pcols,pver,3) - real(r8) :: total_interstitial_aer_num(pcols,pver,3) - real(r8) :: total_cloudborne_aer_num(pcols,pver,3) - real(r8) :: total_aer_num(pcols,pver,3) - real(r8) :: coated_aer_num(pcols,pver,3) - real(r8) :: uncoated_aer_num(pcols,pver,3) - real(r8) :: fn_cloudborne_aer_num(pcols,pver,3) - real(r8) :: con1, r3lx, supersatice - real(r8) :: qcic - real(r8) :: ncic - real(r8) :: frzbcimm(pcols,pver), frzduimm(pcols,pver) - real(r8) :: frzbccnt(pcols,pver), frzducnt(pcols,pver) - real(r8) :: frzbcdep(pcols,pver), frzdudep(pcols,pver) - real(r8) :: freqimm(pcols,pver), freqcnt(pcols,pver), freqdep(pcols,pver), freqmix(pcols,pver) - real(r8) :: nnuccc_bc(pcols,pver), nnucct_bc(pcols,pver), nnudep_bc(pcols,pver) - real(r8) :: nnuccc_dst(pcols,pver), nnucct_dst(pcols,pver), nnudep_dst(pcols,pver) - real(r8) :: niimm_bc(pcols,pver), nicnt_bc(pcols,pver), nidep_bc(pcols,pver) - real(r8) :: niimm_dst(pcols,pver), nicnt_dst(pcols,pver), nidep_dst(pcols,pver) - real(r8) :: numice10s(pcols,pver) - real(r8) :: numice10s_imm_dst(pcols,pver) - real(r8) :: numice10s_imm_bc(pcols,pver) - real(r8) :: CloudnumberConcentration(pcols,pver,0:nmodes_oslo) ! oslo aerosol specific - real(r8) :: numberMedianRadius(pcols,pver,nmodes_oslo) ! oslo aerosol specific - real(r8) :: na500(pcols,pver) - real(r8) :: tot_na500(pcols,pver) - character(128) :: errstring ! Error status - !------------------------------------------------------------------------------- - - associate( & - lchnk => state%lchnk, & - ncol => state%ncol, & - t => state%t, & - qc => state%q(:pcols,:pver,cldliq_idx), & - nc => state%q(:pcols,:pver,numliq_idx), & - pmid => state%pmid ) - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - rho(:,:) = 0._r8 - - do k = top_lev, pver - do i = 1, ncol - rho(i,k) = pmid(i,k)/(rair*t(i,k)) - end do - end do - - do k = top_lev, pver - do i = 1, ncol - lcldm(i,k) = max(ast(i,k), mincld) - end do - end do - - ! Convert interstitial and cloud borne aerosols from a mass to a volume basis before - ! being used in get_aer_num - do i = 1, pcnst - aer_cb(:ncol,:,i,lchnk) = aer_cb(:ncol,:,i,lchnk) * rho(:ncol,:) - end do - - ! Init top levels of outputs of get_aer_num - total_aer_num = 0._r8 - coated_aer_num = 0._r8 - uncoated_aer_num = 0._r8 - total_interstitial_aer_num = 0._r8 - total_cloudborne_aer_num = 0._r8 - hetraer = 0._r8 - awcam = 0._r8 - awfacm = 0._r8 - dstcoat = 0._r8 - na500 = 0._r8 - tot_na500 = 0._r8 - - !Get estimate of number of aerosols inside clouds - call calculateNumberConcentration(ncol, aer_cb, rho, CloudnumberConcentration) - call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) - !End estimate of number inside clouds - - ! output aerosols as reference information for heterogeneous freezing - do i = 1, ncol - do k = top_lev, pver - call get_aer_num(numberConcentration(i,k,:), CloudnumberConcentration(i,k,:), rho(i,k), & - f_acm(i,k,:), f_so4_condm(i,k,:), cam(i,k,:), volumeCore(i,k,:), volumeCoat(i,k,:), & - total_aer_num(i,k,:), coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), & - total_interstitial_aer_num(i,k,:), total_cloudborne_aer_num(i,k,:), & - hetraer(i,k,:), awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), & - na500(i,k), tot_na500(i,k)) - - fn_cloudborne_aer_num(i,k,1) = total_aer_num(i,k,1)*factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc - fn_cloudborne_aer_num(i,k,2) = total_aer_num(i,k,2)*factnum(i,k,MODE_IDX_DST_A2) - fn_cloudborne_aer_num(i,k,3) = total_aer_num(i,k,3)*factnum(i,k,MODE_IDX_DST_A3) - end do - end do - - call outfld('bc_num', total_aer_num(:,:,1), pcols, lchnk) - call outfld('dst1_num', total_aer_num(:,:,2), pcols, lchnk) - call outfld('dst3_num', total_aer_num(:,:,3), pcols, lchnk) - - call outfld('bcc_num', coated_aer_num(:,:,1), pcols, lchnk) - call outfld('dst1c_num', coated_aer_num(:,:,2), pcols, lchnk) - call outfld('dst3c_num', coated_aer_num(:,:,3), pcols, lchnk) - - call outfld('bcuc_num', uncoated_aer_num(:,:,1), pcols, lchnk) - call outfld('dst1uc_num', uncoated_aer_num(:,:,2), pcols, lchnk) - call outfld('dst3uc_num', uncoated_aer_num(:,:,3), pcols, lchnk) - - call outfld('bc_a1_num', total_interstitial_aer_num(:,:,1), pcols, lchnk) - call outfld('dst_a1_num', total_interstitial_aer_num(:,:,2), pcols, lchnk) - call outfld('dst_a3_num', total_interstitial_aer_num(:,:,3), pcols, lchnk) - - call outfld('bc_c1_num', total_cloudborne_aer_num(:,:,1), pcols, lchnk) - call outfld('dst_c1_num', total_cloudborne_aer_num(:,:,2), pcols, lchnk) - call outfld('dst_c3_num', total_cloudborne_aer_num(:,:,3), pcols, lchnk) - - call outfld('fn_bc_c1_num', fn_cloudborne_aer_num(:,:,1), pcols, lchnk) - call outfld('fn_dst_c1_num', fn_cloudborne_aer_num(:,:,2), pcols, lchnk) - call outfld('fn_dst_c3_num', fn_cloudborne_aer_num(:,:,3), pcols, lchnk) - - call outfld('na500', na500, pcols, lchnk) - call outfld('totna500', tot_na500, pcols, lchnk) - - ! frzimm, frzcnt, frzdep are the outputs of this parameterization used by the microphysics - call pbuf_get_field(pbuf, frzimm_idx, frzimm) - call pbuf_get_field(pbuf, frzcnt_idx, frzcnt) - call pbuf_get_field(pbuf, frzdep_idx, frzdep) - - frzimm(:ncol,:) = 0._r8 - frzcnt(:ncol,:) = 0._r8 - frzdep(:ncol,:) = 0._r8 - - frzbcimm(:ncol,:) = 0._r8 - frzduimm(:ncol,:) = 0._r8 - frzbccnt(:ncol,:) = 0._r8 - frzducnt(:ncol,:) = 0._r8 - frzbcdep(:ncol,:) = 0._r8 - frzdudep(:ncol,:) = 0._r8 - - freqimm(:ncol,:) = 0._r8 - freqcnt(:ncol,:) = 0._r8 - freqdep(:ncol,:) = 0._r8 - freqmix(:ncol,:) = 0._r8 - - numice10s(:ncol,:) = 0._r8 - numice10s_imm_dst(:ncol,:) = 0._r8 - numice10s_imm_bc(:ncol,:) = 0._r8 - - nnuccc_bc(:,:) = 0._r8 - nnucct_bc(:,:) = 0._r8 - nnudep_bc(:,:) = 0._r8 - - nnuccc_dst(:,:) = 0._r8 - nnucct_dst(:,:) = 0._r8 - nnudep_dst(:,:) = 0._r8 - - niimm_bc(:,:) = 0._r8 - nicnt_bc(:,:) = 0._r8 - nidep_bc(:,:) = 0._r8 - - niimm_dst(:,:) = 0._r8 - nicnt_dst(:,:) = 0._r8 - nidep_dst(:,:) = 0._r8 - - do i = 1, ncol - do k = top_lev, pver - - if (t(i,k) > 235.15_r8 .and. t(i,k) < 269.15_r8) then - qcic = min(qc(i,k)/lcldm(i,k), 5.e-3_r8) - ncic = max(nc(i,k)/lcldm(i,k), 0._r8) - - con1 = 1._r8/(1.333_r8*pi)**0.333_r8 - r3lx = con1*(rho(i,k)*qcic/(rhoh2o*max(ncic*rho(i,k), 1.0e6_r8)))**0.333_r8 ! in m - r3lx = max(4.e-6_r8, r3lx) - supersatice = svp_water(t(i,k))/svp_ice(t(i,k)) - fn(1) = factnum(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT) ! bc accumulation mode - fn(2) = factnum(i,k,MODE_IDX_DST_A2) ! dust_a1 accumulation mode - fn(3) = factnum(i,k,MODE_IDX_DST_A3) ! dust_a3 coarse mode - - call hetfrz_classnuc_calc( & - deltatin, t(i,k), pmid(i,k), supersatice, & - fn, r3lx, ncic*rho(i,k)*1.0e-6_r8, frzbcimm(i,k), frzduimm(i,k), & - frzbccnt(i,k), frzducnt(i,k), frzbcdep(i,k), frzdudep(i,k), hetraer(i,k,:), & - awcam(i,k,:), awfacm(i,k,:), dstcoat(i,k,:), total_aer_num(i,k,:), & - coated_aer_num(i,k,:), uncoated_aer_num(i,k,:), total_interstitial_aer_num(i,k,:), & - total_cloudborne_aer_num(i,k,:), errstring) - - call handle_errmsg(errstring, subname="hetfrz_classnuc_calc") - - frzimm(i,k) = frzbcimm(i,k) + frzduimm(i,k) - frzcnt(i,k) = frzbccnt(i,k) + frzducnt(i,k) - frzdep(i,k) = frzbcdep(i,k) + frzdudep(i,k) - - if (frzimm(i,k) > 0._r8) freqimm(i,k) = 1._r8 - if (frzcnt(i,k) > 0._r8) freqcnt(i,k) = 1._r8 - if (frzdep(i,k) > 0._r8) freqdep(i,k) = 1._r8 - if ((frzimm(i,k) + frzcnt(i,k) + frzdep(i,k)) > 0._r8) freqmix(i,k) = 1._r8 - else - frzimm(i,k) = 0._r8 - frzcnt(i,k) = 0._r8 - frzdep(i,k) = 0._r8 - end if - - nnuccc_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*ast(i,k) - nnucct_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*ast(i,k) - nnudep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*ast(i,k) - - nnuccc_dst(i,k) = frzduimm(i,k)*1.0e6_r8*ast(i,k) - nnucct_dst(i,k) = frzducnt(i,k)*1.0e6_r8*ast(i,k) - nnudep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*ast(i,k) - - niimm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin - nicnt_bc(i,k) = frzbccnt(i,k)*1.0e6_r8*deltatin - nidep_bc(i,k) = frzbcdep(i,k)*1.0e6_r8*deltatin - - niimm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin - nicnt_dst(i,k) = frzducnt(i,k)*1.0e6_r8*deltatin - nidep_dst(i,k) = frzdudep(i,k)*1.0e6_r8*deltatin - - numice10s(i,k) = (frzimm(i,k)+frzcnt(i,k)+frzdep(i,k))*1.0e6_r8*deltatin*(10._r8/deltatin) - numice10s_imm_dst(i,k) = frzduimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) - numice10s_imm_bc(i,k) = frzbcimm(i,k)*1.0e6_r8*deltatin*(10._r8/deltatin) - end do - end do - - call outfld('FREQIMM', freqimm, pcols, lchnk) - call outfld('FREQCNT', freqcnt, pcols, lchnk) - call outfld('FREQDEP', freqdep, pcols, lchnk) - call outfld('FREQMIX', freqmix, pcols, lchnk) - - call outfld('DSTFREZIMM', nnuccc_dst, pcols, lchnk) - call outfld('DSTFREZCNT', nnucct_dst, pcols, lchnk) - call outfld('DSTFREZDEP', nnudep_dst, pcols, lchnk) - - call outfld('BCFREZIMM', nnuccc_bc, pcols, lchnk) - call outfld('BCFREZCNT', nnucct_bc, pcols, lchnk) - call outfld('BCFREZDEP', nnudep_bc, pcols, lchnk) - - call outfld('NIMIX_IMM', niimm_bc+niimm_dst, pcols, lchnk) - call outfld('NIMIX_CNT', nicnt_bc+nicnt_dst, pcols, lchnk) - call outfld('NIMIX_DEP', nidep_bc+nidep_dst, pcols, lchnk) - - call outfld('DSTNICNT', nicnt_dst, pcols, lchnk) - call outfld('DSTNIDEP', nidep_dst, pcols, lchnk) - call outfld('DSTNIIMM', niimm_dst, pcols, lchnk) - - call outfld('BCNICNT', nicnt_bc, pcols, lchnk) - call outfld('BCNIDEP', nidep_bc, pcols, lchnk) - call outfld('BCNIIMM', niimm_bc, pcols, lchnk) - - call outfld('NUMICE10s', numice10s, pcols, lchnk) - call outfld('NUMIMM10sDST', numice10s_imm_dst, pcols, lchnk) - call outfld('NUMIMM10sBC', numice10s_imm_bc, pcols, lchnk) - - end associate - - end subroutine hetfrz_classnuc_oslo_calc - - !==================================================================================================== - - subroutine hetfrz_classnuc_oslo_save_cbaero(state, pbuf) - - ! Save the required cloud borne aerosol constituents. - type(physics_state), intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - - ! local variables - integer :: i, lchnk, kk, ncol, m, n - type qqcw_type - real(r8), pointer :: fldcw(:,:) - end type qqcw_type - type(qqcw_type) :: qqcw(pcnst) - !------------------------------------------------------------------------------- - - ! loop over the cloud borne constituents required by this module and save - ! a local copy - - lchnk = state%lchnk - ncol = state%ncol - aer_cb(1:ncol,1:pver,:,lchnk) = 0.0_r8 - do m=1,nmodes_oslo - do n=1,getNumberOfTracersInMode(m) - kk = getTracerIndex(m,n,.false.)! This gives the tracer index used in the q-array - qqcw(kk)%fldcw => qqcw_get_field(pbuf,kk) - if(associated(qqcw(kk)%fldcw))then - aer_cb(:,:,kk,lchnk) = qqcw(kk)%fldcw - end if - end do - end do - end subroutine hetfrz_classnuc_oslo_save_cbaero - - !==================================================================================================== - - subroutine get_aer_num(qaerpt, qaercwpt, rhoair, & ! input - f_acm, f_condm, & - cam, volumeCore, volumeCoat, & - total_aer_num, & ! output - coated_aer_num, & - uncoated_aer_num, & - total_interstial_aer_num, & - total_cloudborne_aer_num, & - hetraer, awcam, awfacm, dstcoat, & - na500, tot_na500) - - ! input - real(r8), intent(in) :: qaerpt(0:nmodes_oslo) ! aerosol number and mass mixing ratios(instertitial) - real(r8), intent(in) :: qaercwpt(0:nmodes_oslo) ! cloud borne aerosol number and mass mixing ratios - real(r8), intent(in) :: rhoair ! air density (kg/m3) - real(r8), intent(in) :: f_acm(nmodes_oslo) - real(r8), intent(in) :: f_condm(nmodes_oslo) - real(r8), intent(in) :: cam(nmodes_oslo) - real(r8), intent(in) :: volumeCoat(nmodes_oslo) - real(r8), intent(in) :: volumeCore(nmodes_oslo) - - ! output - real(r8), intent(out) :: total_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: total_interstial_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: total_cloudborne_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: coated_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: uncoated_aer_num(3) ! #/cm^3 - real(r8), intent(out) :: hetraer(3) ! BC and Dust mass mean radius [m] - real(r8), intent(out) :: awcam(3) ! modal added mass [mug m-3] - real(r8), intent(out) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) - real(r8), intent(out) :: dstcoat(3) ! coated fraction - real(r8), intent(out) :: na500 ! #/cm^3 interstitial aerosol number with D>500 nm (#/cm^3) - real(r8), intent(out) :: tot_na500 ! #/cm^3 total aerosol number with D>500 nm (#/cm^3) - - ! local variables - real(r8), parameter :: n_so4_monolayers_dust = 1.0_r8 ! number of so4(+nh4) monolayers needed to coat a dust particle - real(r8), parameter :: dr_so4_monolayers_dust = n_so4_monolayers_dust * 4.76e-10 - real(r8) :: sigmag_amode(3) - real(r8) :: tmp1, tmp2 - real(r8) :: bc_num ! bc number in accumulation mode - real(r8) :: dst1_num, dst3_num ! dust number in accumulation and corase mode - real(r8) :: dst1_num_imm, dst3_num_imm, bc_num_imm - real(r8) :: fac_volsfc_bc, fac_volsfc_dust_a1, fac_volsfc_dust_a3 - real(r8) :: r_bc ! model radii of BC modes [m] - real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] - integer :: i - integer :: num_bc_idx, num_dst1_idx, num_dst3_idx ! mode indices - - num_bc_idx = MODE_IDX_OMBC_INTMIX_COAT_AIT - num_dst1_idx = MODE_IDX_DST_A2 - num_dst3_idx = MODE_IDX_DST_A3 - - !***************************************************************************** - ! calculate intersitial aerosol - !***************************************************************************** - - dst1_num = qaerpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 - dst3_num = qaerpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 - bc_num = qaerpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - - !***************************************************************************** - ! calculate cloud borne aerosol - !***************************************************************************** - - dst1_num_imm = qaercwpt(num_dst1_idx)*1.0e-6_r8 ! #/cm3 - dst3_num_imm = qaercwpt(num_dst3_idx)*1.0e-6_r8 ! #/cm3 - bc_num_imm = qaercwpt(num_bc_idx)*1.0e-6_r8 ! #/cm3 - - ! calculate mass mean radius - r_dust_a1 = lifeCycleNumberMedianRadius(num_dst1_idx) - r_dust_a3 = lifeCycleNumberMedianRadius(num_dst3_idx) - r_bc = lifeCycleNumberMedianRadius(num_bc_idx) - - hetraer(1) = r_bc - hetraer(2) = r_dust_a1 - hetraer(3) = r_dust_a3 - - !***************************************************************************** - ! calculate coated fraction - !***************************************************************************** - - ! volumeCore and volumeCoat from subroutine calculateHygroscopicity in paramix_progncdnc.f90 - - sigmag_amode(1) = lifeCycleSigma(num_bc_idx) - sigmag_amode(2) = lifeCycleSigma(num_dst1_idx) - sigmag_amode(3) = lifeCycleSigma(num_dst3_idx) - - fac_volsfc_bc = exp(2.5*(log(sigmag_amode(1))**2)) - fac_volsfc_dust_a1 = exp(2.5*(log(sigmag_amode(2))**2)) - fac_volsfc_dust_a3 = exp(2.5*(log(sigmag_amode(3))**2)) - - tmp1 = volumeCoat(num_bc_idx)*(r_bc*2._r8)*fac_volsfc_bc - tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_bc_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 - dstcoat(1) = tmp1/tmp2 - - tmp1 = volumeCoat(num_dst1_idx)*(r_dust_a1*2._r8)*fac_volsfc_dust_a1 - tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst1_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 - dstcoat(2) = tmp1/tmp2 - - tmp1 = volumeCoat(num_dst3_idx)*(r_dust_a3*2._r8)*fac_volsfc_dust_a3 - tmp2 = max(6.0_r8*dr_so4_monolayers_dust*volumeCore(num_dst3_idx), 0.0_r8) ! dr_so4_monolayers_dust = n_so4_monolayers_dust (=1) * 4.67e-10 - dstcoat(3) = tmp1/tmp2 - - if (dstcoat(1) > 1._r8) dstcoat(1) = 1._r8 - if (dstcoat(1) < 0.001_r8) dstcoat(1) = 0.001_r8 - if (dstcoat(2) > 1._r8) dstcoat(2) = 1._r8 - if (dstcoat(2) < 0.001_r8) dstcoat(2) = 0.001_r8 - if (dstcoat(3) > 1._r8) dstcoat(3) = 1._r8 - if (dstcoat(3) < 0.001_r8) dstcoat(3) = 0.001_r8 - - !***************************************************************************** - ! prepare some variables for water activity - !***************************************************************************** - ! cam ([kg/m3] added mass distributed to modes) from paramix_progncdnc.f90 - - ! accumulation mode for dust_a1 - if (qaerpt(num_dst1_idx) > 0._r8) then - awcam(2) = cam(num_dst1_idx)*1.e9_r8 ! kg/m3 -> ug/m3 - else - awcam(2) = 0._r8 - end if - if (awcam(2) >0._r8) then - awfacm(2) = f_acm(num_dst1_idx) - else - awfacm(2) = 0._r8 - end if - - ! accumulation mode for dust_a3 - if (qaerpt(num_dst3_idx) > 0._r8) then - awcam(3) = cam(num_dst3_idx)*1.e9_r8 ! kg/m3 -> ug/m3 - else - awcam(3) = 0._r8 - end if - if (awcam(3) >0._r8) then - awfacm(3) = f_acm(num_dst3_idx) - else - awfacm(3) = 0._r8 - end if - - ! accumulation mode for bc - if (qaerpt(num_bc_idx) > 0._r8) then - awcam(1) = cam(num_bc_idx)*1.e9_r8 ! kg/m3 -> ug/m3 - else - awcam(1) = 0._r8 - end if - if (awcam(1) >0._r8) then - awfacm(1) = f_acm(num_bc_idx) - else - awfacm(1) = 0._r8 - end if - - !***************************************************************************** - ! prepare output - !***************************************************************************** - - total_interstial_aer_num(1) = bc_num - total_interstial_aer_num(2) = dst1_num - total_interstial_aer_num(3) = dst3_num - - total_cloudborne_aer_num(1) = bc_num_imm - total_cloudborne_aer_num(2) = dst1_num_imm - total_cloudborne_aer_num(3) = dst3_num_imm - - do i = 1, 3 - total_aer_num(i) = total_interstial_aer_num(i)+total_cloudborne_aer_num(i) - coated_aer_num(i) = total_interstial_aer_num(i)*dstcoat(i) - uncoated_aer_num(i) = total_interstial_aer_num(i)*(1._r8-dstcoat(i)) - end do - - - tot_na500 = total_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 - +total_aer_num(3) - - na500 = total_interstial_aer_num(1)*0.0256_r8 & ! scaled for D>0.5 um using Clarke et al., 1997; 2004; 2007: rg=0.1um, sig=1.6 - +total_interstial_aer_num(3) - - end subroutine get_aer_num - - !=================================================================================================== - - subroutine hetfrz_classnuc_calc( & - deltat, t, p, supersatice, & - fn, & - r3lx, icnlx, & - frzbcimm, frzduimm, & - frzbccnt, frzducnt, & - frzbcdep, frzdudep, & - hetraer, awcam, awfacm, dstcoat, & - total_aer_num, coated_aer_num, uncoated_aer_num, & - total_interstitial_aer_num, total_cloudborne_aer_num, errstring) - - real(r8), intent(in) :: deltat ! timestep [s] - real(r8), intent(in) :: t ! temperature [K] - real(r8), intent(in) :: p ! pressure [Pa] - real(r8), intent(in) :: supersatice ! supersaturation ratio wrt ice at 100%rh over water [ ] - real(r8), intent(in) :: r3lx ! volume mean drop radius [m] - real(r8), intent(in) :: icnlx ! in-cloud droplet concentration [cm-3] - real(r8), intent(in) :: fn(3) ! fraction activated [ ] for cloud borne aerosol number - ! index values are 1:bc, 2:dust_a1, 3:dust_a3 - real(r8), intent(in) :: hetraer(3) ! bc and dust mass mean radius [m] - real(r8), intent(in) :: awcam(3) ! modal added mass [mug m-3] - real(r8), intent(in) :: awfacm(3) ! (OC+BC)/(OC+BC+SO4) - real(r8), intent(in) :: dstcoat(3) ! coated fraction - real(r8), intent(in) :: total_aer_num(3) ! total bc and dust number concentration(interstitial+cloudborne) [#/cm^3] - real(r8), intent(in) :: coated_aer_num(3) ! coated bc and dust number concentration(interstitial) - real(r8), intent(in) :: uncoated_aer_num(3) ! uncoated bc and dust number concentration(interstitial) - real(r8), intent(in) :: total_interstitial_aer_num(3) ! total bc and dust concentration(interstitial) - real(r8), intent(in) :: total_cloudborne_aer_num(3) ! total bc and dust concentration(cloudborne) - real(r8), intent(out) :: frzbcimm ! het. frz by BC immersion nucleation [cm-3 s-1] - real(r8), intent(out) :: frzduimm ! het. frz by dust immersion nucleation [cm-3 s-1] - real(r8), intent(out) :: frzbccnt ! het. frz by BC contact nucleation [cm-3 s-1] - real(r8), intent(out) :: frzducnt ! het. frz by dust contact nucleation [cm-3 s-1] - real(r8), intent(out) :: frzbcdep ! het. frz by BC deposition nucleation [cm-3 s-1] - real(r8), intent(out) :: frzdudep ! het. frz by dust deposition nucleation [cm-3 s-1] - character(len=*), intent(out) :: errstring - - ! local variables - real(r8) , parameter :: Mso4 = 96.06_r8 - integer , parameter :: id_bc = 1 - integer , parameter :: id_dst1 = 2 - integer , parameter :: id_dst3 = 3 - real(r8) , parameter :: n1 = 1.e19_r8 ! number of water molecules in contact with unit area of substrate [m-2] - real(r8) , parameter :: kboltz = 1.38e-23_r8 - real(r8) , parameter :: hplanck = 6.63e-34_r8 - real(r8) , parameter :: rhplanck = 1._r8/hplanck - real(r8) , parameter :: amu = 1.66053886e-27_r8 - real(r8) , parameter :: nus = 1.e13_r8 ! frequ. of vibration [s-1] higher freq. (as in P&K, consistent with Anupam's data) - real(r8) , parameter :: taufrz = 195.435_r8 ! time constant for falloff of freezing rate [s] - real(r8) , parameter :: rhwincloud = 0.98_r8 ! 98% RH in mixed-phase clouds (Korolev & Isaac, JAS 2006) - real(r8) , parameter :: limfacbc = 0.01_r8 ! max. ice nucleating fraction soot - real(r8) :: aw(3) ! water activity [ ] - real(r8) :: molal(3) ! molality [moles/kg] - logical :: do_bc, do_dst1, do_dst3 - real(r8) :: tc - real(r8) :: vwice - real(r8) :: rhoice - real(r8) :: sigma_iw ! [J/m2] - real(r8) :: sigma_iv ! [J/m2] - real(r8) :: esice ! [Pa] - real(r8) :: eswtr ! [Pa] - real(r8) :: rgimm - real(r8) :: rgdep - real(r8) :: dg0dep - real(r8) :: Adep - real(r8) :: dg0cnt - real(r8) :: Acnt - real(r8) :: rgimm_bc - real(r8) :: rgimm_dust_a1, rgimm_dust_a3 - real(r8) :: dg0imm_bc - real(r8) :: dg0imm_dust_a1, dg0imm_dust_a3 - real(r8) :: Aimm_bc - real(r8) :: Aimm_dust_a1, Aimm_dust_a3 - real(r8) :: q, m, phi - real(r8) :: r_bc ! model radii of BC modes [m] - real(r8) :: r_dust_a1, r_dust_a3 ! model radii of dust modes [m] - real(r8) :: f_imm_bc - real(r8) :: f_imm_dust_a1, f_imm_dust_a3 - real(r8) :: Jimm_bc - real(r8) :: Jimm_dust_a1, Jimm_dust_a3 - real(r8) :: f_dep_bc - real(r8) :: f_dep_dust_a1, f_dep_dust_a3 - real(r8) :: Jdep_bc - real(r8) :: Jdep_dust_a1, Jdep_dust_a3 - real(r8) :: f_cnt_bc - real(r8) :: f_cnt_dust_a1,f_cnt_dust_a3 - real(r8) :: Jcnt_bc - real(r8) :: Jcnt_dust_a1,Jcnt_dust_a3 - integer :: i - - !******************************************************** - ! Hoose et al., 2010 fitting parameters - !******************************************************** - !freezing parameters for immersion freezing - !real(r8),parameter :: theta_imm_bc = 40.17 ! contact angle [deg], converted to rad later - !real(r8),parameter :: dga_imm_bc = 14.4E-20 ! activation energy [J] - !real(r8),parameter :: theta_imm_dust = 30.98 ! contact angle [deg], converted to rad later - !real(r8),parameter :: dga_imm_dust = 15.7E-20 ! activation energy [J] - - !freezing parameters for deposition nucleation - !real(r8),parameter :: theta_dep_dust = 12.7 ! contact angle [deg], converted to rad later !Zimmermann et al (2008), illite - !real(r8),parameter :: dga_dep_dust = -6.21E-21 ! activation energy [J] - !real(r8),parameter :: theta_dep_bc = 28. ! contact angle [deg], converted to rad later !Moehler et al (2005), soot - !real(r8),parameter :: dga_dep_bc = -2.E-19 ! activation energy [J] - - !******************************************************** - ! Wang et al., 2014 fitting parameters - !******************************************************** - ! freezing parameters for immersion freezing - real(r8),parameter :: theta_imm_bc = 48.0_r8 ! contact angle [deg], converted to rad later !DeMott et al (1990) - real(r8),parameter :: dga_imm_bc = 14.15E-20_r8 ! activation energy [J] - real(r8),parameter :: theta_imm_dust = 46.0_r8 ! contact angle [deg], converted to rad later !DeMott et al (2011) SD - real(r8),parameter :: dga_imm_dust = 14.75E-20_r8 ! activation energy [J] - - ! freezing parameters for deposition nucleation - real(r8),parameter :: theta_dep_dust = 20.0_r8 ! contact angle [deg], converted to rad later !Koehler et al (2010) SD - real(r8),parameter :: dga_dep_dust = -8.1E-21_r8 ! activation energy [J] - real(r8),parameter :: theta_dep_bc = 28._r8 ! contact angle [deg], converted to rad later !Moehler et al (2005), soot - real(r8),parameter :: dga_dep_bc = -2.E-19_r8 ! activation energy [J] - - real(r8) :: Kcoll_bc ! collision kernel [cm3 s-1] - real(r8) :: Kcoll_dust_a1 ! collision kernel [cm3 s-1] - real(r8) :: Kcoll_dust_a3 ! collision kernel [cm3 s-1] - logical :: tot_in = .false. - real(r8) :: dim_Jimm_dust_a1(pdf_n_theta), dim_Jimm_dust_a3(pdf_n_theta) - real(r8) :: sum_imm_dust_a1, sum_imm_dust_a3 - !------------------------------------------------------------------------------------------------ - - ! get saturation vapor pressures - eswtr = svp_water(t) ! 0 for liquid - esice = svp_ice(t) ! 1 for ice - - tc = t - tmelt - rhoice = 916.7_r8-0.175_r8*tc-5.e-4_r8*tc**2 - vwice = mwh2o*amu/rhoice - sigma_iw = (28.5_r8+0.25_r8*tc)*1E-3_r8 - sigma_iv = (76.1_r8-0.155_r8*tc + 28.5_r8+0.25_r8*tc)*1E-3_r8 - - ! get mass mean radius - r_bc = hetraer(1) - r_dust_a1 = hetraer(2) - r_dust_a3 = hetraer(3) - - ! calculate collision kernels as a function of environmental parameters and aerosol/droplet sizes - call collkernel(t, p, eswtr, rhwincloud, r3lx, & - r_bc, & ! BC modes - r_dust_a1, r_dust_a3, & ! dust modes - Kcoll_bc, & ! collision kernel [cm3 s-1] - Kcoll_dust_a1, Kcoll_dust_a3) - - !***************************************************************************** - ! take water activity into account - !***************************************************************************** - ! solute effect - aw(:) = 1._r8 - molal(:) = 0._r8 - - ! The heterogeneous ice freezing temperatures of all IN generally decrease with - ! increasing total solute mole fraction. Therefore, the large solution concentration - ! will cause the freezing point depression and the ice freezing temperatures of all - ! IN will get close to the homogeneous ice freezing temperatures. Since we take into - ! account water activity for three heterogeneous freezing modes(immersion, deposition, - ! and contact), we utilize interstitial aerosols(not cloudborne aerosols) to calculate - ! water activity. - ! If the index of IN is 0, it means three freezing modes of this aerosol are depressed. - - do i = 1, 3 - !calculate molality - if ( total_interstitial_aer_num(i) > 0._r8 ) then - molal(i) = (1.e-6_r8*awcam(i)*(1._r8-awfacm(i))/(Mso4*total_interstitial_aer_num(i)*1.e6_r8))/ & - (4*pi/3*rhoh2o*(MAX(r3lx,4.e-6_r8))**3) - aw(i) = 1._r8/(1._r8+2.9244948e-2_r8*molal(i)+2.3141243e-3_r8*molal(i)**2+7.8184854e-7_r8*molal(i)**3) - end if - end do - - !***************************************************************************** - ! immersion freezing begin - !***************************************************************************** - - frzbcimm = 0._r8 - frzduimm = 0._r8 - frzbccnt = 0._r8 - frzducnt = 0._r8 - frzbcdep = 0._r8 - frzdudep = 0._r8 - - ! critical germ size - rgimm = 2*vwice*sigma_iw/(kboltz*t*LOG(supersatice)) - - ! take solute effect into account - rgimm_bc = rgimm - rgimm_dust_a1 = rgimm - rgimm_dust_a3 = rgimm - - ! if aw*Si<=1, the freezing point depression is strong enough to prevent freezing - - if (aw(id_bc)*supersatice > 1._r8 ) then - do_bc = .true. - rgimm_bc = 2*vwice*sigma_iw/(kboltz*t*LOG(aw(id_bc)*supersatice)) - else - do_bc = .false. - end if - - if (aw(id_dst1)*supersatice > 1._r8 ) then - do_dst1 = .true. - rgimm_dust_a1 = 2*vwice*sigma_iw/(kboltz*t*LOG(aw(id_dst1)*supersatice)) - else - do_dst1 = .false. - end if - - if (aw(id_dst3)*supersatice > 1._r8 ) then - do_dst3 = .true. - rgimm_dust_a3 = 2*vwice*sigma_iw/(kboltz*t*LOG(aw(id_dst3)*supersatice)) - else - do_dst3 = .false. - end if - - ! form factor - ! only consider flat surfaces due to uncertainty of curved surfaces - - m = COS(theta_imm_bc*pi/180._r8) - f_imm_bc = (2+m)*(1-m)**2/4._r8 - if (.not. pdf_imm_in) then - m = COS(theta_imm_dust*pi/180._r8) - f_imm_dust_a1 = (2+m)*(1-m)**2/4._r8 - - m = COS(theta_imm_dust*pi/180._r8) - f_imm_dust_a3 = (2+m)*(1-m)**2/4._r8 - end if - - ! homogeneous energy of germ formation - dg0imm_bc = 4*pi/3._r8*sigma_iw*rgimm_bc**2 - dg0imm_dust_a1 = 4*pi/3._r8*sigma_iw*rgimm_dust_a1**2 - dg0imm_dust_a3 = 4*pi/3._r8*sigma_iw*rgimm_dust_a3**2 - - ! prefactor - Aimm_bc = n1*((vwice*rhplanck)/(rgimm_bc**3)*SQRT(3._r8/pi*kboltz*T*dg0imm_bc)) - Aimm_dust_a1 = n1*((vwice*rhplanck)/(rgimm_dust_a1**3)*SQRT(3._r8/pi*kboltz*T*dg0imm_dust_a1)) - Aimm_dust_a3 = n1*((vwice*rhplanck)/(rgimm_dust_a3**3)*SQRT(3._r8/pi*kboltz*T*dg0imm_dust_a3)) - - ! nucleation rate per particle - Jimm_bc = Aimm_bc*r_bc**2/SQRT(f_imm_bc)*EXP((-dga_imm_bc-f_imm_bc*dg0imm_bc)/(kboltz*T)) - if (.not. pdf_imm_in) then - ! 1/sqrt(f) - ! the expression of Chen et al. (sqrt(f)) may however lead to unphysical - ! behavior as it implies J->0 when f->0 (i.e. ice nucleation would be - ! more difficult on easily wettable materials). - Jimm_dust_a1 = Aimm_dust_a1*r_dust_a1**2/SQRT(f_imm_dust_a1)*EXP((-dga_imm_dust-f_imm_dust_a1*dg0imm_dust_a1)/(kboltz*T)) - Jimm_dust_a3 = Aimm_dust_a3*r_dust_a3**2/SQRT(f_imm_dust_a3)*EXP((-dga_imm_dust-f_imm_dust_a3*dg0imm_dust_a3)/(kboltz*T)) - end if - - if (pdf_imm_in) then - dim_Jimm_dust_a1 = 0.0_r8 - dim_Jimm_dust_a3 = 0.0_r8 - do i = i1,i2 - ! 1/sqrt(f) - dim_Jimm_dust_a1(i) = Aimm_dust_a1*r_dust_a1**2/SQRT(dim_f_imm_dust_a1(i))*EXP((-dga_imm_dust-dim_f_imm_dust_a1(i)* & - dg0imm_dust_a1)/(kboltz*T)) - dim_Jimm_dust_a1(i) = max(dim_Jimm_dust_a1(i), 0._r8) - - dim_Jimm_dust_a3(i) = Aimm_dust_a3*r_dust_a3**2/SQRT(dim_f_imm_dust_a3(i))*EXP((-dga_imm_dust-dim_f_imm_dust_a3(i)* & - dg0imm_dust_a3)/(kboltz*T)) - dim_Jimm_dust_a3(i) = max(dim_Jimm_dust_a3(i), 0._r8) - end do - end if - - ! Limit to 1% of available potential IN (for BC), no limit for dust - if (pdf_imm_in) then - sum_imm_dust_a1 = 0._r8 - sum_imm_dust_a3 = 0._r8 - do i = i1,i2-1 - sum_imm_dust_a1 = sum_imm_dust_a1+0.5_r8*((pdf_imm_theta(i)*exp(-dim_Jimm_dust_a1(i)*deltat)+ & - pdf_imm_theta(i+1)*exp(-dim_Jimm_dust_a1(i+1)*deltat)))*pdf_d_theta - sum_imm_dust_a3 = sum_imm_dust_a3+0.5_r8*((pdf_imm_theta(i)*exp(-dim_Jimm_dust_a3(i)*deltat)+ & - pdf_imm_theta(i+1)*exp(-dim_Jimm_dust_a3(i+1)*deltat)))*pdf_d_theta - end do - do i = i1,i2 - if (sum_imm_dust_a1 > 0.99_r8) then - sum_imm_dust_a1 = 1.0_r8 - end if - if (sum_imm_dust_a3 > 0.99_r8) then - sum_imm_dust_a3 = 1.0_r8 - end if - end do - - end if - - if (.not.tot_in) then - if (do_bc) frzbcimm = frzbcimm+MIN(limfacbc*total_cloudborne_aer_num(id_bc)/deltat, & - total_cloudborne_aer_num(id_bc)/deltat*(1._r8-exp(-Jimm_bc*deltat))) - - if (.not. pdf_imm_in) then - if (do_dst1) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst1)/deltat, & - total_cloudborne_aer_num(id_dst1)/deltat*(1._r8-exp(-Jimm_dust_a1*deltat))) - if (do_dst3) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst3)/deltat, & - total_cloudborne_aer_num(id_dst3)/deltat*(1._r8-exp(-Jimm_dust_a3*deltat))) - else - if (do_dst1) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst1)/deltat, & - total_cloudborne_aer_num(id_dst1)/deltat*(1._r8-sum_imm_dust_a1)) - if (do_dst3) frzduimm = frzduimm+MIN(1*total_cloudborne_aer_num(id_dst3)/deltat, & - total_cloudborne_aer_num(id_dst3)/deltat*(1._r8-sum_imm_dust_a3)) - end if - - else - if (do_bc) frzbcimm = frzbcimm+MIN(limfacbc*fn(id_bc)*total_aer_num(id_bc)/deltat, & - fn(id_bc)*total_aer_num(id_bc)/deltat*(1._r8-exp(-Jimm_bc*deltat))) - - if (.not. pdf_imm_in) then - if (do_dst1) frzduimm = frzduimm+MIN(1*fn(id_dst1)*total_aer_num(id_dst1)/deltat, & - fn(id_dst1)*total_aer_num(id_dst1)/deltat*(1._r8-exp(-Jimm_dust_a1*deltat))) - if (do_dst3) frzduimm = frzduimm+MIN(1*fn(id_dst3)*total_aer_num(id_dst3)/deltat, & - fn(id_dst3)*total_aer_num(id_dst3)/deltat*(1._r8-exp(-Jimm_dust_a3*deltat))) - else - if (do_dst1) frzduimm = frzduimm+MIN(1*fn(id_dst1)*total_aer_num(id_dst1)/deltat, & - fn(id_dst1)*total_aer_num(id_dst1)/deltat*(1._r8-sum_imm_dust_a1)) - if (do_dst3) frzduimm = frzduimm+MIN(1*fn(id_dst3)*total_aer_num(id_dst3)/deltat, & - fn(id_dst3)*total_aer_num(id_dst3)/deltat*(1._r8-sum_imm_dust_a3)) - end if - end if - - if (t > 263.15_r8) then - frzduimm = 0._r8 - frzbcimm = 0._r8 - end if - - !---------------------------------- - ! Deposition nucleation - !---------------------------------- - ! critical germ size - ! assume 98% RH in mixed-phase clouds (Korolev & Isaac, JAS 2006) - rgdep=2*vwice*sigma_iv/(kboltz*t*LOG(rhwincloud*supersatice)) - - ! form factor - m = COS(theta_dep_bc*pi/180._r8) - f_dep_bc = (2+m)*(1-m)**2/4._r8 - - m = COS(theta_dep_dust*pi/180._r8) - f_dep_dust_a1 = (2+m)*(1-m)**2/4._r8 - - m = COS(theta_dep_dust*pi/180._r8) - f_dep_dust_a3 = (2+m)*(1-m)**2/4._r8 - - ! homogeneous energy of germ formation - dg0dep = 4*pi/3._r8*sigma_iv*rgdep**2 - - ! prefactor - ! attention: division of small numbers - Adep = (rhwincloud*eswtr)**2*(vwice/(mwh2o*amu))/(kboltz*T*nus)*SQRT(sigma_iv/(kboltz*T)) - - ! nucleation rate per particle - if (rgdep > 0) then - Jdep_bc = Adep*r_bc**2/SQRT(f_dep_bc)*EXP((-dga_dep_bc-f_dep_bc*dg0dep)/(kboltz*T)) - Jdep_dust_a1 = Adep*r_dust_a1**2/SQRT(f_dep_dust_a1)*EXP((-dga_dep_dust-f_dep_dust_a1*dg0dep)/(kboltz*T)) - Jdep_dust_a3 = Adep*r_dust_a3**2/SQRT(f_dep_dust_a3)*EXP((-dga_dep_dust-f_dep_dust_a3*dg0dep)/(kboltz*T)) - else - Jdep_bc = 0._r8 - Jdep_dust_a1 = 0._r8 - Jdep_dust_a3 = 0._r8 - end if - - ! Limit to 1% of available potential IN (for BC), no limit for dust - if (.not.tot_in) then - if (do_bc) frzbcdep = frzbcdep+MIN(limfacbc*uncoated_aer_num(id_bc)/deltat, & - uncoated_aer_num(id_bc)/deltat & - *(1._r8-exp(-Jdep_bc*deltat))) - if (do_dst1) frzdudep = frzdudep+MIN(uncoated_aer_num(id_dst1)/deltat, & - uncoated_aer_num(id_dst1)/deltat & - *(1._r8-exp(-Jdep_dust_a1*deltat))) - if (do_dst3) frzdudep = frzdudep+MIN(uncoated_aer_num(id_dst3)/deltat, & - uncoated_aer_num(id_dst3)/deltat & - *(1._r8-exp(-Jdep_dust_a3*deltat))) - else - if (do_bc) frzbcdep = frzbcdep+MIN(limfacbc*(1._r8-fn(id_bc)) & - *(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat, & - (1._r8-fn(id_bc))*(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat & - *(1._r8-exp(-Jdep_bc*deltat))) - if (do_dst1) frzdudep = frzdudep+MIN((1._r8-fn(id_dst1)) & - *(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat, & - (1._r8-fn(id_dst1))*(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat & - *(1._r8-exp(-Jdep_dust_a1*deltat))) - if (do_dst3) frzdudep = frzdudep+MIN((1._r8-fn(id_dst3)) & - *(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat, & - (1._r8-fn(id_dst3))*(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat & - *(1._r8-exp(-Jdep_dust_a3*deltat))) - end if - - ! --------------------------- - ! contact nucleation - ! --------------------------- - - ! form factor - m = COS(theta_dep_bc*pi/180._r8) - f_cnt_bc = (2+m)*(1-m)**2/4._r8 - - m = COS(theta_dep_dust*pi/180._r8) - f_cnt_dust_a1 = (2+m)*(1-m)**2/4._r8 - - m = COS(theta_dep_dust*pi/180._r8) - f_cnt_dust_a3 = (2+m)*(1-m)**2/4._r8 - - ! homogeneous energy of germ formation - dg0cnt = 4*pi/3._r8*sigma_iv*rgimm**2 - - ! prefactor - ! attention: division of small numbers - Acnt = rhwincloud*eswtr*4*pi/(nus*SQRT(2*pi*mwh2o*amu*kboltz*T)) - - ! nucleation rate per particle - Jcnt_bc = Acnt*r_bc**2*EXP((-dga_dep_bc-f_cnt_bc*dg0cnt)/(kboltz*T))*Kcoll_bc*icnlx - Jcnt_dust_a1 = Acnt*r_dust_a1**2*EXP((-dga_dep_dust-f_cnt_dust_a1*dg0cnt)/(kboltz*T))*Kcoll_dust_a1*icnlx - Jcnt_dust_a3 = Acnt*r_dust_a3**2*EXP((-dga_dep_dust-f_cnt_dust_a3*dg0cnt)/(kboltz*T))*Kcoll_dust_a3*icnlx - - ! Limit to 1% of available potential IN (for BC), no limit for dust - if (.not.tot_in) then - if (do_bc) frzbccnt = frzbccnt+MIN(limfacbc*uncoated_aer_num(id_bc)/deltat, & - uncoated_aer_num(id_bc)/deltat & - *(1._r8-exp(-Jcnt_bc*deltat))) - if (do_dst1) frzducnt = frzducnt+MIN(uncoated_aer_num(id_dst1)/deltat, & - uncoated_aer_num(id_dst1)/deltat & - *(1._r8-exp(-Jcnt_dust_a1*deltat))) - if (do_dst3) frzducnt = frzducnt+MIN(uncoated_aer_num(id_dst3)/deltat, & - uncoated_aer_num(id_dst3)/deltat & - *(1._r8-exp(-Jcnt_dust_a3*deltat))) - else - if (do_bc) frzbccnt = frzbccnt+MIN(limfacbc*(1._r8-fn(id_bc))*(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat, & - (1._r8-fn(id_bc))*(1._r8-dstcoat(1))*total_aer_num(id_bc)/deltat & - *(1._r8-exp(-Jcnt_bc*deltat))) - if (do_dst1) frzducnt = frzducnt+MIN((1._r8-fn(id_dst1))*(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat, & - (1._r8-fn(id_dst1))*(1._r8-dstcoat(2))*total_aer_num(id_dst1)/deltat & - *(1._r8-exp(-Jcnt_dust_a1*deltat))) - if (do_dst3) frzducnt = frzducnt+MIN((1._r8-fn(id_dst3))*(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat, & - (1._r8-fn(id_dst3))*(1._r8-dstcoat(3))*total_aer_num(id_dst3)/deltat & - *(1._r8-exp(-Jcnt_dust_a3*deltat))) - end if - - errstring = ' ' - if (frzducnt <= -1._r8) then - write(iulog,*) 'hetfrz_classnuc_calc: frzducnt', frzducnt, Jcnt_dust_a1,Jcnt_dust_a3, & - Kcoll_dust_a1, Kcoll_dust_a3 - errstring = 'ERROR in hetfrz_classnuc_calc::frzducnt' - return - end if - - end subroutine hetfrz_classnuc_calc - - !=================================================================================================== - - subroutine collkernel( & - t, pres, eswtr, rhwincloud, r3lx, & - r_bc, & ! BC modes - r_dust_a1, r_dust_a3, & ! dust modes - Kcoll_bc, & ! collision kernel [cm3 s-1] - Kcoll_dust_a1, Kcoll_dust_a3) - - !----------------------------------------------------------------------- - ! Purpose: calculate collision kernels as a function of - ! environmental parameters and aerosol/droplet sizes - ! Author: Corinna Hoose, UiO, October 2009 - ! Modifications: Yong Wang and Xiaohong Liu, UWyo, 12/2012 - !----------------------------------------------------------------------- - - real(r8), intent(in) :: t ! temperature [K] - real(r8), intent(in) :: pres ! pressure [Pa] - real(r8), intent(in) :: eswtr ! saturation vapor pressure of water [Pa] - real(r8), intent(in) :: r3lx ! volume mean drop radius [m] - real(r8), intent(in) :: rhwincloud ! in-cloud relative humidity over water [ ] - real(r8), intent(in) :: r_bc ! model radii of BC modes [m] - real(r8), intent(in) :: r_dust_a1 ! model radii of dust modes [m] - real(r8), intent(in) :: r_dust_a3 ! model radii of dust modes [m] - real(r8), intent(out) :: Kcoll_bc ! collision kernel [cm3 s-1] - real(r8), intent(out) :: Kcoll_dust_a1 - real(r8), intent(out) :: Kcoll_dust_a3 - - ! local variables - real(r8) :: a, b, c, a_f, b_f, c_f, f - real(r8) :: tc ! temperature [deg C] - real(r8) :: rho_air ! air density [kg m-3] - real(r8) :: viscos_air ! dynamic viscosity of air [kg m-1 s-1] - real(r8) :: Ktherm_air ! thermal conductivity of air [J/(m s K)] - real(r8) :: lambda ! mean free path [m] - real(r8) :: Kn ! Knudsen number [ ] - real(r8) :: Re ! Reynolds number [ ] - real(r8) :: Pr ! Prandtl number [ ] - real(r8) :: Sc ! Schmidt number [ ] - real(r8) :: vterm ! terminal velocity [m s-1] - real(r8) :: Ktherm ! thermal conductivity of aerosol [J/(m s K)] - real(r8) :: Dvap ! water vapor diffusivity [m2 s-1] - real(r8) :: Daer ! aerosol diffusivity [m2 s-1] - real(r8) :: latvap ! latent heat of vaporization [J kg-1] - real(r8) :: kboltz ! Boltzmann constant [J K-1] - real(r8) :: G ! thermodynamic function in Cotton et al. [kg m-1 s-1] - real(r8) :: r_a ! aerosol radius [m] - real(r8) :: f_t ! factor by Waldmann & Schmidt [ ] - real(r8) :: Q_heat ! heat flux [J m-2 s-1] - real(r8) :: Tdiff_cotton ! temperature difference between droplet and environment [K] - real(r8) :: K_brownian,K_thermo_cotton,K_diffusio_cotton ! collision kernels [m3 s-1] - real(r8) :: K_total ! total collision kernel [cm3 s-1] - integer :: i - !------------------------------------------------------------------------------------------------ - - Kcoll_bc = 0._r8 - Kcoll_dust_a1 = 0._r8 - Kcoll_dust_a3 = 0._r8 - - tc = t - tmelt - kboltz = 1.38065e-23_r8 - - ! air viscosity for tc<0, from depvel_part.F90 - viscos_air = (1.718_r8+0.0049_r8*tc-1.2e-5_r8*tc*tc)*1.e-5_r8 - - ! air density - rho_air = pres/(rair*t) - - ! mean free path: Seinfeld & Pandis 8.6 - lambda = 2*viscos_air/(pres*SQRT(8/(pi*rair*t))) - - ! latent heat of vaporization, varies with T - latvap = 1000*(-0.0000614342_r8*tc**3 + 0.00158927_r8*tc**2 - 2.36418_r8*tc + 2500.79_r8) - - ! droplet terminal velocity after Chen & Liu, QJRMS 2004 - a = 8.8462e2_r8 - b = 9.7593e7_r8 - c = -3.4249e-11_r8 - a_f = 3.1250e-1_r8 - b_f = 1.0552e-3_r8 - c_f = -2.4023_r8 - f = EXP(EXP(a_f + b_f*(LOG(r3lx))**3 + c_f*rho_air**1.5_r8)) - vterm = (a+ (b + c*r3lx)*r3lx)*r3lx*f - - ! Reynolds number - Re = 2*vterm*r3lx*rho_air/viscos_air - - ! thermal conductivity of air: Seinfeld & Pandis eq. 15.75 - Ktherm_air = 1.e-3_r8*(4.39_r8+0.071_r8*t) !J/(m s K) - - ! Prandtl number - Pr = viscos_air*cpair/Ktherm_air - - ! water vapor diffusivity: Pruppacher & Klett 13-3 - Dvap = 0.211e-4_r8*(t/273.15_r8)*(101325._r8/pres) - - ! G-factor = rhoh2o*Xi in Rogers & Yau, p. 104 - G = rhoh2o/((latvap/(rh2o*t) - 1)*latvap*rhoh2o/(Ktherm_air*t) + rhoh2o*rh2o*t/(Dvap*eswtr)) - - ! variables depending on aerosol radius - ! loop over 3 aerosol modes - do i = 1, 3 - if (i == 1) r_a = r_bc - if (i == 2) r_a = r_dust_a1 - if (i == 3) r_a = r_dust_a3 - ! Knudsen number (Seinfeld & Pandis 8.1) - Kn = lambda/r_a - ! aerosol diffusivity - Daer = kboltz*t*(1 + Kn)/(6*pi*r_a*viscos_air) - ! Schmidt number - Sc = viscos_air/(Daer*rho_air) - - ! Young (1974) first equ. on page 771 - K_brownian = 4*pi*r3lx*Daer*(1 + 0.3_r8*Re**0.5_r8*Sc**0.33_r8) - - ! thermal conductivities from Seinfeld & Pandis, Table 8.6 - if (i == 1) Ktherm = 4.2_r8 ! Carbon - if (i == 2 .or. i == 3) Ktherm = 0.72_r8 ! clay - - ! form factor - f_t = 0.4_r8*(1._r8 + 1.45_r8*Kn + 0.4_r8*Kn*EXP(-1._r8/Kn)) & - *(Ktherm_air + 2.5_r8*Kn*Ktherm) & - /((1._r8 + 3._r8*Kn)*(2._r8*Ktherm_air + 5._r8*Kn*Ktherm+Ktherm)) - - ! calculate T-Tc as in Cotton et al. - Tdiff_cotton = -G*(rhwincloud - 1._r8)*latvap/Ktherm_air - Q_heat = Ktherm_air/r3lx*(1._r8 + 0.3_r8*Re**0.5_r8*Pr**0.33_r8)*Tdiff_cotton - K_thermo_cotton = 4._r8*pi*r3lx*r3lx*f_t*Q_heat/pres - K_diffusio_cotton = -(1._r8/f_t)*(rh2o*t/latvap)*K_thermo_cotton - K_total = 1.e6_r8*(K_brownian + K_thermo_cotton + K_diffusio_cotton) ! convert m3/s -> cm3/s - - ! set K to 0 if negative - if (K_total .lt. 0._r8) K_total = 0._r8 - - if (i == 1) Kcoll_bc = K_total - if (i == 2) Kcoll_dust_a1 = K_total - if (i == 3) Kcoll_dust_a3 = K_total - end do - - end subroutine collkernel - - !=================================================================================================== - - subroutine hetfrz_classnuc_init_pdftheta() - - ! Local variables: - real(r8) :: theta_min, theta_max - real(r8) :: x1_imm, x2_imm - real(r8) :: norm_theta_imm - real(r8) :: imm_dust_mean_theta - real(r8) :: imm_dust_var_theta - integer :: i - real(r8) :: m - real(r8) :: temp - !---------------------------------------------------------------------------- - - theta_min = pi/180._r8 - theta_max = 179._r8/180._r8*pi - imm_dust_mean_theta = 46.0_r8/180.0_r8*pi - imm_dust_var_theta = 0.01_r8 - - pdf_d_theta = (179._r8-1._r8)/180._r8*pi/(pdf_n_theta-1) - - x1_imm = (LOG(theta_min) - LOG(imm_dust_mean_theta))/(sqrt(2.0_r8)*imm_dust_var_theta) - x2_imm = (LOG(theta_max) - LOG(imm_dust_mean_theta))/(sqrt(2.0_r8)*imm_dust_var_theta) - norm_theta_imm = (ERF(x2_imm) - ERF(x1_imm))*0.5_r8 - dim_theta = 0.0_r8 - pdf_imm_theta = 0.0_r8 - do i = i1, i2 - dim_theta(i) = 1._r8/180._r8*pi + (i-1)*pdf_d_theta - pdf_imm_theta(i) = exp(-((LOG(dim_theta(i)) - LOG(imm_dust_mean_theta))**2._r8) / & - (2._r8*imm_dust_var_theta**2._r8) ) / & - (dim_theta(i)*imm_dust_var_theta*SQRT(2*pi))/norm_theta_imm - end do - - do i = i1, i2 - m = cos(dim_theta(i)) - temp = (2+m)*(1-m)**2/4._r8 - dim_f_imm_dust_a1(i) = temp - dim_f_imm_dust_a3(i) = temp - end do - - end subroutine hetfrz_classnuc_init_pdftheta - -end module oslo_aero_hetfrz diff --git a/src/chemistry/oslo_aero/oslo_aero_linear_interp.F90 b/src/chemistry/oslo_aero/oslo_aero_linear_interp.F90 deleted file mode 100644 index 7385e25d0c..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_linear_interp.F90 +++ /dev/null @@ -1,134 +0,0 @@ -module oslo_aero_linear_interp - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - private - - public :: lininterpol3dim - public :: lininterpol4dim - public :: lininterpol5dim - -! ========================================================== -contains -! ========================================================== - - subroutine lininterpol3dim (d2mx, dxm1, invd, opt3d, optout1, optout2) - - ! arguments - real(r8), intent(in) :: opt3d(2,2,2) - real(r8), intent(in) :: d2mx(3) - real(r8), intent(in) :: dxm1(3) - real(r8), intent(in) :: invd(3) - real(r8), intent(out) :: optout1 - real(r8), intent(out) :: optout2 - ! - ! local variables - real(r8) :: opt2d(2,2) - !------------------------------------ - - ! interpolation in the third dimension (except invd(3) factor) - opt2d(1,1) = d2mx(3)*opt3d(1,1,1) + dxm1(3)*opt3d(1,1,2) - opt2d(1,2) = d2mx(3)*opt3d(1,2,1) + dxm1(3)*opt3d(1,2,2) - opt2d(2,1) = d2mx(3)*opt3d(2,1,1) + dxm1(3)*opt3d(2,1,2) - opt2d(2,2) = d2mx(3)*opt3d(2,2,1) + dxm1(3)*opt3d(2,2,2) - - ! interpolation in the (third and) second dimension - optout1 = (d2mx(2)*opt2d(1,1) + dxm1(2)*opt2d(1,2))*invd(3)*invd(2) - optout2 = (d2mx(2)*opt2d(2,1) + dxm1(2)*opt2d(2,2))*invd(3)*invd(2) - - end subroutine lininterpol3dim - - ! ========================================================== - subroutine lininterpol4dim (d2mx, dxm1, invd, opt4d, optout1, optout2) - - ! arguments - real(r8), intent(in) :: opt4d(2,2,2,2) - real(r8), intent(in) :: d2mx(4) - real(r8), intent(in) :: dxm1(4) - real(r8), intent(in) :: invd(4) - real(r8), intent(out) :: optout1 - real(r8), intent(out) :: optout2 - ! - ! local variables - real(r8) :: opt3d(2,2,2), opt2d(2,2) - !------------------------------------ - - ! interpolation in the fourth dimension (except invd(4) factor) - opt3d(1,1,1) = d2mx(4)*opt4d(1,1,1,1) + dxm1(4)*opt4d(1,1,1,2) - opt3d(1,1,2) = d2mx(4)*opt4d(1,1,2,1) + dxm1(4)*opt4d(1,1,2,2) - opt3d(1,2,1) = d2mx(4)*opt4d(1,2,1,1) + dxm1(4)*opt4d(1,2,1,2) - opt3d(1,2,2) = d2mx(4)*opt4d(1,2,2,1) + dxm1(4)*opt4d(1,2,2,2) - opt3d(2,1,1) = d2mx(4)*opt4d(2,1,1,1) + dxm1(4)*opt4d(2,1,1,2) - opt3d(2,1,2) = d2mx(4)*opt4d(2,1,2,1) + dxm1(4)*opt4d(2,1,2,2) - opt3d(2,2,1) = d2mx(4)*opt4d(2,2,1,1) + dxm1(4)*opt4d(2,2,1,2) - opt3d(2,2,2) = d2mx(4)*opt4d(2,2,2,1) + dxm1(4)*opt4d(2,2,2,2) - - ! interpolation in the third dimension (except invd(3) factor) - opt2d(1,1) = d2mx(3)*opt3d(1,1,1) + dxm1(3)*opt3d(1,1,2) - opt2d(1,2) = d2mx(3)*opt3d(1,2,1) + dxm1(3)*opt3d(1,2,2) - opt2d(2,1) = d2mx(3)*opt3d(2,1,1) + dxm1(3)*opt3d(2,1,2) - opt2d(2,2) = d2mx(3)*opt3d(2,2,1) + dxm1(3)*opt3d(2,2,2) - - ! interpolation in the (fourth, third and) second dimension - optout1 = (d2mx(2)*opt2d(1,1) + dxm1(2)*opt2d(1,2))*invd(4)*invd(3)*invd(2) - optout2 = (d2mx(2)*opt2d(2,1) + dxm1(2)*opt2d(2,2))*invd(4)*invd(3)*invd(2) - - end subroutine lininterpol4dim - - ! ========================================================== - subroutine lininterpol5dim (d2mx, dxm1, invd, opt5d, optout1, optout2) - - ! arguments - real(r8), intent(in) :: opt5d(2,2,2,2,2) - real(r8), intent(in) :: d2mx(5) - real(r8), intent(in) :: dxm1(5) - real(r8), intent(in) :: invd(5) - real(r8), intent(out) :: optout1 - real(r8), intent(out) :: optout2 - - ! local variables - real(r8) :: opt4d(2,2,2,2), opt3d(2,2,2), opt2d(2,2) - !------------------------------------ - - ! interpolation in the fifth dimension (except invd(5) factor) - opt4d(1,1,1,1) = d2mx(5)*opt5d(1,1,1,1,1) + dxm1(5)*opt5d(1,1,1,1,2) - opt4d(1,1,1,2) = d2mx(5)*opt5d(1,1,1,2,1) + dxm1(5)*opt5d(1,1,1,2,2) - opt4d(1,1,2,1) = d2mx(5)*opt5d(1,1,2,1,1) + dxm1(5)*opt5d(1,1,2,1,2) - opt4d(1,1,2,2) = d2mx(5)*opt5d(1,1,2,2,1) + dxm1(5)*opt5d(1,1,2,2,2) - opt4d(1,2,1,1) = d2mx(5)*opt5d(1,2,1,1,1) + dxm1(5)*opt5d(1,2,1,1,2) - opt4d(1,2,1,2) = d2mx(5)*opt5d(1,2,1,2,1) + dxm1(5)*opt5d(1,2,1,2,2) - opt4d(1,2,2,1) = d2mx(5)*opt5d(1,2,2,1,1) + dxm1(5)*opt5d(1,2,2,1,2) - opt4d(1,2,2,2) = d2mx(5)*opt5d(1,2,2,2,1) + dxm1(5)*opt5d(1,2,2,2,2) - opt4d(2,1,1,1) = d2mx(5)*opt5d(2,1,1,1,1) + dxm1(5)*opt5d(2,1,1,1,2) - opt4d(2,1,1,2) = d2mx(5)*opt5d(2,1,1,2,1) + dxm1(5)*opt5d(2,1,1,2,2) - opt4d(2,1,2,1) = d2mx(5)*opt5d(2,1,2,1,1) + dxm1(5)*opt5d(2,1,2,1,2) - opt4d(2,1,2,2) = d2mx(5)*opt5d(2,1,2,2,1) + dxm1(5)*opt5d(2,1,2,2,2) - opt4d(2,2,1,1) = d2mx(5)*opt5d(2,2,1,1,1) + dxm1(5)*opt5d(2,2,1,1,2) - opt4d(2,2,1,2) = d2mx(5)*opt5d(2,2,1,2,1) + dxm1(5)*opt5d(2,2,1,2,2) - opt4d(2,2,2,1) = d2mx(5)*opt5d(2,2,2,1,1) + dxm1(5)*opt5d(2,2,2,1,2) - opt4d(2,2,2,2) = d2mx(5)*opt5d(2,2,2,2,1) + dxm1(5)*opt5d(2,2,2,2,2) - - ! interpolation in the fourth dimension (except invd(4) factor) - opt3d(1,1,1) = d2mx(4)*opt4d(1,1,1,1) + dxm1(4)*opt4d(1,1,1,2) - opt3d(1,1,2) = d2mx(4)*opt4d(1,1,2,1) + dxm1(4)*opt4d(1,1,2,2) - opt3d(1,2,1) = d2mx(4)*opt4d(1,2,1,1) + dxm1(4)*opt4d(1,2,1,2) - opt3d(1,2,2) = d2mx(4)*opt4d(1,2,2,1) + dxm1(4)*opt4d(1,2,2,2) - opt3d(2,1,1) = d2mx(4)*opt4d(2,1,1,1) + dxm1(4)*opt4d(2,1,1,2) - opt3d(2,1,2) = d2mx(4)*opt4d(2,1,2,1) + dxm1(4)*opt4d(2,1,2,2) - opt3d(2,2,1) = d2mx(4)*opt4d(2,2,1,1) + dxm1(4)*opt4d(2,2,1,2) - opt3d(2,2,2) = d2mx(4)*opt4d(2,2,2,1) + dxm1(4)*opt4d(2,2,2,2) - - ! interpolation in the third dimension (except invd(3) factor) - opt2d(1,1) = d2mx(3)*opt3d(1,1,1) + dxm1(3)*opt3d(1,1,2) - opt2d(1,2) = d2mx(3)*opt3d(1,2,1) + dxm1(3)*opt3d(1,2,2) - opt2d(2,1) = d2mx(3)*opt3d(2,1,1) + dxm1(3)*opt3d(2,1,2) - opt2d(2,2) = d2mx(3)*opt3d(2,2,1) + dxm1(3)*opt3d(2,2,2) - - ! interpolation in the (fifth, fourth, third and) second dimension - optout1 = (d2mx(2)*opt2d(1,1) + dxm1(2)*opt2d(1,2))*(invd(5)*invd(4)*invd(3)*invd(2)) - optout2 = (d2mx(2)*opt2d(2,1) + dxm1(2)*opt2d(2,2))*(invd(5)*invd(4)*invd(3)*invd(2)) - - end subroutine lininterpol5dim - -end module oslo_aero_linear_interp diff --git a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 deleted file mode 100644 index faa1380466..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_logn_tables.F90 +++ /dev/null @@ -1,716 +0,0 @@ -module oslo_aero_logn_tables - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols - use cam_logfile, only: iulog - use spmd_utils, only: masterproc - ! - use oslo_aero_control, only: oslo_aero_getopts,dir_string_length - use oslo_aero_sw_tables, only: cate, fac, faq, fbc, cat - use oslo_aero_linear_interp, only: lininterpol3dim, lininterpol4dim - use oslo_aero_params, only: nmodes, nbmodes - use oslo_aero_share - - implicit none - private - - public :: initlogn - public :: intlog1to3_sub - public :: intlog4_sub - public :: intlog5to10_sub - - real(r8) :: rrr1to3 (3,16,6) ! Modal radius array, mode 1 - 3 - real(r8) :: sss1to3 (3,16,6) ! Standard deviation array, Mode 1 -3 - real(r8) :: rrr4 (16,6,6) ! Modal radius array, mode 4 - real(r8) :: sss4 (16,6,6) ! Modal radius array, mode 4 - real(r8) :: rrr (5:10,6,6,6,6) ! Modal radius array, mode 5 - 10 - real(r8) :: sss (5:10,6,6,6,6) ! Standard deviation array, mode 5 - 10 - - real(r8) :: calog1to3(3,96) ! Array for reading catot from file - real(r8) :: rk1to3 (3,96) ! Array for reading modal radius from file - real(r8) :: stdv1to3 (3,96) ! Array for reading std. dev. from file - real(r8) :: fraclog1to3 (3,96) ! Same as frac4, but for initlogn.F90 - - real(r8) :: calog4(576) ! Same as catot4, but for initlogn.F90 - real(r8) :: fraclog4(576) ! Same as frac4, but for initlogn.F90 - real(r8) :: fraqlog4(576) ! Same as fraq4, but for initlogn.F90 - real(r8) :: rk4 (576) ! Array for reading modal radius from file - real(r8) :: stdv4 (576) ! Array for reading std. dev. from file - - real(r8) :: calog (5:10,1296) ! Same as catot, but for initlogn.F90 - real(r8) :: fraclog5to10 (5:10,1296) ! Same as frac5to10, but for initlogn.F90 - real(r8) :: fabclog5to10 (5:10,1296) ! Same as fabc5to10, but for initlogn.F90 - real(r8) :: fraqlog5to10 (5:10,1296) ! Same as fraq5to10, but for initlogn.F90 - real(r8) :: rk5to10 (5:10,1296) ! Array for reading modal radius from file - real(r8) :: stdv5to10 (5:10,1296) ! Array for reading std. dev. from file - -!======================================================= -contains -!======================================================= - - subroutine initlogn() - - ! Reads the tabulated parameters for "best lognormal fits" of the - ! aerosol size distribution wrt CCN activation as calculated by Alf Kirkevaag. - - integer :: kcomp, ictot, ifac, ifbc, ifaq - integer :: ic, ifil, lin - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps4 = 1.e-4_r8 - character(len=dir_string_length) :: aerotab_table_dir - - ! Where are the tables stored?? - call oslo_aero_getopts(aerotab_table_dir_out=aerotab_table_dir) - - open(20,file=trim(aerotab_table_dir)//'/logntilp1.out' ,form='formatted',status='old') ! SO4&SOA(n/Ait) - open(21,file=trim(aerotab_table_dir)//'/logntilp2.out' ,form='formatted',status='old') ! BC(n/Ait) - open(22,file=trim(aerotab_table_dir)//'/logntilp3.out' ,form='formatted',status='old') ! OC(n/Ait) - open(23,file=trim(aerotab_table_dir)//'/logntilp4.out' ,form='formatted',status='old') ! BC&OC(n/Ait) - open(24,file=trim(aerotab_table_dir)//'/logntilp5.out' ,form='formatted',status='old') ! SO4(Ait75) - open(25,file=trim(aerotab_table_dir)//'/logntilp6.out' ,form='formatted',status='old') ! MINACC - open(26,file=trim(aerotab_table_dir)//'/logntilp7.out' ,form='formatted',status='old') ! MINCOA - open(27,file=trim(aerotab_table_dir)//'/logntilp8.out' ,form='formatted',status='old') ! SEASF - open(28,file=trim(aerotab_table_dir)//'/logntilp9.out' ,form='formatted',status='old') ! SEASACC - open(29,file=trim(aerotab_table_dir)//'/logntilp10.out',form='formatted',status='old') ! SEASCOA - if (masterproc) then - write(iulog,*)'nlog open ok' - end if - - ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 20,29 - call checkTableHeader (ifil) - enddo - - ! ************************************************************************ - ! Mode 1 (SO4&SOA + condesate from H2SO4 and SOA) - ! Modes 2 to 3 (BC/OC + condesate from H2SO4 and SOA) - ! - ! These two are treated the same way since there is no dependence on - ! fombg (SOA fraction in the background) for mode 1. - ! ************************************************************************ - - do ifil = 1,2 - do lin = 1,96 ! 16*6 entries - read(19+ifil,993) kcomp, calog1to3(ifil,lin), fraclog1to3 (ifil, lin), & - rk1to3(ifil,lin), stdv1to3(ifil,lin) - - do ic=1,16 - if(abs((calog1to3(ifil,lin)-cate(kcomp,ic))/cate(kcomp,ic))shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, pverp - use ref_pres, only: top_lev => trop_cloud_top_lev - use physconst, only: rair - use constituents, only: cnst_get_ind, pcnst - use physics_types, only: physics_state, physics_ptend, physics_ptend_init, physics_ptend_sum - use physics_types, only: physics_state_copy, physics_update - use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field - use phys_control, only: phys_getopts, use_hetfrz_classnuc - use rad_constituents, only: rad_cnst_get_info, rad_cnst_get_aer_mmr, rad_cnst_get_aer_props, rad_cnst_get_mode_num - use ndrop_bam, only: ndrop_bam_init, ndrop_bam_run, ndrop_bam_ccn - use cam_history, only: addfld, add_default, outfld - use cam_logfile, only: iulog - ! - use oslo_aero_ndrop, only: ndrop_init_oslo, dropmixnuc_oslo - use oslo_aero_conc, only: oslo_aero_conc_calc - use oslo_aero_hetfrz, only: hetfrz_classnuc_oslo_register, hetfrz_classnuc_oslo_init, hetfrz_classnuc_oslo_readnl - use oslo_aero_hetfrz, only: hetfrz_classnuc_oslo_calc, hetfrz_classnuc_oslo_save_cbaero - use oslo_aero_nucleate_ice, only: nucleate_ice_oslo_register, nucleate_ice_oslo_init, nucleate_ice_oslo_readnl - use oslo_aero_nucleate_ice, only: nucleate_ice_oslo_calc, use_preexisting_ice - use oslo_aero_params, only: nmodes_oslo => nmodes - use oslo_aero_share, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC, MODE_IDX_OMBC_INTMIX_COAT_AIT - use oslo_aero_share, only: lifeCycleNumberMedianRadius, l_dst_a2, l_dst_a3, l_bc_ai - use oslo_aero_share, only: getNumberOfTracersInMode, getTracerIndex, getCloudTracerIndex - - implicit none - private - - public :: oslo_aero_microp_init, oslo_aero_microp_run, oslo_aero_microp_readnl, oslo_aero_microp_register - - ! Private module data - - character(len=16) :: eddy_scheme - - ! contact freezing due to dust, dust number mean radius (m), - ! Zender et al JGR 2003 assuming number mode radius of 0.6 micron, sigma=2 - real(r8), parameter :: rn_dst1 = 0.258e-6_r8 - real(r8), parameter :: rn_dst2 = 0.717e-6_r8 - real(r8), parameter :: rn_dst3 = 1.576e-6_r8 - real(r8), parameter :: rn_dst4 = 3.026e-6_r8 - - ! smallest mixing ratio considered in microphysics - real(r8), parameter :: qsmall = 1.e-18_r8 - - ! minimum allowed cloud fraction - real(r8), parameter :: mincld = 0.0001_r8 - - ! indices in state%q and pbuf structures - integer :: cldliq_idx = -1 - integer :: cldice_idx = -1 - integer :: numliq_idx = -1 - integer :: numice_idx = -1 - integer :: kvh_idx = -1 - integer :: tke_idx = -1 - integer :: wp2_idx = -1 - integer :: ast_idx = -1 - integer :: cldo_idx = -1 - integer :: dgnumwet_idx = -1 - - ! prescribed aerosol bulk sulfur scale factor - real(r8) :: bulk_scale - - integer :: npccn_idx, rndst_idx, nacon_idx - -!========================================================================================= -contains -!========================================================================================= - - subroutine oslo_aero_microp_readnl(nlfile) - - use namelist_utils, only: find_group_name - use cam_abortutils, only: endrun - use mpishorthand - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Namelist variables - real(r8) :: microp_aero_bulk_scale = 2._r8 ! prescribed aerosol bulk sulfur scale factor - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'microp_aero_readnl' - - namelist /microp_aero_nl/ microp_aero_bulk_scale - !----------------------------------------------------------------------------- - - if (masterproc) then - open(newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'microp_aero_nl', status=ierr) - if (ierr == 0) then - read(unitn, microp_aero_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - end if -#ifdef SPMD - call mpibcast(microp_aero_bulk_scale, 1, mpir8, 0, mpicom) -#endif - - ! set local variables - bulk_scale = microp_aero_bulk_scale - - call nucleate_ice_oslo_readnl(nlfile) - call hetfrz_classnuc_oslo_readnl(nlfile) - - end subroutine oslo_aero_microp_readnl - - !========================================================================================= - subroutine oslo_aero_microp_register - !----------------------------------------------------------------------- - ! Register pbuf fields for aerosols needed by microphysics - ! Author: Cheryl Craig October 2012 - !----------------------------------------------------------------------- - - use physics_buffer, only: pbuf_add_field, dtype_r8 - - call pbuf_add_field('NPCCN', 'physpkg',dtype_r8,(/pcols,pver/) , npccn_idx) - call pbuf_add_field('RNDST', 'physpkg',dtype_r8,(/pcols,pver,4/), rndst_idx) - call pbuf_add_field('NACON', 'physpkg',dtype_r8,(/pcols,pver,4/), nacon_idx) - - call nucleate_ice_oslo_register() - call hetfrz_classnuc_oslo_register() - - end subroutine oslo_aero_microp_register - - !========================================================================================= - - subroutine oslo_aero_microp_init - - !----------------------------------------------------------------------- - ! Initialize constants for aerosols needed by microphysics - ! Author: Andrew Gettelman May 2010 - !----------------------------------------------------------------------- - - ! local variables - integer :: iaer, ierr - integer :: m, n, nmodes, nspec - - character(len=32) :: str32 - character(len=*), parameter :: routine = 'oslo_aero_microp_init' - logical :: history_amwg - !----------------------------------------------------------------------- - - ! Query the PBL eddy scheme - call phys_getopts(eddy_scheme_out=eddy_scheme, history_amwg_out=history_amwg ) - - ! Access the physical properties of the aerosols that are affecting the climate - ! by using routines from the rad_constituents module. - - ! get indices into state and pbuf structures - call cnst_get_ind('CLDLIQ', cldliq_idx) - call cnst_get_ind('CLDICE', cldice_idx) - call cnst_get_ind('NUMLIQ', numliq_idx) - call cnst_get_ind('NUMICE', numice_idx) - - select case(trim(eddy_scheme)) - case ('diag_TKE') - tke_idx = pbuf_get_index('tke') - case ('CLUBB_SGS') - wp2_idx = pbuf_get_index('WP2_nadv') - case default - kvh_idx = pbuf_get_index('kvh') - end select - ast_idx = pbuf_get_index('AST') - cldo_idx = pbuf_get_index('CLDO') - - call addfld('LCLOUD', (/ 'lev' /), 'A', ' ', 'Liquid cloud fraction used in stratus activation') - call addfld('WSUB', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity' ) - call addfld('WSUBI', (/ 'lev' /), 'A', 'm/s', 'Diagnostic sub-grid vertical velocity for ice' ) - if (history_amwg) then - call add_default ('WSUB ', 1, ' ') - end if - - call ndrop_init_oslo() - call nucleate_ice_oslo_init(mincld, bulk_scale) - call hetfrz_classnuc_oslo_init(mincld) - - end subroutine oslo_aero_microp_init - - !========================================================================================= - subroutine oslo_aero_microp_run (state, ptend_all, deltatin, pbuf) - - ! arguments - type(physics_state), intent(in) :: state - type(physics_ptend), intent(out) :: ptend_all - real(r8), intent(in) :: deltatin ! time step (s) - type(physics_buffer_desc), pointer :: pbuf(:) - - ! local workspace - ! all units mks unless otherwise stated - integer :: i, k, m - integer :: itim_old - integer :: nmodes - type(physics_state) :: state1 ! Local copy of state variable - type(physics_ptend) :: ptend_loc - real(r8), pointer :: ast(:,:) - real(r8), pointer :: npccn(:,:) ! number of CCN (liquid activated) - real(r8), pointer :: rndst(:,:,:) ! radius of 4 dust bins for contact freezing - real(r8), pointer :: nacon(:,:,:) ! number in 4 dust bins for contact freezing - real(r8), pointer :: num_coarse(:,:) ! number m.r. of coarse mode - real(r8), pointer :: coarse_dust(:,:) ! mass m.r. of coarse dust - real(r8), pointer :: coarse_nacl(:,:) ! mass m.r. of coarse nacl - real(r8), pointer :: coarse_so4(:,:) ! mass m.r. of coarse sulfate - real(r8), pointer :: kvh(:,:) ! vertical eddy diff coef (m2 s-1) - real(r8), pointer :: tke(:,:) ! TKE from the UW PBL scheme (m2 s-2) - real(r8), pointer :: wp2(:,:) ! CLUBB vertical velocity variance - real(r8), pointer :: cldn(:,:) ! cloud fraction - real(r8), pointer :: cldo(:,:) ! old cloud fraction - real(r8), pointer :: dgnumwet(:,:,:) ! aerosol mode diameter - real(r8), pointer :: aer_mmr(:,:) ! aerosol mass mixing ratio - real(r8) :: rho(pcols,pver) ! air density (kg m-3) - real(r8) :: lcldm(pcols,pver) ! liq cloud fraction - real(r8) :: lcldn(pcols,pver) ! fractional coverage of new liquid cloud - real(r8) :: lcldo(pcols,pver) ! fractional coverage of old liquid cloud - real(r8) :: cldliqf(pcols,pver) ! fractional of total cloud that is liquid - real(r8) :: qcld ! total cloud water - real(r8) :: nctend_mixnuc(pcols,pver) - real(r8) :: dum, dum2 ! temporary dummy variable - real(r8) :: dmc, ssmc, so4mc ! variables for modal scheme. - integer :: dst_idx, num_idx - real(r8) :: wsub(pcols,pver) ! diagnosed sub-grid vertical velocity st. dev. (m/s) - real(r8) :: wsubi(pcols,pver) ! diagnosed sub-grid vertical velocity ice (m/s) - real(r8) :: nucboas - real(r8) :: wght - integer :: lchnk, ncol - real(r8) :: factnum(pcols,pver,0:nmodes_oslo) ! activation fraction for aerosol number - real(r8) :: qaercwpt(pcols,pver,pcnst) - logical :: hasAerosol(pcols, pver, nmodes_oslo) - real(r8) :: f_acm(pcols,pver, nmodes_oslo) - real(r8) :: f_bcm(pcols,pver, nmodes_oslo) - real(r8) :: f_aqm(pcols, pver, nmodes_oslo) - real(r8) :: f_so4_condm(pcols, pver, nmodes_oslo) !Needed in "get component fraction" - real(r8) :: f_soam(pcols, pver, nmodes_oslo) !Needed in "get component fraction" - real(r8) :: numberConcentration(pcols,pver,0:nmodes_oslo) ![#/m3] number concentraiton - real(r8) :: volumeConcentration(pcols,pver,nmodes_oslo) ![m3/m3] volume concentration - real(r8) :: hygroscopicity(pcols,pver,nmodes_oslo) ![mol_{aer}/mol_{water}] hygroscopicity - real(r8) :: lnsigma(pcols,pver,nmodes_oslo) ![-] log(base e) sigma - real(r8) :: CProcessModes(pcols,pver) - real(r8) :: cam(pcols,pver,nmodes_oslo) - real(r8) :: f_c(pcols, pver) - real(r8) :: f_aq(pcols,pver) - real(r8) :: f_bc(pcols,pver) - real(r8) :: f_so4_cond(pcols,pver) - real(r8) :: f_soa(pcols,pver) - real(r8) :: volumeCore(pcols,pver,nmodes_oslo) - real(r8) :: volumeCoat(pcols,pver,nmodes_oslo) - !------------------------------------------------------------------------------- - - call physics_state_copy(state,state1) - - lchnk = state1%lchnk - ncol = state1%ncol - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - call pbuf_get_field(pbuf, npccn_idx, npccn) - call pbuf_get_field(pbuf, nacon_idx, nacon) - call pbuf_get_field(pbuf, rndst_idx, rndst) - - call physics_ptend_init(ptend_all, state%psetcols, 'microp_aero') - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, cldn, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - call pbuf_get_field(pbuf, cldo_idx, cldo, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - ! initialize output - npccn(1:ncol,1:pver) = 0._r8 - nacon(1:ncol,1:pver,:) = 0._r8 - - ! set default or fixed dust bins for contact freezing - rndst(1:ncol,1:pver,1) = rn_dst1 - rndst(1:ncol,1:pver,2) = rn_dst2 - rndst(1:ncol,1:pver,3) = rn_dst3 - rndst(1:ncol,1:pver,4) = rn_dst4 - - ! save copy of cloud borne aerosols for use in heterogeneous freezing - if (use_hetfrz_classnuc) then - call hetfrz_classnuc_oslo_save_cbaero(state, pbuf) - end if - - ! initialize time-varying parameters - do k = top_lev, pver - do i = 1, ncol - rho(i,k) = state1%pmid(i,k)/(rair*state1%t(i,k)) - end do - end do - - factnum(1:ncol,1:pver,0:nmodes_oslo) = 0._r8 - cam(:,:,:) = 0._r8 - - ! More refined computation of sub-grid vertical velocity - ! Set to be zero at the surface by initialization. - - select case (trim(eddy_scheme)) - case ('diag_TKE') - call pbuf_get_field(pbuf, tke_idx, tke) - case ('CLUBB_SGS') - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, wp2_idx, wp2, start=(/1,1,itim_old/),kount=(/pcols,pverp,1/)) - allocate(tke(pcols,pverp)) - tke(:ncol,:) = (3._r8/2._r8)*wp2(:ncol,:) - - case default - call pbuf_get_field(pbuf, kvh_idx, kvh) - end select - - ! Set minimum values above top_lev. - wsub(:ncol,:top_lev-1) = 0.20_r8 - wsubi(:ncol,:top_lev-1) = 0.001_r8 - - do k = top_lev, pver - do i = 1, ncol - - select case (trim(eddy_scheme)) - case ('diag_TKE', 'CLUBB_SGS') - wsub(i,k) = sqrt(0.5_r8*(tke(i,k) + tke(i,k+1))*(2._r8/3._r8)) - wsub(i,k) = min(wsub(i,k),10._r8) - case default - ! get sub-grid vertical velocity from diff coef. - ! following morrison et al. 2005, JAS - ! assume mixing length of 30 m - dum = (kvh(i,k) + kvh(i,k+1))/2._r8/30._r8 - ! use maximum sub-grid vertical vel of 10 m/s - dum = min(dum, 10._r8) - ! set wsub to value at current vertical level - wsub(i,k) = dum - end select - - wsubi(i,k) = max(0.001_r8, wsub(i,k)) - if (.not. use_preexisting_ice) then - wsubi(i,k) = min(wsubi(i,k), 0.2_r8) - endif - wsub(i,k) = max(0.20_r8, wsub(i,k)) - - end do - end do - - call outfld('WSUB', wsub, pcols, lchnk) - call outfld('WSUBI', wsubi, pcols, lchnk) - - if (trim(eddy_scheme) == 'CLUBB_SGS') deallocate(tke) - - ! Get size distributed interstitial aerosol - call oslo_aero_conc_calc(ncol, state%q, rho, CProcessModes, & - f_c, f_bc, f_aq, f_so4_cond, f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & - numberConcentration, volumeConcentration, hygroscopicity, lnsigma, hasAerosol, volumeCore, volumeCoat) - - ! ----------------- - ! ICE Nucleation - ! ----------------- - call nucleate_ice_oslo_calc(state1, wsubi, pbuf, deltatin, ptend_loc, numberConcentration) - - call physics_ptend_sum(ptend_loc, ptend_all, ncol) - call physics_update(state1, ptend_loc, deltatin) - - ! get liquid cloud fraction, check for minimum - do k = top_lev, pver - do i = 1, ncol - lcldm(i,k) = max(ast(i,k), mincld) - end do - end do - - ! ----------------- - ! Droplet Activation - ! ----------------- - - ! partition cloud fraction into liquid water part - lcldn = 0._r8 - lcldo = 0._r8 - cldliqf = 0._r8 - do k = top_lev, pver - do i = 1, ncol - qcld = state1%q(i,k,cldliq_idx) + state1%q(i,k,cldice_idx) - if (qcld > qsmall) then - lcldn(i,k) = cldn(i,k)*state1%q(i,k,cldliq_idx)/qcld - lcldo(i,k) = cldo(i,k)*state1%q(i,k,cldliq_idx)/qcld - cldliqf(i,k) = state1%q(i,k,cldliq_idx)/qcld - end if - end do - end do - - call outfld('LCLOUD', lcldn, pcols, lchnk) - - ! If not using preexsiting ice, then only use cloudbourne aerosol for the - ! liquid clouds. This is the same behavior as CAM5. - if (use_preexisting_ice) then - call dropmixnuc_oslo( & - state1, ptend_loc, deltatin, pbuf, wsub, & ! Input - cldn, cldo, cldliqf, & - hasAerosol, & - CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, & - cam, f_acm, f_bcm, f_aqm, f_so4_condm, & - f_soam, & - numberConcentration, volumeConcentration, & - hygroscopicity, lnsigma, & - nctend_mixnuc, & ! Output - factnum ) - else - ! Note difference in arguments lcldn, lcldo - cldliqf = 1._r8 - call dropmixnuc_oslo( & - state1, ptend_loc, deltatin, pbuf, wsub, & ! Input - lcldn, lcldo, cldliqf, & - hasAerosol, & - CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, & - cam, f_acm, f_bcm, f_aqm, f_so4_condm, & - f_soam, & - numberConcentration, volumeConcentration, & - hygroscopicity, lnsigma, & - nctend_mixnuc, & ! Output - factnum ) - end if - npccn(:ncol,:) = nctend_mixnuc(:ncol,:) - - call physics_ptend_sum(ptend_loc, ptend_all, ncol) - call physics_update(state1, ptend_loc, deltatin) - - ! Contact freezing (-40 shr_kind_r8 - use constituents, only: pcnst, cnst_name, cnst_get_ind - use ppgrid, only: pcols, pver, pverp - use phys_control, only: phys_getopts, cam_physpkg_is - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - use perf_mod, only: t_startf, t_stopf - use camsrfexch, only: cam_in_t, cam_out_t - use aerodep_flx, only: aerodep_flx_prescribed - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_get_index, pbuf_set_field - use physconst, only: gravit, rair, rhoh2o, pi - use spmd_utils, only: masterproc - use time_manager, only: get_nstep - use cam_history, only: outfld, fieldname_len, addfld, add_default, horiz_only - use chem_mods, only: gas_pcnst, adv_mass - use mo_tracname, only: solsym - use mo_setsox, only: setsox - use mo_mass_xforms, only: vmr2mmr, mmr2vmr, mmr2vmri - use mo_chem_utls, only: get_rxt_ndx, get_spc_ndx - use ref_pres, only: top_lev => clim_modal_aero_top_lev - use wv_saturation, only: qsat_water - ! - use oslo_aero_depos, only: oslo_aero_depos_init - use oslo_aero_depos, only: oslo_aero_depos_dry, oslo_aero_depos_wet, oslo_aero_wetdep_init - use oslo_aero_coag, only: coagtend, clcoag - use oslo_aero_coag, only: initializeCoagulationReceivers - use oslo_aero_coag, only: initializeCoagulationCoefficients - use oslo_aero_coag, only: initializeCoagulationOutput - use oslo_aero_utils, only: calculateNumberConcentration - use oslo_aero_condtend, only: N_COND_VAP, COND_VAP_ORG_SV, COND_VAP_ORG_LV, COND_VAP_H2SO4 - use oslo_aero_condtend, only: registerCondensation, initializeCondensation, condtend - use oslo_aero_seasalt, only: oslo_aero_seasalt_init, oslo_aero_seasalt_emis, seasalt_active - use oslo_aero_dust, only: oslo_aero_dust_init, oslo_aero_dust_emis, dust_active - use oslo_aero_ocean, only: oslo_aero_ocean_init, oslo_aero_dms_emis - use oslo_aero_sw_tables, only: initopt, initopt_lw - use oslo_aero_share, only: chemistryIndex, physicsIndex, getCloudTracerIndexDirect, getCloudTracerName - use oslo_aero_share, only: qqcw_get_field, numberOfProcessModeTracers - use oslo_aero_share, only: lifeCycleNumberMedianRadius - use oslo_aero_share, only: getCloudTracerName - use oslo_aero_share, only: aero_register - use oslo_aero_sox_cldaero, only: sox_cldaero_init - use oslo_aero_params, only: originalSigma, originalNumberMedianRadius - use oslo_aero_params, only: nmodes_oslo=>nmodes, nbmodes - use oslo_aero_const, only: numberToSurface -#ifdef AEROCOM - use oslo_aero_aerocom_opt, only: initaeropt - use oslo_aero_aerocom_dry, only: initdryp -#endif - - implicit none - private - - public :: aero_model_readnl - public :: aero_model_register - public :: aero_model_init - public :: aero_model_gasaerexch ! create, grow, change, and shrink aerosols. - public :: aero_model_drydep ! aerosol dry deposition and sediment - public :: aero_model_wetdep ! aerosol wet removal - public :: aero_model_emissions ! aerosol emissions - public :: aero_model_surfarea ! tropopspheric aerosol wet surface area for chemistry - public :: aero_model_strat_surfarea ! stratospheric aerosol wet surface area for chemistry - - private :: aero_model_constants - - ! Misc private data - integer :: nmodes ! number of modes - integer :: pblh_idx= 0 - integer :: ndx_h2so4, ndx_soa_lv, ndx_soa_sv ! for surf_area_dens - logical :: convproc_do_aer - - ! Namelist variables - character(len=16) :: wetdep_list(pcnst) = ' ' - character(len=16) :: drydep_list(pcnst) = ' ' - real(r8) :: sol_facti_cloud_borne = 1._r8 - real(r8) :: sol_factb_interstitial = 0.1_r8 - real(r8) :: sol_factic_interstitial = 0.4_r8 - real(r8) :: seasalt_emis_scale - -!============================================================================= -contains -!============================================================================= - - subroutine aero_model_readnl(nlfile) - ! read aerosol namelist options - - use namelist_utils, only: find_group_name - use mpishorthand - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=16) :: aer_wetdep_list(pcnst) = ' ' ! Namelist variable - character(len=16) :: aer_drydep_list(pcnst) = ' ' ! Namelist variable - character(len=*), parameter :: subname = 'aero_model_readnl' - - namelist /aerosol_nl/ aer_wetdep_list, aer_drydep_list, sol_facti_cloud_borne, & - sol_factb_interstitial, sol_factic_interstitial - !----------------------------------------------------------------------------- - - ! Read namelist - if (masterproc) then - open(newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'aerosol_nl', status=ierr) - if (ierr == 0) then - read(unitn, aerosol_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - end if -#ifdef SPMD - ! Broadcast namelist variables - call mpibcast(aer_wetdep_list, len(aer_wetdep_list(1))*pcnst, mpichar, 0, mpicom) - call mpibcast(aer_drydep_list, len(aer_drydep_list(1))*pcnst, mpichar, 0, mpicom) - call mpibcast(sol_facti_cloud_borne, 1, mpir8, 0, mpicom) - call mpibcast(sol_factb_interstitial, 1, mpir8, 0, mpicom) - call mpibcast(sol_factic_interstitial, 1, mpir8, 0, mpicom) - call mpibcast(seasalt_emis_scale, 1, mpir8, 0, mpicom) -#endif - - wetdep_list = aer_wetdep_list - drydep_list = aer_drydep_list - - end subroutine aero_model_readnl - - !============================================================================= - subroutine aero_model_register() - - call aero_register() - call registerCondensation() - - end subroutine aero_model_register - - !============================================================================= - subroutine aero_model_init( pbuf2d ) - - ! args - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local vars - integer :: m, n, id, l - character(len=20) :: dummy - logical :: history_aerosol ! Output MAM or SECT aerosol tendencies - character(len=2) :: unit_basename ! Units 'kg' or '1' - !------------------------------------ - - call phys_getopts(history_aerosol_out=history_aerosol, convproc_do_aer_out=convproc_do_aer) - - call aero_model_constants - call initopt - call initopt_lw - call initializeCondensation() - call oslo_aero_ocean_init() - call oslo_aero_depos_init(pbuf2d) - call oslo_aero_dust_init() - call oslo_aero_seasalt_init() !seasalt_emis_scale) - call oslo_aero_wetdep_init() -#ifdef AEROCOM - call initaeropt() - call initdryp() -#endif - - dummy = 'RAM1' - call addfld (dummy,horiz_only, 'A','frac','RAM1') - if ( history_aerosol ) then - call add_default (dummy, 1, ' ') - endif - dummy = 'airFV' - call addfld (dummy,horiz_only, 'A','frac','FV') - if ( history_aerosol ) then - call add_default (dummy, 1, ' ') - endif - - ! Get height of boundary layer for boundary layer nucleation - pblh_idx = pbuf_get_index('pblh') - - call cnst_get_ind ( "H2SO4", ndx_h2so4, abort=.true. ) - ndx_h2so4 = chemistryIndex(ndx_h2so4) - call cnst_get_ind ( "SOA_LV", ndx_soa_lv,abort=.true.) - ndx_soa_lv = chemistryIndex(ndx_soa_lv) - call cnst_get_ind ( "SOA_SV", ndx_soa_sv, abort=.true.) - ndx_soa_sv = chemistryIndex(ndx_soa_sv) - - do m = 1,gas_pcnst - unit_basename = 'kg' ! Units 'kg' or '1' - - call addfld( 'GS_'//trim(solsym(m)),horiz_only, 'A', unit_basename//'/m2/s ', & - trim(solsym(m))//' gas chemistry/wet removal (for gas species)') - - call addfld( 'AQ_'//trim(solsym(m)),horiz_only, 'A', unit_basename//'/m2/s ', & - trim(solsym(m))//' aqueous chemistry (for gas species)') - - if(physicsIndex(m).le.pcnst) then - if (getCloudTracerIndexDirect(physicsIndex(m)) .gt. 0)then - call addfld( 'AQ_'//getCloudTracerName(physicsIndex(m)),horiz_only, 'A', unit_basename//'/m2/s ', & - trim(solsym(m))//' aqueous chemistry (for cloud species)') - end if - end if - - if ( history_aerosol ) then - call add_default( 'GS_'//trim(solsym(m)), 1, ' ') - call add_default( 'AQ_'//trim(solsym(m)), 1, ' ') - if(physicsIndex(m).le.pcnst) then - if(getCloudTracerIndexDirect(physicsIndex(m)).gt.0)then - call add_default( 'AQ_'//getCloudTracerName(physicsIndex(m)),1,' ') - end if - end if - endif - enddo - - call addfld ('NUCLRATE',(/'lev'/), 'A','#/cm3/s','Nucleation rate') - call addfld ('FORMRATE',(/'lev'/), 'A','#/cm3/s','Formation rate of 12nm particles') - call addfld ('COAGNUCL',(/'lev'/), 'A', '/s','Coagulation sink for nucleating particles') - call addfld ('GRH2SO4',(/'lev'/), 'A', 'nm/hour','Growth rate H2SO4') - call addfld ('GRSOA',(/'lev'/),'A','nm/hour','Growth rate SOA') - call addfld ('GR',(/'lev'/), 'A', 'nm/hour','Growth rate, H2SO4+SOA') - call addfld ('NUCLSOA',(/'lev'/),'A','kg/kg','SOA nucleate') - call addfld ('ORGNUCL',(/'lev'/),'A','kg/kg','Organic gas available for nucleation') - - if(history_aerosol)then - call add_default ('NUCLRATE', 1, ' ') - call add_default ('FORMRATE', 1, ' ') - call add_default ('COAGNUCL', 1, ' ') - call add_default ('GRH2SO4', 1, ' ') - call add_default ('GRSOA', 1, ' ') - call add_default ('GR', 1, ' ') - call add_default ('NUCLSOA', 1, ' ') - call add_default ('ORGNUCL', 1, ' ') - end if - - call addfld( 'XPH_LWC', (/ 'lev' /), 'A','kg/kg', 'pH value multiplied by lwc') - call addfld ('AQSO4_H2O2', horiz_only, 'A','kg/m2/s', 'SO4 aqueous phase chemistry due to H2O2') - call addfld ('AQSO4_O3', horiz_only, 'A','kg/m2/s', 'SO4 aqueous phase chemistry due to O3') - - if ( history_aerosol ) then - call add_default ('XPH_LWC', 1, ' ') - call add_default ('AQSO4_H2O2', 1, ' ') - call add_default ('AQSO4_O3', 1, ' ') - endif - - end subroutine aero_model_init - - !============================================================================= - subroutine aero_model_drydep ( state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend ) - - ! args - type(physics_state), intent(in) :: state ! Physics state variables - real(r8), intent(in) :: obklen(:) - real(r8), intent(in) :: ustar(:) ! sfc fric vel - type(cam_in_t), target, intent(in) :: cam_in ! import state - real(r8), intent(in) :: dt ! time step - type(cam_out_t), intent(inout) :: cam_out ! export state - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - type(physics_buffer_desc), pointer :: pbuf(:) - - ! local vars - integer :: ncol - real(r8), dimension(pcols, pver, 0:nmodes_oslo) :: oslo_dgnumwet - real(r8), dimension(pcols, pver, 0:nmodes_oslo) :: oslo_wetdens - real(r8), dimension(pcols, pver, numberOfProcessModeTracers) :: oslo_dgnumwet_processmodes - real(r8), dimension(pcols, pver, numberOfProcessModeTracers) :: oslo_wetdens_processmodes - - ncol = state%ncol - oslo_wetdens(:,:,:) = 0._r8 - call calcaersize_sub( ncol, state%t, state%q(1,1,1), state%pmid, state%pdel, & - oslo_dgnumwet, oslo_wetdens, oslo_dgnumwet_processmodes, oslo_wetdens_processmodes) - - call oslo_aero_depos_dry(state, pbuf, obklen, ustar, cam_in, dt, cam_out, ptend, & - oslo_dgnumwet, oslo_wetdens, oslo_dgnumwet_processmodes, oslo_wetdens_processmodes, & - cam_in%cflx ) - - endsubroutine aero_model_drydep - - !============================================================================= - subroutine aero_model_wetdep( state, dt, dlf, cam_out, ptend, pbuf) - - type(physics_state), intent(in) :: state ! Physics state variables - real(r8), intent(in) :: dt ! time step - real(r8), intent(in) :: dlf(:,:) ! shallow+deep convective detrainment [kg/kg/s] - type(cam_out_t), intent(inout) :: cam_out ! export state - type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - type(physics_buffer_desc), pointer :: pbuf(:) - - call oslo_aero_depos_wet( state, dt, dlf, cam_out, ptend, pbuf) - - endsubroutine aero_model_wetdep - - !============================================================================= - subroutine aero_model_surfarea(mmr, radmean, relhum, pmid, temp, strato_sad, sulfate, rho, ltrop, & - dlat, het1_ndx, pbuf, ncol, sfc, dm_aer, sad_trop, reff_trop ) - - !------------------------------------------------------------------------- - ! provides wet tropospheric aerosol surface area info for modal aerosols - ! called from mo_usrrxt - !------------------------------------------------------------------------- - - ! arguments - real(r8), intent(in) :: pmid(:,:) - real(r8), intent(in) :: temp(:,:) - real(r8), intent(in) :: mmr(:,:,:) - real(r8), intent(in) :: radmean ! mean radii in cm - real(r8), intent(in) :: strato_sad(:,:) - integer, intent(in) :: ncol - integer, intent(in) :: ltrop(:) - real(r8), intent(in) :: dlat(:) ! degrees latitude - integer, intent(in) :: het1_ndx - real(r8), intent(in) :: relhum(:,:) - real(r8), intent(in) :: rho(:,:) ! total atm density (/cm^3) - real(r8), intent(in) :: sulfate(:,:) - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(inout) :: sfc(:,:,:) - real(r8), intent(inout) :: dm_aer(:,:,:) - real(r8), intent(inout) :: sad_trop(:,:) - real(r8), intent(out) :: reff_trop(:,:) - - ! local vars - ! HAVE TO GET RID OF THIS MODE 0!! MESSES UP EVERYTHING!! - real(r8) :: numberConcentration(pcols,pver,0:nmodes_oslo) - real(r8), target :: sad_mode(pcols,pver,nmodes_oslo) - real(r8) :: rho_air(pcols,pver) - integer :: l,m,i,k - - ! Get air density - do k=1,pver - do i=1,ncol - rho_air(i,k) = pmid(i,k)/(temp(i,k)*287.04_r8) - end do - end do - - ! Get number concentrations - call calculateNumberConcentration(ncol, mmr, rho_air, numberConcentration) - - ! Convert to area using lifecycle-radius - sad_mode = 0._r8 - sad_trop = 0._r8 - do m=1,nmodes_oslo - do k=1,pver - sad_mode(:ncol,k,m) = numberConcentration(:ncol,k,m)*numberToSurface(m)*1.e-2_r8 !m2/m3 ==> cm2/cm3 - sad_trop(:ncol,k) = sad_trop(:ncol,k) + sad_mode(:ncol,k,m) - end do - end do - - do m=1,nmodes_oslo - do k=1,pver - sfc(:ncol,k,m) = sad_mode(:ncol,k,m) ! aitken_idx:aitken_idx) - dm_aer(:ncol,k,m) = 2.0_r8*lifeCycleNumberMedianRadius(m) - end do - end do - - ! Need to implement reff_trop here - reff_trop(:,:) = 1.0e-6_r8 - - end subroutine aero_model_surfarea - - !============================================================================= - subroutine aero_model_strat_surfarea( ncol, mmr, pmid, temp, ltrop, pbuf, strato_sad, reff_strat ) - - !------------------------------------------------------------------------- - ! provides WET stratospheric aerosol surface area info for modal aerosols - ! if modal_strat_sulfate = TRUE -- called from mo_gas_phase_chemdr - !------------------------------------------------------------------------- - - ! arguments - integer, intent(in) :: ncol - real(r8), intent(in) :: mmr(:,:,:) - real(r8), intent(in) :: pmid(:,:) - real(r8), intent(in) :: temp(:,:) - integer, intent(in) :: ltrop(:) ! tropopause level indices - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(out) :: strato_sad(:,:) - real(r8), intent(out) :: reff_strat(:,:) - - reff_strat = 0.1e-6_r8 - strato_sad = 0._r8 - - end subroutine aero_model_strat_surfarea - - !============================================================================= - subroutine aero_model_gasaerexch( loffset, ncol, lchnk, troplev, delt, reaction_rates, & - tfld, pmid, pdel, mbar, relhum, & - zm, qh2o, cwat, cldfr, cldnum, & - airdens, invariants, del_h2so4_gasprod, & - vmr0, vmr, pbuf ) - - ! arguments - integer, intent(in) :: loffset ! offset applied to modal aero "pointers" - integer, intent(in) :: ncol ! number columns in chunk - integer, intent(in) :: lchnk ! chunk index - integer, intent(in) :: troplev(pcols) - real(r8), intent(in) :: delt ! time step size (sec) - real(r8), intent(in) :: reaction_rates(:,:,:) ! reaction rates - real(r8), intent(in) :: tfld(:,:) ! temperature (K) - real(r8), intent(in) :: pmid(:,:) ! pressure at model levels (Pa) - real(r8), intent(in) :: pdel(:,:) ! pressure thickness of levels (Pa) - real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) - real(r8), intent(in) :: relhum(:,:) ! relative humidity - real(r8), intent(in) :: airdens(:,:) ! total atms density (molec/cm**3) - real(r8), intent(in) :: invariants(:,:,:) - real(r8), intent(in) :: zm(:,:) - real(r8), intent(in) :: qh2o(:,:) - real(r8), intent(in) :: cwat(:,:) ! cloud liquid water content (kg/kg) - real(r8), intent(in) :: cldfr(:,:) - real(r8), intent(in) :: cldnum(:,:) ! droplet number concentration (#/kg) - real(r8), intent(inout) :: del_h2so4_gasprod(:,:) ! [molec/molec/sec] - real(r8), intent(in) :: vmr0(:,:,:) ! initial mixing ratios (before gas-phase chem changes) - real(r8), intent(inout) :: vmr(:,:,:) ! mixing ratios ( vmr ) - type(physics_buffer_desc), pointer :: pbuf(:) - - ! local vars - integer, parameter :: nmodes_aq_chem = 1 - integer :: n,m,i,k,l - integer :: nstep - real(r8) :: wrk(ncol) - real(r8) :: dvmrcwdt(ncol,pver,gas_pcnst) - real(r8) :: dvmrdt(ncol,pver,gas_pcnst) - real(r8) :: vmrcw(ncol,pver,gas_pcnst) ! cloud-borne aerosol (vmr) - real(r8) :: del_h2so4_aeruptk(ncol,pver) - real(r8) :: del_h2so4_aqchem(ncol,pver) - real(r8) :: mmr_cond_vap_start_of_timestep(pcols,pver,N_COND_VAP) - real(r8) :: mmr_cond_vap_gasprod(pcols,pver,N_COND_VAP) - real(r8) :: del_soa_lv_gasprod(ncol,pver) - real(r8) :: del_soa_sv_gasprod(ncol,pver) - real(r8) :: dvmrdt_sv1(ncol,pver,gas_pcnst) - real(r8) :: dvmrcwdt_sv1(ncol,pver,gas_pcnst) - real(r8) :: mmr_tend_ncols(ncol, pver, gas_pcnst) - real(r8) :: mmr_tend_pcols(pcols, pver, gas_pcnst) - integer :: cond_vap_idx - real(r8) :: aqso4(ncol,nmodes_aq_chem) ! aqueous phase chemistry - real(r8) :: aqh2so4(ncol,nmodes_aq_chem) ! aqueous phase chemistry - real(r8) :: aqso4_h2o2(ncol) ! SO4 aqueous phase chemistry due to H2O2 - real(r8) :: aqso4_o3(ncol) ! SO4 aqueous phase chemistry due to O3 - real(r8) :: xphlwc(ncol,pver) ! pH value multiplied by lwc - real(r8) :: delt_inverse ! 1 / timestep - real(r8), pointer :: pblh(:) - character(len=32) :: name - - nstep = get_nstep() - - delt_inverse = 1.0_r8 / delt - - ! Get height of boundary layer (needed for boundary layer nucleation) - call pbuf_get_field(pbuf, pblh_idx, pblh) - - ! calculate tendency due to gas phase chemistry and processes - dvmrdt(:ncol,:,:) = (vmr(:ncol,:,:) - vmr0(:ncol,:,:)) / delt - do m = 1, gas_pcnst - wrk(:) = 0._r8 - do k = 1,pver - wrk(:ncol) = wrk(:ncol) + dvmrdt(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit - end do - name = 'GS_'//trim(solsym(m)) - call outfld( name, wrk(:ncol), ncol, lchnk ) - enddo - - ! Get mass mixing ratios at start of time step - call vmr2mmr( vmr0, mmr_tend_ncols, mbar, ncol ) - mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_H2SO4) = mmr_tend_ncols(1:ncol,:,ndx_h2so4) - mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) = mmr_tend_ncols(1:ncol,:,ndx_soa_lv) - mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) = mmr_tend_ncols(1:ncol,:,ndx_soa_sv) - ! - ! Aerosol processes ... - call qqcw2vmr( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) - - ! save h2so4 change by gas phase chem (for later new particle nucleation) - if (ndx_h2so4 > 0) then - del_h2so4_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_h2so4) - vmr0(1:ncol,:,ndx_h2so4) - endif - - del_soa_lv_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_soa_lv) - vmr0(1:ncol,:,ndx_soa_lv) - del_soa_sv_gasprod(1:ncol,:) = vmr(1:ncol,:,ndx_soa_sv) - vmr0(1:ncol,:,ndx_soa_sv) - - dvmrdt(:ncol,:,:) = vmr(:ncol,:,:) - dvmrcwdt(:ncol,:,:) = vmrcw(:ncol,:,:) - - !Save intermediate concentrations - dvmrdt_sv1 = vmr - dvmrcwdt_sv1 = vmrcw - - ! aqueous chemistry ... - call setsox( ncol, lchnk, loffset, delt, pmid, pdel, tfld, mbar, cwat, & - cldfr, cldnum, airdens, invariants, vmrcw, vmr, xphlwc, & - aqso4, aqh2so4, aqso4_h2o2, aqso4_o3) - - call outfld( 'AQSO4_H2O2', aqso4_h2o2(:ncol), ncol, lchnk) - call outfld( 'AQSO4_O3', aqso4_o3(:ncol), ncol, lchnk) - call outfld( 'XPH_LWC', xphlwc(:ncol,:), ncol, lchnk ) - - ! vmr tendency from aqchem and soa routines - dvmrdt_sv1 = (vmr - dvmrdt_sv1)/delt - dvmrcwdt_sv1 = (vmrcw - dvmrcwdt_sv1)/delt - - if(ndx_h2so4 .gt. 0)then - del_h2so4_aqchem(:ncol,:) = dvmrdt_sv1(:ncol,:,ndx_h2so4)*delt !"production rate" of H2SO4 - else - del_h2so4_aqchem(:ncol,:) = 0.0_r8 - end if - - do m = 1,gas_pcnst - wrk(:ncol) = 0._r8 - do k = 1,pver - wrk(:ncol) = wrk(:ncol) + dvmrdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit - end do - name = 'AQ_'//trim(solsym(m)) - call outfld( name, wrk(:ncol), ncol, lchnk ) - - !In oslo aero also write out the tendencies for the - !cloud borne aerosols... - n = physicsIndex(m) - if (n.le.pcnst) then - if(getCloudTracerIndexDirect(n) .gt. 0)then - name = 'AQ_'//trim(getCloudTracerName(n)) - wrk(:ncol)=0.0_r8 - do k=1,pver - wrk(:ncol) = wrk(:ncol) + dvmrcwdt_sv1(:ncol,k,m)*adv_mass(m)/mbar(:ncol,k)*pdel(:ncol,k)/gravit - end do - call outfld( name, wrk(:ncol), ncol, lchnk ) - end if - end if - enddo - - ! condensation - call vmr2mmr( vmr, mmr_tend_ncols, mbar, ncol ) - do k = 1,pver - mmr_cond_vap_gasprod(:ncol,k,COND_VAP_H2SO4) = adv_mass(ndx_h2so4) & - * (del_h2so4_gasprod(:ncol,k)+del_h2so4_aqchem(:ncol,k)) / mbar(:ncol,k)/delt - mmr_cond_vap_gasprod(:ncol,k,COND_VAP_ORG_LV) = adv_mass(ndx_soa_lv) & - * del_soa_lv_gasprod(:ncol,k) / mbar(:ncol,k)/delt - mmr_cond_vap_gasprod(:ncol,k,COND_VAP_ORG_SV) = adv_mass(ndx_soa_sv) & - * del_soa_sv_gasprod(:ncol,k) / mbar(:ncol,k)/delt - end do - - ! This should not happen since there are only production terms for these gases! ! - do cond_vap_idx=1,N_COND_VAP - where(mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx).lt. 0.0_r8) - mmr_cond_vap_gasprod(:ncol,:,cond_vap_idx) = 0.0_r8 - end where - end do - mmr_tend_ncols(:ncol,:,ndx_h2so4) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_H2SO4) - mmr_tend_ncols(:ncol,:,ndx_soa_lv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_LV) - mmr_tend_ncols(:ncol,:,ndx_soa_sv) = mmr_cond_vap_start_of_timestep(:ncol,:,COND_VAP_ORG_SV) - - ! Rest of microphysics have pcols dimension - mmr_tend_pcols(:ncol,:,:) = mmr_tend_ncols(:ncol,:,:) - - ! Condensation - ! Note use of "zm" here. In CAM5.3-implementation "zi" was used.. - ! zm is passed through the generic interface, and it should not change much - ! to check if "zm" is below boundary layer height instead of zi - call condtend( lchnk, mmr_tend_pcols, mmr_cond_vap_gasprod,tfld, pmid, & - pdel, delt, ncol, pblh, zm, qh2o) ! cka - - ! Coagulation - ! OS 280415 Concentratiions in cloud water is in vmr space and as a - ! temporary variable (vmrcw) Coagulation between aerosol and cloud - ! droplets moved to after vmrcw is moved into qqcw (in mmr spac) - call coagtend( mmr_tend_pcols, pmid, pdel, tfld, delt_inverse, ncol, lchnk) - - ! Convert cloud water to mmr again ==> values in buffer - call vmr2qqcw( lchnk, vmrcw, mbar, ncol, loffset, pbuf ) - - ! Call cloud coagulation routines (all in mass mixing ratios) - call clcoag( mmr_tend_pcols, pmid, pdel, tfld, cldnum ,cldfr, delt_inverse, ncol, lchnk,loffset,pbuf) - - ! Make sure mmr==> vmr is done correctly - mmr_tend_ncols(:ncol,:,:) = mmr_tend_pcols(:ncol,:,:) - - ! Go back to volume mixing ratio for chemistry - call mmr2vmr( mmr_tend_ncols, vmr, mbar, ncol ) - - end subroutine aero_model_gasaerexch - - !============================================================================= - subroutine aero_model_emissions( state, cam_in ) - - ! Arguments: - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), intent(inout) :: cam_in ! import state - - if (dust_active) then - call oslo_aero_dust_emis( state, cam_in) - ! some dust emis diagnostics ... - endif - - if (seasalt_active) then - call oslo_aero_seasalt_emis(state, cam_in) - endif - - !Pick up correct DMS emissions (replace values from file if requested) - call oslo_aero_dms_emis(state, cam_in) - - end subroutine aero_model_emissions - - !============================================================================= - ! private methods - !============================================================================= - - subroutine qqcw2vmr(lchnk, vmr, mbar, ncol, im, pbuf) - - !----------------------------------------------------------------- - ! ... Xfrom from mass to volume mixing ratio - !----------------------------------------------------------------- - - !----------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------- - integer, intent(in) :: lchnk, ncol, im - real(r8), intent(in) :: mbar(ncol,pver) - real(r8), intent(inout) :: vmr(ncol,pver,gas_pcnst) - type(physics_buffer_desc), pointer :: pbuf(:) - - !----------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------- - integer :: k, m - real(r8), pointer :: fldcw(:,:) - - do m=1,gas_pcnst - if( adv_mass(m) /= 0._r8 ) then - fldcw => qqcw_get_field(pbuf, m+im) - if(associated(fldcw)) then - do k=1,pver - vmr(:ncol,k,m) = mbar(:ncol,k) * fldcw(:ncol,k) / adv_mass(m) - end do - else - vmr(:,:,m) = 0.0_r8 - end if - end if - end do - end subroutine qqcw2vmr - - !============================================================================= - subroutine vmr2qqcw( lchnk, vmr, mbar, ncol, im, pbuf ) - !----------------------------------------------------------------- - ! ... Xfrom from volume to mass mixing ratio - !----------------------------------------------------------------- - - use m_spc_id - - !----------------------------------------------------------------- - ! ... Dummy args - !----------------------------------------------------------------- - integer, intent(in) :: lchnk, ncol, im - real(r8), intent(in) :: mbar(ncol,pver) - real(r8), intent(in) :: vmr(ncol,pver,gas_pcnst) - type(physics_buffer_desc), pointer :: pbuf(:) - - !----------------------------------------------------------------- - ! ... Local variables - !----------------------------------------------------------------- - integer :: k, m - real(r8), pointer :: fldcw(:,:) - !----------------------------------------------------------------- - ! ... The non-group species - !----------------------------------------------------------------- - do m = 1,gas_pcnst - fldcw => qqcw_get_field(pbuf, m+im) - if( adv_mass(m) /= 0._r8 .and. associated(fldcw)) then - do k = 1,pver - fldcw(:ncol,k) = adv_mass(m) * vmr(:ncol,k,m) / mbar(:ncol,k) - end do - end if - end do - end subroutine vmr2qqcw - - !============================================================================= - subroutine aero_model_constants() - ! - ! A number of constants used in the emission and size-calculation in CAM-Oslo Jan 2011. - ! Updated by Alf Kirkev May 2013 - ! Updated by Alf Grini February 2014 - - use oslo_aero_const - use oslo_aero_utils - use oslo_aero_share - - ! local variables - integer :: kcomp,i - real(r8) :: rhob(0:nmodes) !density of background aerosol in mode - real(r8) :: rhorbc !This has to do with fractal dimensions of bc, come back to this!! - real(r8) :: sumnormnk - real(r8) :: totalLogDelta - real(r8) :: logDeltaBin - real(r8) :: logNextEdge - - rhob(:) =-1.0_r8 - volumeToNumber(:) =-1.0_r8 - numberToSurface(:) =-1.0_r8 - - !Prepare modal properties - do i=0, nmodes - - if(getNumberOfTracersInMode(i) .gt. 0)then - - !Approximate density of mode - !density of mode is density of first species in mode - rhob(i) = rhopart(getTracerIndex(i,1,.false.)) - - !REPLACE THE EFACT-VARIABLE WITH THIS!! - volumeToNumber(i) = 1.0_r8 / & - ( DEXP ( 4.5_r8 * ( log(originalSigma(i)) * log(originalSigma(i)) ) ) & - *(4.0_r8/3.0_r8)*pi*(originalNumberMedianRadius(i))**3 ) - - numberToSurface(i) = 4.0_r8*pi*lifeCycleNumberMedianRadius(i)*lifeCycleNumberMedianRadius(i)& - *DEXP(log(lifeCycleSigma(i))*log(lifeCycleSigma(i))) - end if - end do - - !Find radius in edges and midpoints of bin - rBinEdge(1) = rTabMin - totalLogDelta = log(rTabMax/rTabMin) - logDeltaBin = totalLogDelta / nBinsTab - do i=2,nBinsTab+1 - logNextEdge = log(rBinEdge(i-1)) + logDeltaBin - rBinEdge(i) = DEXP(logNextEdge) - rBinMidPoint(i-1) = sqrt(rBinEdge(i)*rBinEdge(i-1)) - end do - - !Calculate the fraction of a mode which goes to aquous chemstry - numberFractionAvailableAqChem(:)=0.0_r8 - do i=1,nbmodes - if(isTracerInMode(i,l_so4_a2))then - numberFractionAvailableAqChem(i) = 1.0_r8 - & - calculateLognormalCDF(rMinAquousChemistry,originalNumberMedianRadius(i), originalSigma(i)) - end if - end do - - !Set the density of the fractal mode ==> we get lesser density - !than the emitted density, so for a given mass emitted, we get - !more number-concentration!! This is a way of simulating that the - !aerosols take up more space - rhorbc = calculateEquivalentDensityOfFractalMode( & - rhopart(l_bc_n), & !emitted density - originalNumberMedianRadius(MODE_IDX_BC_NUC), & !emitted size - 2.5_r8, & !fractal dim - originalNumberMedianRadius(MODE_IDX_BC_EXT_AC), & !diameter of mode - originalSigma(MODE_IDX_BC_EXT_AC)) !sigma mode - - rhopart(l_bc_ax) = rhorbc - !fxm: not the right place for this change of value, - !but anyway.. this re-calculateion of tracer density - !influences density of mode used in coagulation - rhob(MODE_IDX_BC_EXT_AC)=rhorbc - - !Size distribution of the modes! - !Unclear if this should use the radii assuming growth or not! - !Mostly used in code where it is sensible to assume some growth has - !happened, so it is used here - do kcomp = 0,nmodes - do i=1,nBinsTab - !dN/dlogR (does not sum to one over size range) - nk(kcomp,i) = calculatedNdLogR(rBinMidPoint(i), lifeCycleNumberMedianRadius(kcomp), lifeCycleSigma(kcomp)) - - !dN (sums to one) over the size range - normnk(kcomp,i) =logDeltaBin*nk(kcomp,i) - enddo - enddo ! kcomp - - !++test: Normalized size distribution must sum to one (accept 2% error) - do kcomp=0,nmodes - sumNormNk = sum(normnk(kcomp,:)) - if(abs(sum(normnk(kcomp,:)) - 1.0_r8) .gt. 2.0e-2_r8)then - print*, "sum normnk", sum(normnk(kcomp,:)) - stop - endif - enddo - !--test - - !Initialize coagulation - call initializeCoagulationReceivers() - - !Calculate the coagulation coefficients Note: Inaccurate density used! - call initializeCoagulationCoefficients(rhob, lifeCycleNumberMedianRadius) - - call initializeCoagulationOutput() - - end subroutine aero_model_constants - - - subroutine calcaersize_sub( ncol, t, h2ommr, pmid, pdel,wetnumberMedianDiameter,wetrho, & - wetNumberMedianDiameter_processmode, wetrho_processmode) - - ! Seland Calculates mean volume size and hygroscopic growth for use in dry deposition - - use oslo_aero_params, only: nmodes - use oslo_aero_share - - integer, intent(in) :: ncol ! number of columns - real(r8), intent(in) :: t(pcols,pver) ! layer temperatures (K) - real(r8), intent(in) :: h2ommr(pcols,pver) ! layer specific humidity - real(r8), intent(in) :: pmid(pcols,pver) ! layer pressure (Pa) - real(r8), intent(in) :: pdel(pcols,pver) ! layer pressure thickness (Pa) - - real(r8), intent(out):: wetNumberMedianDiameter(pcols,pver,0:nmodes) - real(r8), intent(out):: wetrho(pcols,pver,0:nmodes) ! wet aerosol density - real(r8), intent(out) :: wetNumberMedianDiameter_processmode(pcols,pver,numberOfProcessModeTracers) - real(r8), intent(out) :: wetrho_processmode(pcols,pver,numberOfProcessModeTracers) - - ! local variables - real(r8) :: relhum(pcols,pver) ! Relative humidity - integer :: i,k,m,irelh,mm, tracerCounter - integer :: l ! species index - real(r8) :: xrh(pcols,pver) - real(r8) :: qs(pcols,pver) ! saturation specific humidity - real(r8) :: rmeanvol ! Mean radius with respect to volume - integer :: irh1(pcols,pver),irh2(pcols,pver) - integer :: t_irh1,t_irh2 - real(r8) :: t_rh1,t_rh2,t_xrh,rr1,rr2 - real(r8) :: volumeFractionAerosol !with respect to total (aerosol + water) - real(r8) :: tmp1, tmp2 - real(r8) :: wetrad_tmp(max_tracers_per_mode) - real(r8) :: dry_rhopart_tmp(max_tracers_per_mode) - real(r8) :: mixed_dry_rho - - - !Get the tabulated rh in all grid cells - do k=1,pver - do i=1,ncol - call qsat_water(t(i,k),pmid(i,k), tmp1, qs(i,k), tmp2) - xrh(i,k) = h2ommr(i,k)/qs(i,k) - xrh(i,k) = max(xrh(i,k),0.0_r8) - xrh(i,k) = min(xrh(i,k),1.0_r8) - relhum(i,k)=xrh(i,k) - xrh(i,k)=min(xrh(i,k),rhtab(10)) - end do - end do - - !Find the relh-index in all grid-points - do irelh=1,SIZE(rhtab) - 1 - do k=1,pver - do i=1,ncol - if(xrh(i,k).ge.rhtab(irelh).and. & - xrh(i,k).le.rhtab(irelh+1)) then - irh1(i,k)=irelh !lower index - irh2(i,k)=irelh+1 !higher index - end if - end do - end do - end do - - do k=1,pver - do i=1,ncol - - !Get the indexes out as floating point single numbers - t_irh1 = irh1(i,k) - t_irh2 = irh2(i,k) - t_rh1 = rhtab(t_irh1) - t_rh2 = rhtab(t_irh2) - t_xrh = xrh(i,k) - - do m = 0, nmodes - !Do some weighting to mass mean property - !weighting by 1.5 is number median ==> volumetric mean - !http://dust.ess.uci.edu/facts/psd/psd.pdf - rmeanvol = lifeCycleNumberMedianRadius(m)*DEXP(1.5_r8*(log(lifeCycleSigma(m)))**2) - wetNumberMedianDiameter(i,k,m ) = 0.1e-6_r8 !Initialize to something.. - mixed_dry_rho = 1.e3_r8 - - tracerCounter = 0 - do l = 1,getNumberOfBackgroundTracersInMode(m) - - tracerCounter = tracerCounter + 1 - - !which tracer is this? - mm = getTracerIndex(m,l,.false.) - - !radius of lower rh-bin for this tracer - rr1=rdivr0(t_irh1,mm) - - !radius of upper rh-bin for this tracer - rr2=rdivr0(t_irh2,mm) - - !linear interpolate dry ==> wet radius for this tracer - wetrad_tmp(tracerCounter) = (((t_rh2-t_xrh)*rr1+(t_xrh-t_rh1)*rr2)/ & - (t_rh2-t_rh1))*rmeanvol - - !mixed density of dry particle - dry_rhopart_tmp(tracerCounter) = getDryDensity(m,l) - - end do - - !Find the average growth of this mode - !(still not taking into account how much we have!!) - if(TracerCounter .gt. 0)then - - !Convert to diameter and take average (note: This is MASS median diameter) - wetNumberMedianDiameter(i,k,m) = 2.0_r8 * SUM(wetrad_tmp(1:tracerCounter))/dble(tracerCounter) - - !Take average density - mixed_dry_rho = SUM(dry_rhopart_tmp(1:tracerCounter))/dble(tracerCounter) - - !At this point the radius is in "mass mean" space - volumeFractionAerosol = MIN(1.0_r8, ( 2.0_r8*rmeanVol / wetNumberMedianDiameter(i,k,m) )**3) - - !wet density - wetrho(i,k,m) = mixed_dry_rho * volumeFractionAerosol & - + (1._r8-volumeFractionAerosol)*rhoh2o - - !convert back to number median diameter (wet) - wetNumberMedianDiameter(i,k,m) = wetNumberMedianDiameter(i,k,m)*DEXP(-1.5_r8*(log(lifeCycleSigma(m)))**2) - endif - - - end do !modes - - !Same thing for the process modes - do l=1,numberOfProcessModeTracers - - mm = tracerInProcessMode(l) !process mode tracer (physics space) - - !weighting by 1.5 is number median ==> volumetric mean - !http://dust.ess.uci.edu/facts/psd/psd.pdf - rmeanvol = processModeNumberMedianRadius(l)*DEXP(1.5_r8*(log(processModeSigma(l)))**2) - - !radius of lower rh-bin for this tracer - rr1=rdivr0(t_irh1,mm) - - !radius of upper rh-bin for this tracer - rr2=rdivr0(t_irh2,mm) - - !Note this is MASS median diameter - wetNumberMedianDiameter_processmode(i,k,l) = (((t_rh2-t_xrh)*rr1+(t_xrh-t_rh1)*rr2)/ & - (t_rh2-t_rh1))*rmeanvol*2.0_r8 - - volumeFractionAerosol = MIN(1.0, (2.0_r8*rmeanVol/wetnumberMedianDiameter_processmode(i,k,l))**3) - - wetrho_processmode(i,k,l) = volumeFractionAerosol*rhopart(mm) & - + (1.0_r8 - volumeFractionAerosol)*rhoh2o - - !convert back to number median diameter (wet) - wetNumberMedianDiameter_processMode(i,k,l) = wetNumberMedianDiameter_processMode(i,k,l)*DEXP(-1.5_r8*(log(processModeSigma(l)))**2) - end do !process modes - end do !horizontal points - end do !layers - - end subroutine calcaersize_sub - -end module oslo_aero_model diff --git a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 b/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 deleted file mode 100644 index e4fb4ffb0e..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_ndrop.F90 +++ /dev/null @@ -1,2034 +0,0 @@ -module oslo_aero_ndrop - - !--------------------------------------------------------------------------------- - ! Droplet activation by oslo modal aerosols - ! Compute vertical diffusion and nucleation of cloud droplets - !--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, pverp - use physconst, only: pi, rhoh2o, mwh2o, r_universal, rh2o - use physconst, only: gravit, latvap, cpair, rair - use constituents, only: pcnst, cnst_get_ind, cnst_name, cnst_spec_class_gas, cnst_species_class - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_get_field - use wv_saturation, only: qsat - use phys_control, only: phys_getopts, use_hetfrz_classnuc - use ref_pres, only: top_lev => trop_cloud_top_lev - use shr_spfn_mod, only: erf => shr_spfn_erf - use cam_history, only: addfld, add_default, horiz_only, fieldname_len, outfld - use cam_abortutils, only: endrun - use cam_logfile, only: iulog - ! - use oslo_aero_utils, only: calculateNumberMedianRadius - use oslo_aero_share, only: getNumberOfTracersInMode, getNumberOfAerosolTracers, getTracerIndex - use oslo_aero_share, only: getCloudTracerName, getCloudTracerIndex, getConstituentFraction - use oslo_aero_share, only: fillAerosolTracerList, fillInverseAerosolTracerList - use oslo_aero_params, only: nmodes, nbmodes - use oslo_aero_const, only: smallNumber - - implicit none - private - - ! public routines - public :: ndrop_init_oslo - public :: dropmixnuc_oslo - - ! private routines - private :: explmix_oslo - private :: maxsat_oslo - private :: ccncalc_oslo - private :: activate_modal_oslo - - ! private variables - real(r8) :: t0 ! reference temperature - real(r8) :: aten - real(r8) :: surften ! surface tension of water w/respect to air (N/m) - real(r8) :: alog2, alog3, alogaten - real(r8) :: third, twothird, sixth, zero - real(r8) :: sq2, sqpi - - integer, parameter :: psat=7 ! number of supersaturations to calc ccn concentration - - ! supersaturation (%) to determine ccn concentration - real(r8), parameter :: supersat(psat)= (/ 0.02_r8, 0.05_r8, 0.1_r8, 0.15_r8, 0.2_r8, 0.5_r8, 1.0_r8 /) - - character(len=8) :: ccn_name(psat)= (/'CCN1','CCN2','CCN3','CCN4','CCN5','CCN6','CCN7'/) - - ! indices in state and pbuf structures - integer :: numliq_idx = -1 - integer :: kvh_idx = -1 - - ! description of modal aerosols - integer :: ntot_amode ! number of aerosol modes - integer, allocatable :: nspec_amode(:) ! number of chemical species in each aerosol mode - real(r8), allocatable :: sigmag_amode(:)! geometric standard deviation for each aerosol mode - real(r8), allocatable :: dgnumlo_amode(:) - real(r8), allocatable :: dgnumhi_amode(:) - real(r8), allocatable :: voltonumblo_amode(:) - real(r8), allocatable :: voltonumbhi_amode(:) - - logical :: history_aerosol ! Output the MAM aerosol tendencies - character(len=fieldname_len), allocatable :: fieldname(:) ! names for drop nuc tendency output fields - character(len=fieldname_len), allocatable :: fieldname_cw(:) ! names for drop nuc tendency output fields - - ! local indexing for MAM - integer, allocatable :: mam_idx(:,:) ! table for local indexing of modal aero number and mmr - integer :: ncnst_tot ! total number of mode number conc + mode species - - ! Indices for MAM species in the ptend%q array. Needed for prognostic aerosol case. - integer, allocatable :: mam_cnst_idx(:,:) - - logical :: tendencyCounted(pcnst) = .false. ! set flags true for constituents with non-zero tendencies - integer :: n_aerosol_tracers - integer :: aerosolTracerList(pcnst) !List where indexes 1...n_aerosol_tracers are the indexes in pcnst - !..something like (/ l_so4_a1, l_bc_a, .../)etc - integer :: inverseAerosolTracerList(pcnst) !List where you can back the place in aerosolTracerList if you know the - !tracer index. So in the example above inverseAerosolTracerList(l_so4_a1) = 1 - - ! ptr2d_t is used to create arrays of pointers to 2D fields - type ptr2d_t - real(r8), pointer :: fld(:,:) - end type ptr2d_t - - ! modal aerosols - logical :: prog_modal_aero ! true when modal aerosols are prognostic - logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies - -!=============================================================================== -contains -!=============================================================================== - - subroutine ndrop_init_oslo() - - integer :: ii, l, lptr, m, mm - integer :: nspec_max ! max number of species in a mode - character(len=32) :: tmpname - character(len=32) :: tmpname_cw - character(len=128) :: long_name - character(len=8) :: unit - logical :: history_amwg ! output the variables used by the AMWG diag package - character(len=10) :: modeString - character(len=20) :: varname - !------------------------------------------------------------------------------- - - ! get indices into state%q and pbuf structures - call cnst_get_ind('NUMLIQ', numliq_idx) - - kvh_idx = pbuf_get_index('kvh') - - zero = 0._r8 - third = 1._r8/3._r8 - twothird = 2._r8*third - sixth = 1._r8/6._r8 - sq2 = sqrt(2._r8) - sqpi = sqrt(pi) - - t0 = 273._r8 - surften = 0.076_r8 - aten = 2._r8*mwh2o*surften/(r_universal*t0*rhoh2o) - alogaten = log(aten) - alog2 = log(2._r8) - alog3 = log(3._r8) - - ! get info about the modal aerosols - ! get ntot_amode - ! TODO: make these local variables and don't allocate - ntot_amode = nmodes - allocate( & - nspec_amode(ntot_amode), & - sigmag_amode(ntot_amode), & - dgnumlo_amode(ntot_amode), & - dgnumhi_amode(ntot_amode), & - voltonumblo_amode(ntot_amode), & - voltonumbhi_amode(ntot_amode) ) - - do m = 1,ntot_amode - nspec_amode(m) = getNumberOfTracersInMode(m) - enddo - - ! Init the table for local indexing of mam number conc and mmr. - ! This table uses species index 0 for the number conc. - - ! Find max number of species in all the modes, and the total - ! number of mode number concentrations + mode species - nspec_max = nspec_amode(1) - ncnst_tot = nspec_amode(1) + 1 - do m = 2, ntot_amode - nspec_max = max(nspec_max, nspec_amode(m)) - ncnst_tot = ncnst_tot + nspec_amode(m) + 1 - end do - - allocate(mam_idx(ntot_amode,0:nspec_max)) - allocate(mam_cnst_idx(ntot_amode,0:nspec_max)) - allocate(fieldname(ncnst_tot)) - allocate(fieldname_cw(ncnst_tot)) - - ! Local indexing compresses the mode and number/mass indicies into one index. - ! This indexing is used by the pointer arrays used to reference state and pbuf - ! fields. - ii = 0 - do m = 1, ntot_amode - do l = 0, nspec_amode(m) - ii = ii + 1 - mam_idx(m,l) = ii - end do - end do - - ! Add dropmixnuc tendencies for all modal aerosol species - - call phys_getopts(history_amwg_out = history_amwg, & - history_aerosol_out = history_aerosol, prog_modal_aero_out=prog_modal_aero) - - prog_modal_aero = .TRUE. - n_aerosol_tracers = getNumberOfAerosolTracers() - call fillAerosolTracerList(aerosolTracerList) - call fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) - if (masterproc) then - do ii=1,n_aerosol_tracers - write(iulog,*) "aerosolTracerList", ii, aerosolTracerList(ii), inverseAerosolTracerList(aerosolTracerList(ii)) - end do - end if - - lq(:) = .false. !Initialize - - !Set up tendencies for tracers (output) - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.false.) - - if(.NOT. lq(lptr))then - !add dropmixnuc tendencies - mm=mam_idx(m,l) - fieldname(mm)=trim(cnst_name(lptr))//"_mixnuc1" - fieldname_cw(mm)=trim(getCloudTracerName(lptr))//"_mixnuc1" - - long_name = trim(fieldname(mm)) // ' dropmixnuc column tendency' - call addfld(trim(fieldname(mm)), horiz_only ,'A', "kg/m2/s",long_name) - - long_name = trim(fieldname_cw(mm)) // ' dropmixnuc column tendency' - call addfld(trim(fieldname_cw(mm)), horiz_only, 'A', "kg/m2/s",long_name) - - if (history_aerosol) then - call add_default(trim(fieldname(mm)), 1, ' ') - call add_default(trim(fieldname_cw(mm)),1,' ') - endif - - !Do tendencies of this tracer - lq(lptr)=.TRUE. - endif - enddo - enddo - do m=1,ntot_amode - modeString=" " - write(modeString,"(I2)"),m - if(m .lt. 10) modeString="0"//adjustl(modeString) - varName = "NMR"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', 'm ', 'number median radius mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - - varName = "NCONC"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', '#/m3 ', 'number concentration mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - - varName = "VCONC"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', 'm3/m3 ','volume concentration mode '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - - varName = "SIGMA"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A', '-','Std. dev. mode '//modeString) - - if(history_aerosol)call add_default(varName, 1, ' ') - varName = "HYGRO"//trim(modeString) - call addfld(varName, (/ 'lev' /),'A','-','Hygroscopicity '//modeString) - if(history_aerosol)call add_default(varName, 1, ' ') - end do - call addfld('CCN1',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.02%') - call addfld('CCN2',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.05%') - call addfld('CCN3',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.1%') - call addfld('CCN4',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.15%') - call addfld('CCN5',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.2%') - call addfld('CCN6',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=0.5%') - call addfld('CCN7',(/ 'lev' /), 'A','#/cm3','CCN concentration at S=1.0%') - - if(history_aerosol)then - do l = 1, psat - call add_default(ccn_name(l), 1, ' ') - enddo - end if - - call addfld('WTKE', (/ 'lev' /), 'A', 'm/s', 'Standard deviation of updraft velocity') - call addfld('NDROPMIX', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number mixing') - call addfld('NDROPSRC', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number source') - call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics') - call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number') - - end subroutine ndrop_init_oslo - - !=============================================================================== - - subroutine dropmixnuc_oslo( state, ptend, dtmicro, pbuf, wsub, & - cldn, cldo, cldliqf, hasAerosol, CProcessModes, f_c, f_bc, f_aq, f_so4_cond, & - f_soa, cam, f_acm, f_bcm, f_aqm, f_so4_condm, f_soam, & - numberConcentration, volumeConcentration, hygroscopicity, lnsigma, tendnd, fn_in) - - ! vertical diffusion and nucleation of cloud droplets - ! assume cloud presence controlled by cloud fraction - ! doesn't distinguish between warm, cold clouds - - ! arguments - type(physics_state), target, intent(in) :: state - type(physics_ptend), intent(out) :: ptend - real(r8), intent(in) :: dtmicro ! time step for microphysics (s) - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: wsub(pcols,pver) ! subgrid vertical velocity - real(r8), intent(in) :: cldn(pcols,pver) ! cloud fraction - real(r8), intent(in) :: cldo(pcols,pver) ! cloud fraction on previous time step - real(r8), intent(in) :: cldliqf(pcols,pver) ! liquid cloud fraction (liquid / (liquid + ice)) - logical , intent(in) :: hasAerosol(pcols, pver, nmodes) - real(r8), intent(in) :: CProcessModes(pcols,pver) - real(r8), intent(in) :: f_c(pcols,pver) - real(r8), intent(in) :: f_bc(pcols,pver) - real(r8), intent(in) :: f_aq(pcols,pver) - real(r8), intent(in) :: f_so4_cond(pcols,pver) - real(r8), intent(in) :: f_soa(pcols,pver) - real(r8), intent(in) :: cam(pcols,pver,nbmodes) - real(r8), intent(in) :: f_acm(pcols,pver, nbmodes) - real(r8), intent(in) :: f_bcm(pcols,pver, nbmodes) - real(r8), intent(in) :: f_aqm(pcols, pver, nbmodes) - real(r8), intent(in) :: f_so4_condm(pcols, pver, nbmodes) !Needed in "get component fraction - real(r8), intent(in) :: f_soam(pcols,pver,nbmodes) - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentraiton - real(r8), intent(in) :: volumeConcentration(pcols,pver,nmodes) ![m3/m3] volume concentration - real(r8), intent(in) :: hygroscopicity(pcols,pver,nmodes) ![-] hygroscopicity - real(r8), intent(in) :: lnsigma(pcols,pver,nmodes) ![-] log(base e) sigma - real(r8), intent(out) :: tendnd(pcols,pver) ! change in droplet number concentration (#/kg/s) - - ! Local variables - integer :: lchnk ! chunk identifier - integer :: ncol ! number of columns - real(r8), pointer :: ncldwtr(:,:) ! droplet number concentration (#/kg) - real(r8), pointer :: temp(:,:) ! temperature (K) - real(r8), pointer :: omega(:,:) ! vertical velocity (Pa/s) - real(r8), pointer :: pmid(:,:) ! mid-level pressure (Pa) - real(r8), pointer :: pint(:,:) ! pressure at layer interfaces (Pa) - real(r8), pointer :: pdel(:,:) ! pressure thickess of layer (Pa) - real(r8), pointer :: rpdel(:,:) ! inverse of pressure thickess of layer (/Pa) - real(r8), pointer :: zm(:,:) ! geopotential height of level (m) - real(r8), pointer :: kvh(:,:) ! vertical diffusivity (m2/s) - type(ptr2d_t), allocatable :: raer(:) ! aerosol mass, number mixing ratios - type(ptr2d_t), allocatable :: qqcw(:) - real(r8) :: raertend(pver) ! tendency of aerosol mass, number mixing ratios - real(r8) :: qqcwtend(pver) ! tendency of cloudborne aerosol mass, number mixing ratios - - real(r8), parameter :: zkmin = 0.01_r8, zkmax = 100._r8 - real(r8), parameter :: wmixmin = 0.1_r8 ! minimum turbulence vertical velocity (m/s) - real(r8) :: sq2pi - - integer :: i, k, l, m, mm, n - integer :: km1, kp1 - integer :: nnew, nsav, ntemp - integer :: lptr - integer :: nsubmix, nsubmix_bnd - integer, save :: count_submix(100) - integer :: phase ! phase of aerosol - - real(r8) :: arg - real(r8) :: dtinv - real(r8) :: dtmin, tinv, dtt - real(r8) :: lcldn(pcols,pver) - real(r8) :: lcldo(pcols,pver) - - real(r8) :: zs(pver) ! inverse of distance between levels (m) - real(r8) :: qcld(pver) ! cloud droplet number mixing ratio (#/kg) - real(r8) :: qncld(pver) ! droplet number nucleated on cloud boundaries - real(r8) :: srcn(pver) ! droplet source rate (/s) - real(r8) :: cs(pcols,pver) ! air density (kg/m3) - real(r8) :: csbot(pver) ! air density at bottom (interface) of layer (kg/m3) - real(r8) :: csbot_cscen(pver) ! csbot(i)/cs(i,k) - real(r8) :: dz(pcols,pver) ! geometric thickness of layers (m) - - real(r8) :: wtke(pcols,pver) ! turbulent vertical velocity at base of layer k (m/s) - real(r8) :: wtke_cen(pcols,pver) ! turbulent vertical velocity at center of layer k (m/s) - real(r8) :: wbar, wmix, wmin, wmax - - real(r8) :: zn(pver) ! g/pdel (m2/g) for layer - real(r8) :: flxconv ! convergence of flux into lowest layer - - real(r8) :: wdiab ! diabatic vertical velocity - real(r8) :: ekd(pver) ! diffusivity for droplets (m2/s) - real(r8) :: ekk(0:pver) ! density*diffusivity for droplets (kg/m3 m2/s) - real(r8) :: ekkp(pver) ! zn*zs*density*diffusivity - real(r8) :: ekkm(pver) ! zn*zs*density*diffusivity - - real(r8) :: dum, dumc - real(r8) :: tmpa - real(r8) :: dact - real(r8) :: fluxntot ! (#/cm2/s) - real(r8) :: dtmix - real(r8) :: alogarg - real(r8) :: overlapp(pver), overlapm(pver) ! cloud overlap - - real(r8) :: nsource(pcols,pver) ! droplet number source (#/kg/s) - real(r8) :: ndropmix(pcols,pver) ! droplet number mixing (#/kg/s) - real(r8) :: ndropcol(pcols) ! column droplet number (#/m2) - real(r8) :: cldo_tmp, cldn_tmp - real(r8) :: tau_cld_regenerate - real(r8) :: zeroaer(pver) - real(r8) :: taumix_internal_pver_inv ! 1/(internal mixing time scale for k=pver) (1/s) - - real(r8), allocatable :: nact(:,:) ! fractional aero. number activation rate (/s) - real(r8), allocatable :: mact(:,:) ! fractional aero. mass activation rate (/s) - - real(r8), allocatable :: raercol(:,:,:) ! single column of aerosol mass, number mixing ratios - real(r8), allocatable :: raercol_cw(:,:,:) ! same as raercol but for cloud-borne phase - - !to avoid excessive calls to boundary layer scheme - real(r8), allocatable :: raercol_tracer(:,:,:) - real(r8), allocatable :: raercol_cw_tracer(:,:,:) - real(r8), allocatable :: mact_tracer(:,:) - real(r8), allocatable :: mfullact_tracer(:,:) - - real(r8) :: na(pcols), va(pcols), hy(pcols) - real(r8), allocatable :: naermod(:) ! (1/m3) - real(r8), allocatable :: hygro(:) ! hygroscopicity of aerosol mode - real(r8), allocatable :: vaerosol(:) ! interstit+activated aerosol volume conc (cm3/cm3) - - real(r8) :: source(pver) - - real(r8), allocatable :: fn(:) ! activation fraction for aerosol number - real(r8), intent(out) :: fn_in(pcols,pver,0:nmodes) - real(r8), allocatable :: fm(:) ! activation fraction for aerosol mass - - real(r8), allocatable :: fluxn(:) ! number activation fraction flux (cm/s) - real(r8), allocatable :: fluxm(:) ! mass activation fraction flux (cm/s) - real(r8) :: flux_fullact(pver) ! 100% activation fraction flux (cm/s) - ! note: activation fraction fluxes are defined as - ! fluxn = [flux of activated aero. number into cloud (#/cm2/s)] - ! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] - - real(r8), allocatable :: coltend(:,:) ! column tendency for diagnostic output - real(r8), allocatable :: coltend_cw(:,:) ! column tendency - real(r8) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat - - !for gas species turbulent mixing - real(r8), pointer :: rgas(:, :, :) - real(r8), allocatable :: rgascol(:, :, :) - real(r8), allocatable :: coltendgas(:) - real(r8) :: zerogas(pver) - character*200 :: fieldnamegas - - real(r8) :: numberMedianRadius(pcols,pver,nmodes) - real(r8) :: sigma(pcols,pver,nmodes) ![-] sigma - real(r8) :: constituentFraction - real(r8) :: volumeCore(pcols,pver,nmodes) - real(r8) :: volumeCoat(pcols,pver,nmodes) - integer :: tracerIndex - integer :: cloudTracerIndex - integer :: kcomp - integer :: speciesMap(nmodes) - real(r8), allocatable :: fn_tmp(:), fm_tmp(:) - real(r8), allocatable :: fluxn_tmp(:), fluxm_tmp(:) - real(r8) :: componentFraction - real(r8) :: componentFractionOK(pver,nmodes,pcnst) - real(r8) :: sumFraction - logical :: alert - real(r8), dimension(pver, pcnst) :: massBalance - real(r8), dimension(pver, pcnst) :: newMass - real(r8), dimension(pver,pcnst) :: newCloud, oldCloud, newAerosol, oldAerosol, deltaCloud - integer :: kCrit, lptr2 - logical :: stopMe - integer :: iDebug=1, lDebug=15 - real(r8) :: mixRatioToMass - real(r8),dimension(pcnst) :: debugSumFraction - real(r8), allocatable :: lnsigman(:) - character(len=2) :: modeString - character(len=20) :: varname - integer :: numberOfModes - !------------------------------------------------------------------------------- - - sq2pi = sqrt(2._r8*pi) - - lchnk = state%lchnk - ncol = state%ncol - - ncldwtr => state%q(:,:,numliq_idx) - temp => state%t - omega => state%omega - pmid => state%pmid - pint => state%pint - pdel => state%pdel - rpdel => state%rpdel - zm => state%zm - - call pbuf_get_field(pbuf, kvh_idx, kvh) - - ! Create the liquid weighted cloud fractions that were passsed in - ! before. This doesn't seem like the best variable, since the cloud could - ! have liquid condensate, but the part of it that is changing could be the - ! ice portion; however, this is what was done before. - lcldo(:ncol,:) = cldo(:ncol,:) * cldliqf(:ncol,:) - lcldn(:ncol,:) = cldn(:ncol,:) * cldliqf(:ncol,:) - - arg = 1.0_r8 - if (abs(0.8427_r8 - erf(arg))/0.8427_r8 > 0.001_r8) then - write(iulog,*) 'erf(1.0) = ',ERF(arg) - call endrun('dropmixnuc: Error function error') - endif - arg = 0.0_r8 - if (erf(arg) /= 0.0_r8) then - write(iulog,*) 'erf(0.0) = ',erf(arg) - write(iulog,*) 'dropmixnuc: Error function error' - call endrun('dropmixnuc: Error function error') - endif - - dtinv = 1._r8/dtmicro - - allocate( & - nact(pver,ntot_amode), & - mact(pver,ntot_amode), & - raer(ncnst_tot), & - qqcw(ncnst_tot), & - raercol(pver,ncnst_tot,2), & - raercol_cw(pver,ncnst_tot,2), & - coltend(pcols,ncnst_tot), & - coltend_cw(pcols,ncnst_tot), & - naermod(ntot_amode), & - hygro(ntot_amode), & - lnsigman(ntot_amode), & !variable std. deviation (CAM-Oslo) - raercol_tracer(pver,n_aerosol_tracers,2), & - raercol_cw_tracer(pver,n_aerosol_tracers,2), & - mact_tracer(pver,n_aerosol_tracers), & - mfullact_tracer(pver,n_aerosol_tracers), & - vaerosol(ntot_amode), & - fn(ntot_amode), & - fm(ntot_amode), & - fluxn(ntot_amode), & - fluxm(ntot_amode) ) - - ! Init pointers to mode number and specie mass mixing ratios in - ! intersitial and cloud borne phases. - ! Need a list of all aerosol species ==> store in raer (mm) - ! or qqcw for cloud-borne aerosols (?) - do m=1,nmodes !All aerosol modes - - !NOTE: SEVERAL POINTERS POINT TO SAME FIELD, E.G. CONDENSATE WHICH IS IN SEVERAL MODES - do l = 1, nspec_amode(m) - tracerIndex = getTracerIndex(m,l,.false.) !Index in q - cloudTracerIndex = getCloudTracerIndex(m,l) !Index in phys-buffer - mm = mam_idx(m,l) !Index in raer/qqcw - raer(mm)%fld => state%q(:,:,tracerIndex) !NOTE: These are total fields (for example condensate) - call pbuf_get_field(pbuf, CloudTracerIndex, qqcw(mm)%fld) !NOTE: These are total fields (for example condensate) - enddo - enddo - allocate( & - fn_tmp(ntot_amode), & - fm_tmp(ntot_amode), & - fluxn_tmp(ntot_amode), & - fluxm_tmp(ntot_amode) ) - - wtke = 0._r8 - - if (prog_modal_aero) then - ! aerosol tendencies - call physics_ptend_init(ptend, state%psetcols, 'ndrop', lq=lq) - else - ! no aerosol tendencies - call physics_ptend_init(ptend, state%psetcols, 'ndrop') - end if - - !Improve this later by using only cloud points ? - do k = top_lev, pver - do i=1,ncol - cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) - end do - end do - - !Output this - call calculateNumberMedianRadius(numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) - do n=1,nmodes - sigma(:ncol,:,n) = DEXP(lnSigma(:ncol,:,n)) - modeString=" " - write(modeString,"(I2)"),n - if(n .lt. 10) modeString="0"//adjustl(modeString) - varName = "NMR"//trim(modeString) - call outfld(varName, numberMedianRadius(:,:,n), pcols, lchnk) - varName = "NCONC"//trim(modeString) - call outfld(varName, numberConcentration(:,:,n),pcols, lchnk) - varName = "VCONC"//trim(modeString) - call outfld(varName, volumeConcentration(:,:,n), pcols,lchnk) - varName = "SIGMA"//trim(modeString) - call outfld(varName, sigma(:,:,n), pcols,lchnk) - varName = "HYGRO"//trim(modeString) - call outfld(varName, hygroscopicity(:,:,n), pcols,lchnk) - end do - - alert = .FALSE. - do k=top_lev,pver - mm = k - top_lev + 1 - do m=1,nmodes - if(.NOT. alert .and. & - ANY(numberConcentration(:ncol,k,m) .lt. 0.0_r8 ))then - alert = .TRUE. - lptr = k - print*,"STRANGE numberconc", m, minval(numberConcentration(:,:,:))*1.e-6_r8, "#/cm3", k, mm - endif - enddo - enddo - if (alert)then - print*,"strange stuff here " - call endrun() - endif - - ! overall_main_i_loop - do i = 1, ncol - - coltend(i,:)=0.0_r8 - coltend_cw(i,:) = 0.0_r8 - - do k = top_lev, pver-1 - zs(k) = 1._r8/(zm(i,k) - zm(i,k+1)) - end do - zs(pver) = zs(pver-1) - - ! load number nucleated into qcld on cloud boundaries - do k = top_lev, pver - - qcld(k) = ncldwtr(i,k) - qncld(k) = 0._r8 - srcn(k) = 0._r8 - cs(i,k) = pmid(i,k)/(rair*temp(i,k)) ! air density (kg/m3) - dz(i,k) = 1._r8/(cs(i,k)*gravit*rpdel(i,k)) ! layer thickness in m - - do m = 1, ntot_amode - nact(k,m) = 0._r8 - mact(k,m) = 0._r8 - end do - - zn(k) = gravit*rpdel(i,k) - - if (k < pver) then - ekd(k) = kvh(i,k+1) - ekd(k) = max(ekd(k), zkmin) - ekd(k) = min(ekd(k), zkmax) - csbot(k) = 2.0_r8*pint(i,k+1)/(rair*(temp(i,k) + temp(i,k+1))) - csbot_cscen(k) = csbot(k)/cs(i,k) - else - ekd(k) = 0._r8 - csbot(k) = cs(i,k) - csbot_cscen(k) = 1.0_r8 - end if - - ! rce-comment - define wtke at layer centers for new-cloud activation - ! and at layer boundaries for old-cloud activation - wtke_cen(i,k) = wsub(i,k) - wtke(i,k) = wsub(i,k) - wtke_cen(i,k) = max(wtke_cen(i,k), wmixmin) - wtke(i,k) = max(wtke(i,k), wmixmin) - nsource(i,k) = 0._r8 - - end do ! k - - nsav = 1 - nnew = 2 - - !get constituent fraction - componentFractionOK(:,:,:) = 0.0_r8 - do k=top_lev, pver - do m = 1,ntot_amode - if(m .le. nbmodes)then - do l = 1, nspec_amode(m) - !calculate fraction of component "l" in mode "m" based on concentrations in clear air - componentFractionOK(k,m,getTracerIndex(m,l,.false.)) & - = getConstituentFraction(CProcessModes(i,k), & - f_c(i,k), f_bc(i,k), f_aq(i,k), f_so4_cond(i,k), f_soa(i,k), & - Cam(i,k,m), f_acm(i,k,m), f_bcm(i,k,m), f_aqm(i,k,m), & - f_so4_condm(i,k,m), f_soam(i,k,m), getTracerIndex(m,l,.false.) ) - end do - else - do l = 1, nspec_amode(m) - componentFractionOK(k,m,getTracerIndex(m,l,.false.)) = 1.0_r8 - end do - endif - end do - - !Loop over all tracers ==> check that sums to one - !for all tracers which exist in the oslo-modes - do l=1,pcnst - sumFraction = 0.0_r8 - do m=1,ntot_amode - sumFraction = sumFraction + componentFractionOK(k,m,l) - end do - if(sumFraction .gt. 1.e-2_r8)then !Just scale what comes out if componentFraction is larger than 1% - do m=1,ntot_amode - componentFractionOK(k,m,l) = & - componentFractionOK(k,m,l)/sumFraction - end do - else !negative or zero fraction for this species - !distribute equal fraction to all receiver modes - sumFraction = 0.0_r8 - do m=1,ntot_amode - do lptr=1,getNumberOfTracersInMode(m) - if(getTracerIndex(m,lptr,.FALSE.) .eq. l ) then - sumFraction = sumFraction + 1.0_r8 - endif - end do ! tracers in mode - end do ! mode - do m=1,ntot_amode - componentFractionOK(k,m,l)=1.0_r8/max(1.e-30_r8, sumFraction) - end do !modes - endif - end do !tracers - end do !levels - !debug sum fraction for "i" done - - debugSumFraction(:) = 0.0_r8 !sum of component lDebug in level k - do m = 1, nmodes ! Number of modes - !Get number concentration of this mode - mm =mam_idx(m,0) - do k= top_lev,pver - raercol(k,mm,nsav) = numberConcentration(i,k,m)/cs(i,k) !#/kg air - !In oslo model, number concentrations are diagnostics, so - !Approximate number concentration in each mode by total - !cloud number concentration scaled by how much is available of - !each mode - raercol_cw(k,mm,nsav) = ncldwtr(i,k)*numberConcentration(i,k,m)& - /max(1.e-30_r8, sum(numberConcentration(i,k,1:nmodes))) - enddo - - !These are the mass mixing ratios - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) !index of tracer (all unique) - raercol(:,mm,nsav) = 0.0_r8 - raercol_cw(:,mm,nsav) = 0.0_r8 - !Several of the fields (raer(mm)%fld point to the same - !field in q. To avoid double counting, we take into - !account the component fraction in the mode - do k=top_lev,pver - if(m .gt. nbmodes) then - componentFraction = 1.0_r8 - else - componentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.)) - endif - !Assign to the components used here i.e. distribute condensate/coagulate to modes - raercol_cw(k,mm,nsav) = qqcw(mm)%fld(i,k)*componentFraction - raercol(k,mm,nsav) = raer(mm)%fld(i,k)*componentFraction - enddo ! k (levels) - end do ! l (species) - end do ! m (modes) - - ! droplet nucleation/aerosol activation - - ! tau_cld_regenerate = time scale for regeneration of cloudy air - ! by (horizontal) exchange with clear air - tau_cld_regenerate = 3600.0_r8 * 3.0_r8 - - ! k-loop for growing/shrinking cloud calcs ............................. - ! grow_shrink_main_k_loop: & - do k = top_lev, pver - - ! This code was designed for liquid clouds, but the cloudbourne - ! aerosol can be either from liquid or ice clouds. For the ice clouds, - ! we do not do regeneration, but as cloud fraction decreases the - ! aerosols should be returned interstitial. The lack of a liquid cloud - ! should not mean that all of the aerosol is realease. Therefor a - ! section has been added for shrinking ice clouds and checks were added - ! to protect ice cloudbourne aerosols from being released when no - ! liquid cloud is present. - - ! shrinking ice cloud ...................................................... - cldo_tmp = cldo(i,k) * (1._r8 - cldliqf(i,k)) - cldn_tmp = cldn(i,k) * (1._r8 - cldliqf(i,k)) - - if (cldn_tmp < cldo_tmp) then - - ! convert activated aerosol to interstitial in decaying cloud - - dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * (1._r8 - cldliqf(i,k)) - do m = 1, ntot_amode - mm = mam_idx(m,0) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - end do - end do - end if - - ! shrinking liquid cloud ...................................................... - ! treat the reduction of cloud fraction from when cldn(i,k) < cldo(i,k) - ! and also dissipate the portion of the cloud that will be regenerated - cldo_tmp = lcldo(i,k) - cldn_tmp = lcldn(i,k) * exp( -dtmicro/tau_cld_regenerate ) - ! alternate formulation - ! cldn_tmp = cldn(i,k) * max( 0.0_r8, (1.0_r8-dtmicro/tau_cld_regenerate) ) - - ! fraction is also provided. - if (cldn_tmp < cldo_tmp) then - ! droplet loss in decaying cloud - nsource(i,k) = nsource(i,k) + qcld(k)*(cldn_tmp - cldo_tmp)/cldo_tmp*cldliqf(i,k)*dtinv - qcld(k) = qcld(k)*(1._r8 + (cldn_tmp - cldo_tmp)/cldo_tmp) - - ! convert activated aerosol to interstitial in decaying cloud - dumc = (cldn_tmp - cldo_tmp)/cldo_tmp * cldliqf(i,k) - do m = 1, ntot_amode - mm = mam_idx(m,0) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - dact = raercol_cw(k,mm,nsav)*dumc - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - end do - end do - end if - - ! growing liquid cloud ...................................................... - ! treat the increase of cloud fraction from when cldn(i,k) > cldo(i,k) - ! and also regenerate part of the cloud - cldo_tmp = cldn_tmp - cldn_tmp = lcldn(i,k) - - if (cldn_tmp-cldo_tmp > 0.01_r8) then - - ! use wtke at layer centers for new-cloud activation - wbar = wtke_cen(i,k) - wmix = 0._r8 - wmin = 0._r8 - wmax = 10._r8 - wdiab = 0._r8 - - ! load aerosol properties, assuming external mixtures - naermod(:) = 0.0_r8 - vaerosol(:) = 0.0_r8 - hygro(:) = 0.0_r8 - lnsigman(:) = log(2.0_r8) - - m = 0 - do kcomp = 1,nmodes - if(hasAerosol(i,k,kcomp)) then - m = m + 1 - naermod(m) = numberConcentration(i,k,kcomp) - vaerosol(m) = volumeConcentration(i,k,kcomp) - hygro(m) = hygroscopicity(i,k,kcomp) - lnsigman(m) = lnsigma(i,k,kcomp) - speciesMap(m) = kcomp - end if - end do - numberOfModes = m - - ! Call the activation procedure - if (numberOfModes .gt. 0)then - if (use_hetfrz_classnuc) then - call activate_modal_oslo( wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes, & - vaerosol, hygro, fn_in(i,k,1:nmodes), fm, fluxn, & - fluxm, flux_fullact(k), lnsigman) - else - call activate_modal_oslo( wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes, & - vaerosol, hygro, fn, fm, fluxn, & - fluxm, flux_fullact(k), lnsigman) - end if - endif - - dumc = (cldn_tmp - cldo_tmp) - - if (use_hetfrz_classnuc) then - fn_tmp(:) = fn_in(i,k,1:nmodes) - else - fn_tmp(:) = fn(:) - end if - fm_tmp(:) = fm(:) - fluxn_tmp(:) = fluxn(:) - fluxm_tmp(:) = fluxm(:) - fn(:) = 0.0_r8 - fn_in(i,k,:) = 0.0_r8 - fm(:) = 0.0_r8 - fluxn(:)=0.0_r8 - fluxm(:)= 0.0_r8 - do m = 1, numberOfModes !Number of coexisting modes to be used for activation - kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) - if (use_hetfrz_classnuc) then - fn_in(i,k,kcomp) = fn_tmp(m) - else - fn(kcomp) = fn_tmp(m) - end if - fm(kcomp) = fm_tmp(m) - fluxn(kcomp) = fluxn_tmp(m) - fluxm(kcomp) = fluxm_tmp(m) - enddo - do m = 1, ntot_amode - mm = mam_idx(m,0) - if (use_hetfrz_classnuc) then - dact = dumc*fn_in(i,k,m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} - else - dact = dumc*fn(m)*numberConcentration(i,k,m)/cs(i,k) !#/kg_{air} - end if - qcld(k) = qcld(k) + dact - nsource(i,k) = nsource(i,k) + dact*dtinv - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - dum = dumc*fm(m) - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - if(m .gt. nbmodes)then - constituentFraction = 1.0_r8 - else - constituentFraction = componentFractionOK(k,m,getTracerIndex(m,l,.false.) ) - endif - - dact = dum*raer(mm)%fld(i,k)*constituentFraction - raercol_cw(k,mm,nsav) = raercol_cw(k,mm,nsav) + dact ! cloud-borne aerosol - raercol(k,mm,nsav) = raercol(k,mm,nsav) - dact - enddo - enddo - endif ! cldn_tmp-cldo_tmp > 0.01_r8 - - enddo ! grow_shrink_main_k_loop - ! end of k-loop for growing/shrinking cloud calcs ...................... - - ! ...................................................................... - ! start of k-loop for calc of old cloud activation tendencies .......... - ! - ! use current cloud fraction (cldn) exclusively - ! consider case of cldo(:)=0, cldn(k)=1, cldn(k+1)=0 - ! previous code (which used cldo below here) would have no cloud-base activation - ! into layer k. however, activated particles in k mix out to k+1, - ! so they are incorrectly depleted with no replacement - - ! old_cloud_main_k_loop - do k = top_lev, pver - kp1 = min0(k+1, pver) - taumix_internal_pver_inv = 0.0_r8 - - if (lcldn(i,k) > 0.01_r8) then - - wdiab = 0._r8 - wmix = 0._r8 ! single updraft - wbar = wtke(i,k) ! single updraft - if (k == pver) wbar = wtke_cen(i,k) ! single updraft - wmax = 10._r8 - wmin = 0._r8 - - if (lcldn(i,k) - lcldn(i,kp1) > 0.01_r8 .or. k == pver) then - - ! cloud base - - ! ekd(k) = wtke(i,k)*dz(i,k)/sq2pi - ! rce-comments - ! first, should probably have 1/zs(k) here rather than dz(i,k) because - ! the turbulent flux is proportional to ekd(k)*zs(k), - ! while the dz(i,k) is used to get flux divergences - ! and mixing ratio tendency/change - ! second and more importantly, using a single updraft velocity here - ! means having monodisperse turbulent updraft and downdrafts. - ! The sq2pi factor assumes a normal draft spectrum. - ! The fluxn/fluxm from activate must be consistent with the - ! fluxes calculated in explmix. - ekd(k) = wbar/zs(k) - - alogarg = max(1.e-20_r8, 1._r8/lcldn(i,k) - 1._r8) - wmin = wbar + wmix*0.25_r8*sq2pi*log(alogarg) - phase = 1 ! interstitial - naermod(:) = 0.0_r8 - vaerosol(:) = 0.0_r8 - hygro(:) = 0.0_r8 - lnsigman(:) = log(2.0_r8) - - m=0 - do kcomp = 1,nmodes - if(hasAerosol(i,kp1,kcomp) .eqv. .TRUE.)then - m = m + 1 - naermod(m) = numberConcentration(i,kp1,kcomp) - vaerosol(m) = volumeConcentration(i,kp1,kcomp) - hygro(m) = hygroscopicity(i,kp1,kcomp) - lnsigman(m) = lnsigma(i,kp1,kcomp) - speciesMap(m) = kcomp - end if - end do - numberOfModes = m - if(numberOfModes .gt. 0)then - if (use_hetfrz_classnuc) then - call activate_modal_oslo(wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn_in(i,k,:), fm, fluxn, & - fluxm, flux_fullact(k), lnsigman) - else - call activate_modal_oslo(wbar, wmix, wdiab, wmin, wmax, & - temp(i,k), cs(i,k), naermod, numberOfModes , & - vaerosol, hygro, fn, fm, fluxn, & - fluxm, flux_fullact(k), lnsigman) - end if - endif - - !Difference in cloud fraction this layer and above! - !we are here because there are more clouds above, and some - !aerosols go into that layer! ==> calculate additional cloud fraction - if (k < pver) then - dumc = lcldn(i,k) - lcldn(i,kp1) - else - dumc = lcldn(i,k) - endif - - if (use_hetfrz_classnuc) then - fn_tmp(:) = fn_in(i,k,1:nmodes) - else - fn_tmp(:) = fn(:) - end if - fm_tmp(:) = fm(:) - fluxn_tmp(:) = fluxn(:) - fluxm_tmp(:) = fluxm(:) - fn(:) = 0.0_r8 - fn_in(i,k,:) = 0.0_r8 - fm(:) = 0.0_r8 - fluxn(:)=0.0_r8 - fluxm(:)= 0.0_r8 - do m = 1, numberOfModes !Number of coexisting modes to be used for activation - kcomp = speciesMap(m) !This is the CAM-oslo mode (modes 1-14 may be activated, mode 0 not) - if (use_hetfrz_classnuc) then - fn_in(i,k,kcomp) = fn_tmp(m) - else - fn(kcomp) = fn_tmp(m) - end if - fm(kcomp) = fm_tmp(m) - fluxn(kcomp) = fluxn_tmp(m) - fluxm(kcomp) = fluxm_tmp(m) - enddo - - fluxntot = 0.0_r8 - - ! flux of activated mass into layer k (in kg/m2/s) - ! = "actmassflux" = dumc*fluxm*raercol(kp1,lmass)*csbot(k) - ! source of activated mass (in kg/kg/s) = flux divergence - ! = actmassflux/(cs(i,k)*dz(i,k)) - ! so need factor of csbot_cscen = csbot(k)/cs(i,k) - ! dum=1./(dz(i,k)) - dum=csbot_cscen(k)/(dz(i,k)) - - ! code for k=pver was changed to use the following conceptual model - ! in k=pver, there can be no cloud-base activation unless one considers - ! a scenario such as the layer being partially cloudy, - ! with clear air at bottom and cloudy air at top - ! assume this scenario, and that the clear/cloudy portions mix with - ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) - ! in the absence of other sources/sinks, qact (the activated particle - ! mixratio) attains a steady state value given by - ! qact_ss = fcloud*fact*qtot - ! where fcloud is cloud fraction, fact is activation fraction, - ! qtot=qact+qint, qint is interstitial particle mixratio - ! the activation rate (from mixing within the layer) can now be - ! written as - ! d(qact)/dt = (qact_ss - qact)/taumix_internal - ! = qtot*(fcloud*fact*wtke/dz) - qact*(wtke/dz) - ! note that (fcloud*fact*wtke/dz) is equal to the nact/mact - ! also, d(qact)/dt can be negative. in the code below - ! it is forced to be >= 0 - ! - ! steve -- - ! you will likely want to change this. i did not really understand - ! what was previously being done in k=pver - ! in the cam3_5_3 code, wtke(i,pver) appears to be equal to the - ! droplet deposition velocity which is quite small - ! in the cam3_5_37 version, wtke is done differently and is much - ! larger in k=pver, so the activation is stronger there - ! - if (k == pver) then - taumix_internal_pver_inv = flux_fullact(k)/dz(i,k) - end if - - do m = 1, ntot_amode - mm = mam_idx(m,0) - fluxn(m) = fluxn(m)*dumc - fluxm(m) = fluxm(m)*dumc - nact(k,m) = nact(k,m) + fluxn(m)*dum - mact(k,m) = mact(k,m) + fluxm(m)*dum - if (k < pver) then - ! note that kp1 is used here - fluxntot = fluxntot & - + fluxn(m)*raercol(kp1,mm,nsav)*cs(i,k) - else - tmpa = raercol(kp1,mm,nsav)*fluxn(m) & - + raercol_cw(kp1,mm,nsav)*(fluxn(m) & - - taumix_internal_pver_inv*dz(i,k)) - fluxntot = fluxntot + max(0.0_r8, tmpa)*cs(i,k) - end if - end do - srcn(k) = srcn(k) + fluxntot/(cs(i,k)*dz(i,k)) - nsource(i,k) = nsource(i,k) + fluxntot/(cs(i,k)*dz(i,k)) - endif ! (cldn(i,k) - cldn(i,kp1) > 0.01 .or. k == pver) - - else ! i.e: cldn(i,k) < 0.01_r8 - - ! no liquid cloud - nsource(i,k) = nsource(i,k) - qcld(k)*dtinv - qcld(k) = 0.0_r8 - - if (cldn(i,k) < 0.01_r8) then - ! no ice cloud either - - ! convert activated aerosol to interstitial in decaying cloud - - do m = 1, ntot_amode - mm = mam_idx(m,0) - raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol - raercol_cw(k,mm,nsav) = 0._r8 - - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - raercol(k,mm,nsav) = raercol(k,mm,nsav) + raercol_cw(k,mm,nsav) ! cloud-borne aerosol - raercol_cw(k,mm,nsav) = 0._r8 - end do - end do - end if - end if - - end do ! old_cloud_main_k_loop - - ! switch nsav, nnew so that nnew is the updated aerosol - ntemp = nsav - nsav = nnew - nnew = ntemp - - ! load new droplets in layers above, below clouds - - dtmin = dtmicro - ekk(top_lev-1) = 0.0_r8 - ekk(pver) = 0.0_r8 - do k = top_lev, pver-1 - ! rce-comment -- ekd(k) is eddy-diffusivity at k/k+1 interface - ! want ekk(k) = ekd(k) * (density at k/k+1 interface) - ! so use pint(i,k+1) as pint is 1:pverp - ! ekk(k)=ekd(k)*2.*pint(i,k)/(rair*(temp(i,k)+temp(i,k+1))) - ! ekk(k)=ekd(k)*2.*pint(i,k+1)/(rair*(temp(i,k)+temp(i,k+1))) - ekk(k) = ekd(k)*csbot(k) - end do - - do k = top_lev, pver - km1 = max0(k-1, top_lev) - ekkp(k) = zn(k)*ekk(k)*zs(k) - ekkm(k) = zn(k)*ekk(k-1)*zs(km1) - tinv = ekkp(k) + ekkm(k) - - ! rce-comment -- tinv is the sum of all first-order-loss-rates - ! for the layer. for most layers, the activation loss rate - ! (for interstitial particles) is accounted for by the loss by - ! turb-transfer to the layer above. - ! k=pver is special, and the loss rate for activation within - ! the layer must be added to tinv. if not, the time step - ! can be too big, and explmix can produce negative values. - ! the negative values are reset to zero, resulting in an - ! artificial source. - if (k == pver) tinv = tinv + taumix_internal_pver_inv - - if (tinv .gt. 1.e-6_r8) then - dtt = 1._r8/tinv - dtmin = min(dtmin, dtt) - end if - end do - - dtmix = 0.9_r8*dtmin - nsubmix = dtmicro/dtmix + 1 - if (nsubmix > 100) then - nsubmix_bnd = 100 - else - nsubmix_bnd = nsubmix - end if - count_submix(nsubmix_bnd) = count_submix(nsubmix_bnd) + 1 - dtmix = dtmicro/nsubmix - - do k = top_lev, pver - kp1 = min(k+1, pver) - km1 = max(k-1, top_lev) - ! maximum overlap assumption - if (cldn(i,kp1) > 1.e-10_r8) then - overlapp(k) = min(cldn(i,k)/cldn(i,kp1), 1._r8) - else - overlapp(k) = 1._r8 - end if - if (cldn(i,km1) > 1.e-10_r8) then - overlapm(k) = min(cldn(i,k)/cldn(i,km1), 1._r8) - else - overlapm(k) = 1._r8 - end if - end do - - ! the activation source(k) = mact(k,m)*raercol(kp1,lmass) - ! should not exceed the rate of transfer of unactivated particles - ! from kp1 to k which = ekkp(k)*raercol(kp1,lmass) - ! however it might if things are not "just right" in subr activate - ! the following is a safety measure to avoid negatives in explmix - do k = top_lev, pver-1 - do m = 1, ntot_amode - nact(k,m) = min( nact(k,m), ekkp(k) ) - mact(k,m) = min( mact(k,m), ekkp(k) ) - end do - end do - - !Don't need the mixing per mode in OSLO_AERO ==> only per tracer - !Note that nsav/nnew is switched above, so operate on nnew here - !nnew is the updated aerosol - raercol_tracer(:,:,:) = 0.0_r8 - raercol_cw_tracer(:,:,:) = 0.0_r8 - mact_tracer(:,:) = 0.0_r8 - mfullact_tracer(:,:) = 0.0_r8 - do m=1,ntot_amode - do l=1,nspec_amode(m) - lptr = getTracerIndex(m,l,.FALSE.) !which tracer are we talking about - lptr2 = inverseAerosolTracerList(lptr) !which index is this in the list of aerosol-tracers - mm = mam_idx(m,l) - raercol_tracer(:,lptr2,nnew) = raercol_tracer(:,lptr2,nnew) & - + raercol(:,mm,nnew) - - raercol_cw_tracer(:,lptr2,nnew) = raercol_cw_tracer(:,lptr2,nnew)& - + raercol_cw(:,mm,nnew) - - mact_tracer(:,lptr2) = mact_tracer(:,lptr2) + mact(:,m)*raercol(:,mm,nnew) - mfullact_tracer(:,lptr2) = mfullact_tracer(:,lptr2) + raercol(:,mm,nnew) - - end do !l - end do !m - - do lptr2=1,n_aerosol_tracers - mact_tracer(:,lptr2) = mact_tracer(:,lptr2) /(mfullact_tracer(:,lptr2) + smallNumber) - end do - - ! old_cloud_nsubmix_loop - do n = 1, nsubmix - qncld(:) = qcld(:) - ! switch nsav, nnew so that nsav is the updated aerosol - ntemp = nsav - nsav = nnew - nnew = ntemp - srcn(:) = 0.0_r8 - - !First mix cloud droplet number concentration - do m = 1, ntot_amode - mm = mam_idx(m,0) - - ! update droplet source - ! rce-comment- activation source in layer k involves particles from k+1 - ! srcn(:)=srcn(:)+nact(:,m)*(raercol(:,mm,nsav)) - srcn(top_lev:pver-1) = srcn(top_lev:pver-1) + nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - - ! rce-comment- new formulation for k=pver - ! srcn( pver )=srcn( pver )+nact( pver ,m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - srcn(pver) = srcn(pver) + max(0.0_r8,tmpa) - end do - - !mixing of cloud droplets - call explmix_oslo(qcld, srcn, ekkp, ekkm, overlapp, & - overlapm, qncld, zero, zero, pver, dtmix, .false.) - - !Mix number concentrations consistently!! - do m = 1, ntot_amode - mm = mam_idx(m,0) - ! rce-comment - activation source in layer k involves particles from k+1 - ! source(:)= nact(:,m)*(raercol(:,mm,nsav)) - source(top_lev:pver-1) = nact(top_lev:pver-1,m)*(raercol(top_lev+1:pver,mm,nsav)) - ! rce-comment - new formulation for k=pver - ! source( pver )= nact( pver, m)*(raercol( pver,mm,nsav)) - tmpa = raercol(pver,mm,nsav)*nact(pver,m) & - + raercol_cw(pver,mm,nsav)*(nact(pver,m) - taumix_internal_pver_inv) - source(pver) = max(0.0_r8, tmpa) - flxconv = 0._r8 - - call explmix_oslo( raercol_cw(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw(:,mm,nsav), zero, zero, pver, dtmix, .false.) - - call explmix_oslo( raercol(:,mm,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol(:,mm,nsav), zero, flxconv, pver, dtmix, .true., raercol_cw(:,mm,nsav)) - end do - - do lptr2=1,n_aerosol_tracers - source(top_lev:pver-1) = mact_tracer(top_lev:pver-1,lptr2) & - *(raercol_tracer(top_lev+1:pver,lptr2,nsav)) - - tmpa = raercol_tracer(pver,lptr2,nsav)*mact_tracer(pver,lptr2) & - + raercol_cw_tracer(pver,lptr2,nsav)*(mact_tracer(pver,lptr2) - taumix_internal_pver_inv) - - source(pver) = max(0.0_r8, tmpa) - flxconv = 0.0_r8 - - call explmix_oslo(raercol_cw_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_cw_tracer(:,lptr2,nsav), zero, zero, pver, dtmix, .false.) - - call explmix_oslo(raercol_tracer(:,lptr2,nnew), source, ekkp, ekkm, overlapp, & - overlapm, raercol_tracer(:,lptr2,nsav), zero, flxconv, pver, dtmix, .true., & - raercol_cw_tracer(:,lptr2,nsav)) - - end do !Number of aerosol tracers - end do ! old_cloud_nsubmix_loop - - !Set back to the original framework - !Could probably continue in tracer-space from here - !but return back to mixture for easier use of std. NCAR code - tendencyCounted(:)=.FALSE. - do m = 1, ntot_amode - do l=1,nspec_amode(m) - mm=mam_idx(m,l) - lptr = getTracerIndex(m,l,.FALSE.) - lptr2 = inverseAerosolTracerList(lptr) - !All the tracer-space contains sum of all - !modes ==> put in first available component - !and zero in others. - if(.not.tendencyCounted(lptr))then - raercol(:,mm,nnew) = raercol_tracer(:,lptr2,nnew) - raercol_cw(:,mm,nnew) = raercol_cw_tracer(:,lptr2,nnew) - tendencyCounted(lptr) = .TRUE. - else - raercol(:,mm,nnew) = 0.0_r8 - raercol_cw(:,mm,nnew) = 0.0_r8 - end if - end do - end do - - ! evaporate particles again if no cloud - - do k = top_lev, pver - if (cldn(i,k) == 0._r8) then - ! no ice or liquid cloud - qcld(k)=0._r8 - - ! convert activated aerosol to interstitial in decaying cloud - do m = 1, ntot_amode - mm = mam_idx(m,0) - raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) - raercol_cw(k,mm,nnew) = 0._r8 - - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - raercol(k,mm,nnew) = raercol(k,mm,nnew) + raercol_cw(k,mm,nnew) - raercol_cw(k,mm,nnew) = 0._r8 - end do - end do - end if - end do - - ! droplet number - ndropcol(i) = 0._r8 - - !Initialize tendnd to zero in all layers since values are set in only top_lev,pver - !Without this the layers above top_lev would be un-initialized - tendnd(i,:) = 0.0_r8 - - do k = top_lev, pver - ndropmix(i,k) = (qcld(k) - ncldwtr(i,k))*dtinv - nsource(i,k) - tendnd(i,k) = (max(qcld(k), 1.e-6_r8) - ncldwtr(i,k))*dtinv - ndropcol(i) = ndropcol(i) + ncldwtr(i,k)*pdel(i,k) - end do - ndropcol(i) = ndropcol(i)/gravit - - if (prog_modal_aero) then - - raertend = 0._r8 - qqcwtend = 0._r8 - - coltend_cw(i,:)=0.0_r8 - coltend(i,:) = 0.0_r8 - - !Need to initialize first because process modes arrive several times - tendencyCounted(:) = .FALSE. - do m=1,ntot_amode - do l = 1,getNumberOfTracersInMode(m) - lptr = getTracerIndex(m,l,.false.) - mm = mam_idx(m,l) - - !column tendencies for output - if(.NOT. tendencyCounted(lptr))then - coltend_cw(i,lptr) = coltend_cw(i,lptr) & - + sum( pdel(i,top_lev:pver)*(raercol_cw(top_lev:pver,mm,nnew) & !New, splitted, - - qqcw(mm)%fld(i,top_lev:pver) ) )/gravit*dtinv !Old, total - tendencyCounted(lptr) = .TRUE. - else !Already subtracted total old value, just add new - coltend_cw(i,lptr) = coltend_cw(i,lptr) & - + sum(pdel(i,top_lev:pver)*raercol_cw(top_lev:pver,mm,nnew))/gravit*dtinv !total already subtracted - end if - - ptend%q(i,:,lptr) = 0.0_r8 !Initialize tendencies - qqcw(mm)%fld(i,:) = 0.0_r8 !Throw out old concentrations before summing new ones - end do ! Tracers - end do ! Modes - - !First, sum up all the tracer mass concentrations - do m = 1, ntot_amode - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) !tracer indices for aerosol mass mixing ratios in raer-arrays - lptr = getTracerIndex(m,l,.false.) !index in q-array (1-pcnst) - - !This is a bit tricky since in our scheme the tracers can arrive several times - !the same tracer can exist in several modes, e.g. condensate!! - !Here we sum this into "qqcw" and "ptend" so that they contain TOTAL of those tracers - - !raercol and raercol_cw do not have totals, they have process-tracers splitted onto modes - - !Tendency at this point is the sum (original value subtracted below) - ptend%q(i,top_lev:pver,lptr) = ptend%q(i,top_lev:pver,lptr) + raercol(top_lev:pver,mm,nnew) - !for cloud water concentrations, we don't get tendency , only new concentration - qqcw(mm)%fld(i,top_lev:pver) = qqcw(mm)%fld(i,top_lev:pver) + raercol_cw(top_lev:pver,mm,nnew) - - end do - end do - - !Need this check due to some tracers (e.g. condensate) several times - tendencyCounted(:) = .FALSE. - - ! Recalculating cloud-borne aerosol number mixing ratios - do m=1,ntot_amode - - !Now that all new aerosol masses are summed up, we subtract the original concentrations to obtain the tendencies - do l= 1,nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) - if(.NOT. tendencyCounted(lptr)) then - ptend%q(i,top_lev:pver,lptr) = (ptend%q(i,top_lev:pver,lptr) - raer(mm)%fld(i,top_lev:pver))*dtinv - coltend(i,lptr) = sum(pdel(i,top_lev:pver)*ptend%q(i,top_lev:pver,lptr))/gravit !Save column tendency - tendencyCounted(lptr) = .TRUE. - endif - end do !species - end do !modes - - end if !prog_modal_aero - - end do ! overall_main_i_loop - - ! end of main loop over i/longitude .................................... - - call outfld('NDROPCOL', ndropcol, pcols, lchnk) - call outfld('NDROPSRC', nsource, pcols, lchnk) - call outfld('NDROPMIX', ndropmix, pcols, lchnk) - call outfld('WTKE ', wtke, pcols, lchnk) - - if (history_aerosol) then - call ccncalc_oslo(state, pbuf, cs, hasAerosol, numberConcentration, volumeConcentration, & - hygroscopicity, lnSigma, ccn) - do l = 1, psat - call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) - enddo - end if - - tendencyCounted(:)=.FALSE. - do m = 1, ntot_amode - do l = 1, nspec_amode(m) - mm = mam_idx(m,l) - lptr = getTracerIndex(m,l,.false.) - if(.NOT. tendencyCounted(lptr))then - call outfld(fieldname(mm), coltend(:,lptr), pcols,lchnk) - call outfld(fieldname_cw(mm), coltend_cw(:,lptr), pcols,lchnk) - tendencyCounted(lptr)=.TRUE. - endif - end do - end do - - deallocate(nact) - deallocate(mact) - deallocate(raer) - deallocate(qqcw) - deallocate(raercol) - deallocate(raercol_cw) - deallocate(coltend) - deallocate(coltend_cw) - deallocate(naermod) - deallocate(hygro) - deallocate(lnsigman) !Variable std. dev (CAM-Oslo) - deallocate(vaerosol) - deallocate(fn) - deallocate(fm) - deallocate(fluxn) - deallocate(fluxm) - deallocate(fluxm_tmp) - deallocate(fluxn_tmp) - deallocate(fm_tmp) - deallocate(fn_tmp) - deallocate(raercol_tracer) - deallocate(raercol_cw_tracer) - deallocate(mact_tracer) - deallocate(mfullact_tracer) - - end subroutine dropmixnuc_oslo - - !=============================================================================== - - subroutine explmix_oslo( q, src, ekkp, ekkm, overlapp, overlapm, & - qold, surfrate, flxconv, pver, dt, is_unact, qactold ) - - ! explicit integration of droplet/aerosol mixing with source due to activation/nucleation - - integer, intent(in) :: pver ! number of levels - real(r8), intent(out):: q(pver) ! mixing ratio to be updated - real(r8), intent(in) :: qold(pver) ! mixing ratio from previous time step - real(r8), intent(in) :: src(pver) ! source due to activation/nucleation (/s) - real(r8), intent(in) :: ekkp(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! below layer k (k,k+1 interface) - real(r8), intent(in) :: ekkm(pver) ! zn*zs*density*diffusivity (kg/m3 m2/s) at interface - ! above layer k (k,k+1 interface) - real(r8), intent(in) :: overlapp(pver) ! cloud overlap below - real(r8), intent(in) :: overlapm(pver) ! cloud overlap above - real(r8), intent(in) :: surfrate ! surface exchange rate (/s) - real(r8), intent(in) :: flxconv ! convergence of flux from surface - real(r8), intent(in) :: dt ! time step (s) - logical, intent(in) :: is_unact ! true if this is an unactivated species - real(r8), intent(in),optional :: qactold(pver) ! mixing ratio of ACTIVATED species from previous step - ! *** this should only be present if the current species - ! is unactivated number/sfc/mass - - integer k,kp1,km1 - - if ( is_unact ) then - ! the qactold*(1-overlap) terms are resuspension of activated material - do k=top_lev,pver - kp1=min(k+1,pver) - km1=max(k-1,top_lev) - q(k) = qold(k) + dt*( - src(k) + ekkp(k)*(qold(kp1) - qold(k) + & - qactold(kp1)*(1.0_r8-overlapp(k))) & - + ekkm(k)*(qold(km1) - qold(k) + & - qactold(km1)*(1.0_r8-overlapm(k))) ) - q(k)=max(q(k),0._r8) - end do - - ! diffusion loss at base of lowest layer - q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt - q(pver)=max(q(pver),0._r8) - else - do k=top_lev,pver - kp1=min(k+1,pver) - km1=max(k-1,top_lev) - q(k) = qold(k) + dt*(src(k) + ekkp(k)*(overlapp(k)*qold(kp1)-qold(k)) + & - ekkm(k)*(overlapm(k)*qold(km1)-qold(k)) ) - q(k) = max(q(k),0._r8) ! force to non-negative if (q(k)<-1.e-30) then - end do - q(pver)=q(pver)-surfrate*qold(pver)*dt+flxconv*dt ! diffusion loss at base of lowest layer - q(pver)=max(q(pver),0._r8) ! force to non-negative if(q(pver)<-1.e-30)then - end if - - end subroutine explmix_oslo - - !=============================================================================== - - subroutine activate_modal_oslo(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & - na, nmode, volume, hygro, fn, fm, fluxn, fluxm, flux_fullact, lnsigman ) - - ! calculates number, surface, and mass fraction of aerosols activated as CCN - ! calculates flux of cloud droplets, surface area, and aerosol mass into cloud - ! assumes an internal mixture within each of up to nmode multiple aerosol modes - ! a gaussiam spectrum of updrafts can be treated. - - ! mks units - - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - - ! arguments - real(r8) , intent(in) :: wbar ! grid cell mean vertical velocity (m/s) - real(r8) , intent(in) :: sigw ! subgrid standard deviation of vertical vel (m/s) - real(r8) , intent(in) :: wdiab ! diabatic vertical velocity (0 if adiabatic) - real(r8) , intent(in) :: wminf ! minimum updraft velocity for integration (m/s) - real(r8) , intent(in) :: wmaxf ! maximum updraft velocity for integration (m/s) - real(r8) , intent(in) :: tair ! air temperature (K) - real(r8) , intent(in) :: rhoair ! air density (kg/m3) - real(r8) , intent(in) :: na(:) ! aerosol number concentration (/m3) - integer , intent(in) :: nmode ! number of aerosol modes - real(r8) , intent(in) :: volume(:) ! aerosol volume concentration (m3/m3) - real(r8) , intent(in) :: hygro(:) ! hygroscopicity of aerosol mode - real(r8) , intent(in) :: lnsigman(:) - real(r8) , intent(out) :: fn(:) ! number fraction of aerosols activated - real(r8) , intent(out) :: fm(:) ! mass fraction of aerosols activated - real(r8) , intent(out) :: fluxn(:) ! flux of activated aerosol number fraction into cloud (cm/s) - real(r8) , intent(out) :: fluxm(:) ! flux of activated aerosol mass fraction into cloud (cm/s) - real(r8) , intent(out) :: flux_fullact ! flux of activated aerosol fraction assuming 100% activation (cm/s) - - ! used for consistency check -- this should match (ekd(k)*zs(k)) - ! also, fluxm/flux_fullact gives fraction of aerosol mass flux!that is activated - - ! local - integer, parameter:: nx=200 - integer iquasisect_option, isectional - real(r8) integ,integf - real(r8), parameter :: p0 = 1013.25e2_r8 ! reference pressure (Pa) - real(r8) xmin(nmode),xmax(nmode) ! ln(r) at section interfaces - real(r8) volmin(nmode),volmax(nmode) ! volume at interfaces - real(r8) tmass ! total aerosol mass concentration (g/cm3) - real(r8) sign(nmode) ! geometric standard deviation of size distribution - real(r8) rm ! number mode radius of aerosol at max supersat (cm) - real(r8) pres ! pressure (Pa) - real(r8) path ! mean free path (m) - real(r8) diff ! diffusivity (m2/s) - real(r8) conduct ! thermal conductivity (Joule/m/sec/deg) - real(r8) diff0,conduct0 - real(r8) es ! saturation vapor pressure - real(r8) qs ! water vapor saturation mixing ratio - real(r8) dqsdt ! change in qs with temperature - real(r8) dqsdp ! change in qs with pressure - real(r8) g ! thermodynamic function (m2/s) - real(r8) zeta(nmode), eta(nmode) - real(r8) lnsmax ! ln(smax) - real(r8) alpha - real(r8) gamma - real(r8) beta - real(r8) sqrtg - real(r8) :: amcube(nmode) ! cube of dry mode radius (m) - real(r8) :: lnsm(nmode) ! ln(smcrit) - real(r8) smc(nmode) ! critical supersaturation for number mode radius - real(r8) sumflx_fullact - real(r8) sumflxn(nmode) - real(r8) sumflxm(nmode) - real(r8) sumfn(nmode) - real(r8) sumfm(nmode) - real(r8) fnold(nmode) ! number fraction activated - real(r8) fmold(nmode) ! mass fraction activated - real(r8) exp45logsig_var(nmode) !variable std. dev (CAM-Oslo) - real(r8), target :: f1_var(nmode), f2_var(nmode) - real(r8) wold,gold - real(r8) alogam - real(r8) rlo,rhi,xint1,xint2,xint3,xint4 - real(r8) wmin,wmax,w,dw,dwmax,dwmin,wnuc,dwnew,wb - real(r8) dfmin,dfmax,fnew,fold,fnmin,fnbar,fsbar,fmbar - real(r8) alw,sqrtalw - real(r8) smax - real(r8) x,arg - real(r8) xmincoeff,xcut,volcut,surfcut - real(r8) z,z1,z2,wf1,wf2,zf1,zf2,gf1,gf2,gf - real(r8) etafactor1,etafactor2(nmode),etafactor2max - real(r8) grow - character(len=*), parameter :: subname='activate_modal' - integer m,n - ! numerical integration parameters - real(r8), parameter :: eps=0.3_r8,fmax=0.99_r8,sds=3._r8 - - real(r8), parameter :: namin=1.e6_r8 ! minimum aerosol number concentration (/m3) - - integer ndist(nx) ! accumulates frequency distribution of integration bins required - data ndist/nx*0/ - save ndist - - fn(:)=0._r8 - fm(:)=0._r8 - fluxn(:)=0._r8 - fluxm(:)=0._r8 - flux_fullact=0._r8 - - if(nmode.eq.1.and.na(1).lt.1.e-20_r8)return - - if(sigw.le.1.e-5_r8.and.wbar.le.0._r8)return - - pres = rair*rhoair*tair - diff0 = 0.211e-4_r8*(p0/pres)*(tair/t0)**1.94_r8 - conduct0 = (5.69_r8+0.017_r8*(tair-t0))*4.186e2_r8*1.e-5_r8 ! convert to J/m/s/deg - - call qsat(tair, pres, es, qs) - - dqsdt = latvap/(rh2o*tair*tair)*qs - alpha = gravit*(latvap/(cpair*rh2o*tair*tair)-1._r8/(rair*tair)) - gamma = (1.0_r8+latvap/cpair*dqsdt)/(rhoair*qs) - etafactor2max = 1.e10_r8/(alpha*wmaxf)**1.5_r8 ! this should make eta big if na is very small. - - grow = 1._r8/(rhoh2o/(diff0*rhoair*qs) + latvap*rhoh2o/(conduct0*tair)*(latvap/(rh2o*tair) - 1._r8)) - sqrtg = sqrt(grow) - beta = 2._r8*pi*rhoh2o*grow*gamma - - do m=1,nmode - - if(volume(m).gt.1.e-39_r8.and.na(m).gt.1.e-39_r8)then - ! number mode radius (m) - exp45logsig_var(m) = exp(4.5_r8*lnsigman(m)*lnsigman(m)) - amcube(m) = (3._r8*volume(m)/(4._r8*pi*exp45logsig_var(m)*na(m))) ! only if variable size dist - f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) - f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) - - ! growth coefficent Abdul-Razzak & Ghan 1998 eqn 16 - ! should depend on mean radius of mode to account for gas kinetic effects - ! see Fountoukis and Nenes, JGR2005 and Meskhidze et al., JGR2006 - ! for approriate size to use for effective diffusivity. - etafactor2(m) = 1._r8/(na(m)*beta*sqrtg) - if(hygro(m).gt.1.e-10_r8)then - smc(m) = 2._r8*aten*sqrt(aten/(27._r8*hygro(m)*amcube(m))) ! only if variable size dist - else - smc(m) = 100._r8 - endif - else - smc(m) = 1._r8 - etafactor2(m) = etafactor2max ! this should make eta big if na is very small. - endif - lnsm(m) = log(smc(m)) ! only if variable size dist - enddo - - if(sigw.gt.1.e-5_r8)then ! spectrum of updrafts - - wmax = min(wmaxf,wbar+sds*sigw) - wmin = max(wminf,-wdiab) - wmin = max(wmin,wbar-sds*sigw) - w = wmin - dwmax = eps*sigw - dw = dwmax - dfmax = 0.2_r8 - dfmin = 0.1_r8 - if (wmax <= w) return - do m=1,nmode - sumflxn(m) = 0._r8 - sumfn(m) = 0._r8 - fnold(m) = 0._r8 - sumflxm(m) = 0._r8 - sumfm(m) = 0._r8 - fmold(m) = 0._r8 - enddo - sumflx_fullact = 0._r8 - - fold = 0._r8 - wold = 0._r8 - gold = 0._r8 - - dwmin = min( dwmax, 0.01_r8 ) - do n = 1, nx - -100 wnuc=w+wdiab - alw=alpha*wnuc - sqrtalw=sqrt(alw) - etafactor1=alw*sqrtalw - - do m=1,nmode - eta(m)=etafactor1*etafactor2(m) - zeta(m)=twothird*sqrtalw*aten/sqrtg - enddo - - call maxsat_oslo(zeta,eta,nmode,smc,smax,f1_var,f2_var) - - lnsmax=log(smax) - - x=twothird*(lnsm(nmode)-lnsmax)/(sq2*lnsigman(nmode)) - fnew=0.5_r8*(1._r8-erf(x)) - - - dwnew = dw - if(fnew-fold.gt.dfmax.and.n.gt.1)then - ! reduce updraft increment for greater accuracy in integration - if (dw .gt. 1.01_r8*dwmin) then - dw=0.7_r8*dw - dw=max(dw,dwmin) - w=wold+dw - go to 100 - else - dwnew = dwmin - endif - endif - - if(fnew-fold.lt.dfmin)then - ! increase updraft increment to accelerate integration - dwnew=min(1.5_r8*dw,dwmax) - endif - fold=fnew - - z=(w-wbar)/(sigw*sq2) - g=exp(-z*z) - fnmin=1._r8 - xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - - do m=1,nmode - ! modal - x=twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) - fn(m)=0.5_r8*(1._r8-erf(x)) - fnmin=min(fn(m),fnmin) - ! integration is second order accurate - ! assumes linear variation of f*g with w - fnbar=(fn(m)*g+fnold(m)*gold) - arg=x-1.5_r8*sq2*lnsigman(m) - fm(m)=0.5_r8*(1._r8-erf(arg)) - fmbar=(fm(m)*g+fmold(m)*gold) - wb=(w+wold) - if(w.gt.0._r8)then - sumflxn(m)=sumflxn(m)+sixth*(wb*fnbar & - +(fn(m)*g*w+fnold(m)*gold*wold))*dw - sumflxm(m)=sumflxm(m)+sixth*(wb*fmbar & - +(fm(m)*g*w+fmold(m)*gold*wold))*dw - endif - sumfn(m)=sumfn(m)+0.5_r8*fnbar*dw - fnold(m)=fn(m) - sumfm(m)=sumfm(m)+0.5_r8*fmbar*dw - fmold(m)=fm(m) - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact & - + sixth*(wb*(g+gold) + (g*w+gold*wold))*dw - ! sumg=sumg+0.5_r8*(g+gold)*dw - gold=g - wold=w - dw=dwnew - if (n > 1 .and. (w > wmax .or. fnmin > fmax)) exit - w=w+dw - if (n == nx) then - write(iulog,*)'do loop is too short in activate' - write(iulog,*)'wmin=',wmin,' w=',w,' wmax=',wmax,' dw=',dw - write(iulog,*)'wbar=',wbar,' sigw=',sigw,' wdiab=',wdiab - write(iulog,*)'wnuc=',wnuc - write(iulog,*)'na=',(na(m),m=1,nmode) - write(iulog,*)'fn=',(fn(m),m=1,nmode) - ! dump all subr parameters to allow testing with standalone code - ! (build a driver that will read input and call activate) - write(iulog,*)'wbar,sigw,wdiab,tair,rhoair,nmode=' - write(iulog,*) wbar,sigw,wdiab,tair,rhoair,nmode - write(iulog,*)'na=',na - write(iulog,*)'volume=', (volume(m),m=1,nmode) - write(iulog,*)'hydro=' - write(iulog,*) hygro - call endrun(subname) - end if - - enddo - - ndist(n)=ndist(n)+1 - if(w.lt.wmaxf)then - - ! contribution from all updrafts stronger than wmax - ! assuming constant f (close to fmax) - wnuc=w+wdiab - - z1=(w-wbar)/(sigw*sq2) - z2=(wmaxf-wbar)/(sigw*sq2) - g=exp(-z1*z1) - integ=sigw*0.5_r8*sq2*sqpi*(erf(z2)-erf(z1)) - ! consider only upward flow into cloud base when estimating flux - wf1=max(w,zero) - zf1=(wf1-wbar)/(sigw*sq2) - gf1=exp(-zf1*zf1) - wf2=max(wmaxf,zero) - zf2=(wf2-wbar)/(sigw*sq2) - gf2=exp(-zf2*zf2) - gf=(gf1-gf2) - integf=wbar*sigw*0.5_r8*sq2*sqpi*(erf(zf2)-erf(zf1))+sigw*sigw*gf - - do m=1,nmode - sumflxn(m)=sumflxn(m)+integf*fn(m) - sumfn(m)=sumfn(m)+fn(m)*integ - sumflxm(m)=sumflxm(m)+integf*fm(m) - sumfm(m)=sumfm(m)+fm(m)*integ - enddo - ! same form as sumflxm but replace the fm with 1.0 - sumflx_fullact = sumflx_fullact + integf - ! sumg=sumg+integ - endif - - - do m=1,nmode - fn(m)=sumfn(m)/(sq2*sqpi*sigw) - ! fn(m)=sumfn(m)/(sumg) - if(fn(m).gt.1.01_r8)then - write(iulog,*)'fn=',fn(m),' > 1 in activate' - write(iulog,*)'w,m,na,amcube=',w,m,na(m),amcube(m) - write(iulog,*)'integ,sumfn,sigw=',integ,sumfn(m),sigw - call endrun('activate') - endif - fluxn(m)=sumflxn(m)/(sq2*sqpi*sigw) - fm(m)=sumfm(m)/(sq2*sqpi*sigw) - ! fm(m)=sumfm(m)/(sumg) - if(fm(m).gt.1.01_r8)then - write(iulog,*)'fm=',fm(m),' > 1 in activate' - endif - fluxm(m)=sumflxm(m)/(sq2*sqpi*sigw) - enddo - ! same form as fluxm - flux_fullact = sumflx_fullact/(sq2*sqpi*sigw) - - else - - ! single updraft - wnuc=wbar+wdiab - - if(wnuc.gt.0._r8)then - w=wbar - alw=alpha*wnuc - sqrtalw=sqrt(alw) - etafactor1=alw*sqrtalw - - do m = 1,nmode - eta(m) = etafactor1*etafactor2(m) - zeta(m) = twothird*sqrtalw*aten/sqrtg - f1_var(m) = 0.5_r8*exp(2.5_r8*lnsigman(m)*lnsigman(m)) - f2_var(m) = 1._r8 + 0.25_r8*lnsigman(m) - enddo - - call maxsat_oslo(zeta,eta,nmode,smc,smax,f1_var, f2_var) - - lnsmax=log(smax) - xmincoeff=alogaten-twothird*(lnsmax-alog2)-alog3 - do m = 1,nmode - x = twothird*(lnsm(m)-lnsmax)/(sq2*lnsigman(m)) - fn(m) = 0.5_r8*(1._r8-erf(x)) - arg = x-1.5_r8*sq2*lnsigman(m) - fm(m) = 0.5_r8*(1._r8-erf(arg)) - if (wbar.gt.0._r8)then - fluxn(m) = fn(m)*w - fluxm(m) = fm(m)*w - endif - enddo - flux_fullact = w - endif - - endif - - end subroutine activate_modal_oslo - - !=============================================================================== - subroutine maxsat_oslo(zeta, eta, nmode, smc, smax, f1_in, f2_in) - - ! calculates maximum supersaturation for multiple competing aerosol modes. - ! Abdul-Razzak and Ghan, A parameterization of aerosol activation. - ! 2. Multiple aerosol types. J. Geophys. Res., 105, 6837-6844. - - ! arguments - real(r8), intent(in) :: zeta(nmode) - real(r8), intent(in) :: eta(nmode) - integer, intent(in) :: nmode ! number of modes - real(r8), intent(in) :: smc(nmode) ! critical supersaturation for number mode radius - real(r8), intent(in), target :: f1_in(:) - real(r8), intent(in), target :: f2_in(:) - real(r8), intent(out) :: smax ! maximum supersaturation - - ! local variables - integer :: m ! mode index - real(r8) :: sum, g1, g2, g1sqrt, g2sqrt - real(r8), pointer :: f1_used(:), f2_used(:) - - f1_used => f1_in - f2_used => f2_in - - do m=1,nmode - if(zeta(m).gt.1.e5_r8*eta(m).or.smc(m)*smc(m).gt.1.e5_r8*eta(m))then - ! weak forcing. essentially none activated - smax=1.e-20_r8 - else - ! significant activation of this mode. calc activation all modes. - exit - endif - ! No significant activation in any mode. Do nothing. - if (m == nmode) return - enddo - - sum = 0.0_r8 - do m = 1,nmode - if(eta(m).gt.1.e-20_r8)then - g1 = zeta(m)/eta(m) - g1sqrt = sqrt(g1) - g1 = g1sqrt*g1 - g2 = smc(m)/sqrt(eta(m)+3._r8*zeta(m)) - g2sqrt = sqrt(g2) - g2 = g2sqrt*g2 - sum = sum+(f1_used(m)*g1+f2_used(m)*g2)/(smc(m)*smc(m)) - else - sum = 1.e20_r8 - endif - enddo - smax = 1._r8/sqrt(sum) - - end subroutine maxsat_oslo - - !=============================================================================== - - subroutine ccncalc_oslo(state, pbuf, cs, hasAerosol, numberConcentration, volumeConcentration, & - hygroscopicity, lnSigma, ccn) - - ! calculates number concentration of aerosols activated as CCN at - ! supersaturation supersat. - ! assumes an internal mixture of a multiple externally-mixed aerosol modes cgs units - - ! This was used in the BACCHUS-project where it was agreed that - ! CCN would not include cloud-borne aerosols. It is possible to - ! calculate cloud-borne aerosols, but it is complicated, and it was - ! not needed when this code was made. - - ! arguments - type(physics_state), target, intent(in) :: state - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8) , intent(in) :: cs(pcols,pver) ! air density (kg/m3) - logical , intent(in) :: hasAerosol(pcols, pver, nmodes) - real(r8) , intent(in) :: numberConcentration(pcols,pver,0:nmodes) ! interstit+activated aerosol number conc (/m3) - real(r8) , intent(in) :: volumeConcentration(pcols,pver,nmodes) ! interstit+activated aerosol volume conc (m3/m3) - real(r8) , intent(in) :: hygroscopicity(pcols,pver,nmodes) - real(r8) , intent(in) :: lnSigma(pcols,pver,nmodes) - real(r8) , intent(out) :: ccn(pcols,pver,psat) ! number conc of aerosols activated at supersat (#/m3) - - ! local - integer :: lchnk ! chunk index - integer :: ncol ! number of columns - real(r8) :: super(psat) ! supersaturation - real(r8) :: surften_coef ! Coefficient in ARGI / ARGII - real(r8) :: amcube ! number median radius qubed - real(r8) :: a ! surface tension parameter - real(r8) :: sm ! critical supersaturation at mode radius - real(r8) :: arg ! factor in eqn 15 ARGII - real(r8) :: argfactor ! Coefficient in ARGI/ARGII - real(r8) :: exp45logsig_var ! mathematical constants - integer :: lsat,m,i,k ! mathematical constants - real(r8) :: smcoefcoef,smcoef ! mathematical constants - real(r8), pointer :: tair(:,:) ! air temperature (K) - real(r8), parameter :: twothird=2.0_r8/3.0_r8 - real(r8), parameter :: sq2=sqrt(2.0_r8) - real(r8), parameter :: surften=0.076_r8 !surface tension of water (J/m2) - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - tair => state%t - - super(:) = supersat(:)*0.01_r8 - - !This is curvature effect (A) in ARGI eqn 5 in ARG1 (missing division by temperature, see below) - surften_coef = 2._r8*mwh2o*surften/(r_universal*rhoh2o) - - !This is part of eqn 9 in ARGII where A smcoefcoef is 2/3^(3/2) - smcoefcoef = 2._r8/sqrt(27._r8) - - ccn(:,:,:) = 0._r8 - - do m=1,nmodes - do k=top_lev,pver - do i=1,ncol - if (hasAerosol(i,k,m)) then - - !Curvature-parameter "A" in ARGI (eqn 5) - a = surften_coef/tair(i,k) - - !standard factor for transforming size distr, volume ==> number (google psd.pdf by zender) - exp45logsig_var = exp(4.5_r8*lnsigma(i,k,m)*lnsigma(i,k,m)) - - ! Numbe rmedian radius (power of three) - ! By definition of lognormal distribution only if variable size dist - amcube =(3._r8*volumeConcentration(i,k,m) /(4._r8*pi*exp45logsig_var*numberConcentration(i,k,m))) - - !This is part of eqn 9 in ARGII where A smcoefcoef is 2/3^(3/2) - smcoef = smcoefcoef * a * sqrt(a) - - !This is finally solving eqn 9 (solve for critical supersat of mode) - sm = smcoef / sqrt(hygroscopicity(i,k,m)*amcube) ! critical supersaturation - - !Solve eqn 13 in ARGII - do lsat = 1,psat - - !eqn 15 in ARGII - argfactor = twothird/(sq2*lnSigma(i,k,m)) - - !eqn 15 in ARGII - arg = argfactor*log(sm/super(lsat)) - - !eqn 13 i ARGII - ccn(i,k,lsat) = ccn(i,k,lsat) + numberConcentration(i,k,m)*0.5_r8*(1._r8-erf(arg)) - - end do - end if - end do - end do - end do - - ccn(:ncol,:,:)=ccn(:ncol,:,:)*1.e-6_r8 ! convert from #/m3 to #/cm3 - - end subroutine ccncalc_oslo - -end module oslo_aero_ndrop diff --git a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 b/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 deleted file mode 100644 index 7dc5b5d19f..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_nucleate_ice.F90 +++ /dev/null @@ -1,1089 +0,0 @@ -module oslo_aero_nucleate_ice - - !--------------------------------------------------------------------------------- - ! A parameterization of ice nucleation. - ! - ! Method: - ! The current method is based on Liu & Penner (2005) & Liu et al. (2007) - ! It related the ice nucleation with the aerosol number, temperature and the - ! updraft velocity. It includes homogeneous freezing of sulfate & immersion - ! freezing on mineral dust (soot disabled) in cirrus clouds, and - ! Meyers et al. (1992) deposition nucleation in mixed-phase clouds - ! - ! The effect of preexisting ice crystals on ice nucleation in cirrus clouds is included, - ! and also consider the sub-grid variability of temperature in cirrus clouds, - ! following X. Shi et al. ACP (2014). - ! - ! Ice nucleation in mixed-phase clouds now uses classical nucleation theory (CNT), - ! follows Y. Wang et al. ACP (2014), Hoose et al. (2010). - ! - ! Authors: - ! Xiaohong Liu, 01/2005, modifications by A. Gettelman 2009-2010 - ! Xiangjun Shi & Xiaohong Liu, 01/2014. - ! - ! With help from C. C. Chen and B. Eaton (2014) - !--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8=>shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver - use constituents, only: pcnst, cnst_get_ind - use physconst, only: pi, rair, tmelt - use phys_control, only: phys_getopts, use_hetfrz_classnuc - use physics_types, only: physics_state, physics_ptend, physics_ptend_init - use physics_buffer, only: physics_buffer_desc, pbuf_get_index, pbuf_old_tim_idx, pbuf_get_field - use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_old_tim_idx, pbuf_get_index, pbuf_get_field - use cam_history, only: addfld, add_default, outfld - use ref_pres, only: top_lev => trop_cloud_top_lev - use wv_saturation, only: qsat_water, svp_water, svp_ice - use tropopause, only: tropopause_findChemTrop - use cam_logfile, only: iulog - use cam_abortutils, only: endrun - ! - use oslo_aero_share, only: l_dst_a2, l_dst_a3, MODE_IDX_DST_A2, MODE_IDX_DST_A3, rhopart, qqcw_get_field - use oslo_aero_share, only: MODE_IDX_DST_A2, MODE_IDX_DST_A3, MODE_IDX_SO4_AC,MODE_IDX_OMBC_INTMIX_COAT_AIT - use oslo_aero_const, only: volumeToNumber - use oslo_aero_params, only: nmodes - - implicit none - private - - public :: nucleate_ice_oslo_readnl - public :: nucleate_ice_oslo_register - public :: nucleate_ice_oslo_init - public :: nucleate_ice_oslo_calc - - private :: nucleati - - ! Namelist variables - logical, public, protected :: use_preexisting_ice = .false. - logical :: hist_preexisting_ice = .false. - logical :: nucleate_ice_incloud = .false. - logical :: nucleate_ice_use_troplev = .false. - real(r8) :: nucleate_ice_subgrid = -1._r8 - real(r8) :: nucleate_ice_subgrid_strat = -1._r8 - real(r8) :: nucleate_ice_strat = 0.0_r8 - - ! Vars set via init method. - real(r8) :: mincld ! minimum allowed cloud fraction - real(r8) :: bulk_scale ! prescribed aerosol bulk sulfur scale factor - - logical :: clim_modal_aero = .true. - logical :: lq(pcnst) = .false. ! set flags true for constituents with non-zero tendencies - logical :: use_incloud_nuc - real(r8) :: ci - - ! constituent indices - integer :: & - cldliq_idx = -1, & - cldice_idx = -1, & - numice_idx = -1 - - integer :: & - naai_idx, & - naai_hom_idx - - integer :: & - ast_idx = -1 - - integer :: & - qsatfac_idx - - real(r8), parameter :: Shet = 1.3_r8 ! het freezing threshold - real(r8), parameter :: rhoice = 0.5e3_r8 ! kg/m3, Wpice is not sensitive to rhoice - real(r8), parameter :: minweff= 0.001_r8 ! m/s - real(r8), parameter :: gamma4=6.0_r8 - -!=============================================================================== -contains -!=============================================================================== - - subroutine nucleate_ice_oslo_readnl(nlfile) - - use namelist_utils, only: find_group_name - use spmd_utils, only: mpicom, masterprocid, mpi_logical, mpi_real8 - - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - - ! Local variables - integer :: unitn, ierr - character(len=*), parameter :: subname = 'nucleate_ice_cam_readnl' - - namelist /nucleate_ice_nl/ use_preexisting_ice, hist_preexisting_ice, & - nucleate_ice_subgrid, nucleate_ice_subgrid_strat, nucleate_ice_strat, & - nucleate_ice_incloud, nucleate_ice_use_troplev - - !----------------------------------------------------------------------------- - - if (masterproc) then - open( newunit=unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'nucleate_ice_nl', status=ierr) - if (ierr == 0) then - read(unitn, nucleate_ice_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(subname // ':: ERROR reading namelist') - end if - end if - close(unitn) - end if - - ! Broadcast namelist variables - call mpi_bcast(use_preexisting_ice, 1, mpi_logical,masterprocid, mpicom, ierr) - call mpi_bcast(hist_preexisting_ice, 1, mpi_logical,masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_subgrid, 1, mpi_real8, masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_subgrid_strat, 1, mpi_real8, masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_strat, 1, mpi_real8, masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_incloud, 1, mpi_logical,masterprocid, mpicom, ierr) - call mpi_bcast(nucleate_ice_use_troplev, 1, mpi_logical,masterprocid, mpicom, ierr) - - ! Set module variable - use_incloud_nuc = nucleate_ice_incloud - - end subroutine nucleate_ice_oslo_readnl - - !================================================================================================ - - subroutine nucleate_ice_oslo_register() - - call pbuf_add_field('NAAI', 'physpkg', dtype_r8, (/pcols,pver/), naai_idx) - call pbuf_add_field('NAAI_HOM', 'physpkg', dtype_r8, (/pcols,pver/), naai_hom_idx) - - end subroutine nucleate_ice_oslo_register - - !================================================================================================ - - subroutine nucleate_ice_oslo_init(mincld_in, bulk_scale_in) - - ! arguments - real(r8), intent(in) :: mincld_in - real(r8), intent(in) :: bulk_scale_in - - ! local variables - integer :: ierr - integer :: m, n - logical :: history_cesm_forcing - character(len=*), parameter :: routine = 'nucleate_ice_cam_init' - !-------------------------------------------------------------------------------------------- - - call phys_getopts(history_cesm_forcing_out = history_cesm_forcing) - - mincld = mincld_in - bulk_scale = bulk_scale_in - - if( masterproc ) then - write(iulog,*) 'nucleate_ice parameters:' - write(iulog,*) ' mincld = ', mincld_in - write(iulog,*) ' bulk_scale = ', bulk_scale_in - write(iulog,*) ' use_preexisiting_ice = ', use_preexisting_ice - write(iulog,*) ' hist_preexisiting_ice = ', hist_preexisting_ice - write(iulog,*) ' nucleate_ice_subgrid = ', nucleate_ice_subgrid - write(iulog,*) ' nucleate_ice_subgrid_strat = ', nucleate_ice_subgrid_strat - write(iulog,*) ' nucleate_ice_strat = ', nucleate_ice_strat - write(iulog,*) ' nucleate_ice_incloud = ', nucleate_ice_incloud - write(iulog,*) ' nucleate_ice_use_troplev = ', nucleate_ice_use_troplev - end if - - call cnst_get_ind('CLDLIQ', cldliq_idx) - call cnst_get_ind('CLDICE', cldice_idx) - call cnst_get_ind('NUMICE', numice_idx) - qsatfac_idx = pbuf_get_index('QSATFAC', ierr) - - if (((nucleate_ice_subgrid .eq. -1._r8) .or. (nucleate_ice_subgrid_strat .eq. -1._r8)) .and. (qsatfac_idx .eq. -1)) then - call endrun(routine//': ERROR qsatfac is required when subgrid = -1 or subgrid_strat = -1') - end if - - call addfld('NIHF', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to homogenous freezing') - call addfld('NIDEP', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to deposition nucleation') - call addfld('NIIMM', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to immersion freezing') - call addfld('NIMEY', (/ 'lev' /), 'A', '1/m3', 'Activated Ice Number Concentation due to meyers deposition') - - call addfld('NIREGM',(/ 'lev' /), 'A', 'C', 'Ice Nucleation Temperature Threshold for Regime') - call addfld('NISUBGRID',(/ 'lev' /), 'A', '', 'Ice Nucleation subgrid saturation factor') - call addfld('NITROP_PD',(/ 'lev' /), 'A', '', 'Chemical Tropopause probability') - if ( history_cesm_forcing ) then - call add_default('NITROP_PD',8,' ') - endif - - if (use_preexisting_ice) then - call addfld('fhom', (/ 'lev' /), 'A','fraction', 'Fraction of cirrus where homogeneous freezing occur' ) - call addfld ('WICE', (/ 'lev' /), 'A','m/s','Vertical velocity Reduction caused by preexisting ice' ) - call addfld ('WEFF', (/ 'lev' /), 'A','m/s','Effective Vertical velocity for ice nucleation' ) - call addfld ('INnso4', (/ 'lev' /), 'A','1/m3','Number Concentation so4 (in) to ice_nucleation') - call addfld ('INnbc', (/ 'lev' /), 'A','1/m3','Number Concentation bc (in) to ice_nucleation') - call addfld ('INndust', (/ 'lev' /), 'A','1/m3','Number Concentation dust (in) ice_nucleation') - call addfld ('INondust', (/ 'lev' /), 'A','1/m3','Number Concentation dust (out) from ice_nucleation') - call addfld ('INhet', (/ 'lev' /), 'A','1/m3', & - 'contribution for in-cloud ice number density increase by het nucleation in ice cloud') - call addfld ('INhom', (/ 'lev' /), 'A','1/m3', & - 'contribution for in-cloud ice number density increase by hom nucleation in ice cloud') - call addfld ('INFrehom', (/ 'lev' /), 'A','frequency','hom IN frequency ice cloud') - call addfld ('INFreIN', (/ 'lev' /), 'A','frequency','frequency of ice nucleation occur') - - if (hist_preexisting_ice) then - call add_default ('WSUBI ', 1, ' ') ! addfld/outfld calls are in microp_aero - - call add_default ('fhom ', 1, ' ') - call add_default ('WICE ', 1, ' ') - call add_default ('WEFF ', 1, ' ') - call add_default ('INnso4 ', 1, ' ') - call add_default ('INnbc ', 1, ' ') - call add_default ('INndust ', 1, ' ') - call add_default ('INhet ', 1, ' ') - call add_default ('INhom ', 1, ' ') - call add_default ('INFrehom', 1, ' ') - call add_default ('INFreIN ', 1, ' ') - end if - end if - - lq(l_dst_a2) = .TRUE. - lq(l_dst_a3) = .TRUE. - - ! get indices for fields in the physics buffer - ast_idx = pbuf_get_index('AST') - - ci = rhoice*pi/6._r8 - - end subroutine nucleate_ice_oslo_init - - !================================================================================================ - - subroutine nucleate_ice_oslo_calc( state, wsubi, pbuf, dtime, ptend, numberConcentration) - - ! arguments - real(r8), intent(in) :: numberConcentration(pcols,pver,0:nmodes) - type(physics_state), target, intent(in) :: state - real(r8), intent(in) :: wsubi(:,:) - type(physics_buffer_desc), pointer :: pbuf(:) - real(r8), intent(in) :: dtime - type(physics_ptend), intent(out) :: ptend - - ! local workspace - - ! naai and naai_hom are the outputs shared with the microphysics - real(r8), pointer :: naai(:,:) ! number of activated aerosol for ice nucleation - real(r8), pointer :: naai_hom(:,:) ! number of activated aerosol for ice nucleation (homogeneous freezing only) - - integer :: lchnk, ncol - integer :: itim_old - integer :: i, k, m - - real(r8), pointer :: t(:,:) ! input temperature (K) - real(r8), pointer :: qn(:,:) ! input water vapor mixing ratio (kg/kg) - real(r8), pointer :: qc(:,:) ! cloud water mixing ratio (kg/kg) - real(r8), pointer :: qi(:,:) ! cloud ice mixing ratio (kg/kg) - real(r8), pointer :: ni(:,:) ! cloud ice number conc (1/kg) - real(r8), pointer :: pmid(:,:) ! pressure at layer midpoints (pa) - real(r8), pointer :: cld_dst_a2(:,:) ! mmr cld dst a2 - real(r8), pointer :: cld_dst_a3(:,:) ! mass m.r. of coarse dust - real(r8), pointer :: ast(:,:) - real(r8), pointer :: qsatfac(:,:) ! Subgrid cloud water saturation scaling factor. - - real(r8) :: icecldf(pcols,pver) ! ice cloud fraction - real(r8) :: rho(pcols,pver) ! air density (kg m-3) - real(r8) :: qs(pcols) ! liquid-ice weighted sat mixing rat (kg/kg) - real(r8) :: es(pcols) ! liquid-ice weighted sat vapor press (pa) - real(r8) :: gammas(pcols) ! parameter for cond/evap of cloud water - integer :: troplev(pcols) ! tropopause level - - real(r8) :: relhum(pcols,pver) ! relative humidity - real(r8) :: icldm(pcols,pver) ! ice cloud fraction - - real(r8) :: so4_num ! so4 aerosol number (#/cm^3) - real(r8) :: soot_num ! soot (hydrophilic) aerosol number (#/cm^3) - real(r8) :: dst1_num,dst2_num,dst3_num,dst4_num ! dust aerosol number (#/cm^3) - real(r8) :: dst_num ! total dust aerosol number (#/cm^3) - real(r8) :: wght - real(r8) :: dmc - real(r8) :: ssmc - real(r8) :: oso4_num - real(r8) :: odst_num - real(r8) :: osoot_num - real(r8) :: dso4_num ! tuning factor for increased so4 - real(r8) :: ramp ! ---------- " ---------------- - real(r8) :: dust_coarse_fraction ! fraction of dust in coarse (a3) mode - real(r8) :: masslost ! [kg/kg] tmp variable for mass lost - real(r8) :: numberFromSmallDustMode ! [#/cm3] number of dust activated from small mode - - real(r8) :: subgrid(pcols,pver) - real(r8) :: trop_pd(pcols,pver) - - ! For pre-existing ice - real(r8) :: fhom(pcols,pver) ! how much fraction of cloud can reach Shom - real(r8) :: wice(pcols,pver) ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at Shom - real(r8) :: weff(pcols,pver) ! effective Vertical velocity for ice nucleation (m/s); weff=wsubi-wice - real(r8) :: INnso4(pcols,pver) ! #/m3, so4 aerosol number used for ice nucleation - real(r8) :: INnbc(pcols,pver) ! #/m3, bc aerosol number used for ice nucleation - real(r8) :: INndust(pcols,pver) ! #/m3, dust aerosol number used for ice nucleation - real(r8) :: INondust(pcols,pver) ! #/m3, dust aerosol number used for ice nucleation - real(r8) :: INhet(pcols,pver) ! #/m3, ice number from het freezing - real(r8) :: INhom(pcols,pver) ! #/m3, ice number from hom freezing - real(r8) :: INFrehom(pcols,pver) ! hom freezing occurence frequency. 1 occur, 0 not occur. - real(r8) :: INFreIN(pcols,pver) ! ice nucleation occerence frequency. 1 occur, 0 not occur. - - ! history output for ice nucleation - real(r8) :: nihf(pcols,pver) !output number conc of ice nuclei due to heterogenous freezing (1/m3) - real(r8) :: niimm(pcols,pver) !output number conc of ice nuclei due to immersion freezing (hetero nuc) (1/m3) - real(r8) :: nidep(pcols,pver) !output number conc of ice nuclei due to deoposion nucleation (hetero nuc) (1/m3) - real(r8) :: nimey(pcols,pver) !output number conc of ice nuclei due to meyers deposition (1/m3) - real(r8) :: regm(pcols,pver) !output temperature thershold for nucleation regime - - real(r8) :: so4_num_ac - real(r8) :: so4_num_cr - !------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - t => state%t - qn => state%q(:,:,1) - qc => state%q(:,:,cldliq_idx) - qi => state%q(:,:,cldice_idx) - ni => state%q(:,:,numice_idx) - pmid => state%pmid - - do k = top_lev, pver - do i = 1, ncol - rho(i,k) = pmid(i,k)/(rair*t(i,k)) - end do - end do - - call physics_ptend_init(ptend, state%psetcols, 'nucleatei', lq=lq) - - cld_dst_a2 => qqcw_get_field(pbuf, l_dst_a2) - cld_dst_a3 => qqcw_get_field(pbuf, l_dst_a2) - - itim_old = pbuf_old_tim_idx() - call pbuf_get_field(pbuf, ast_idx, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/)) - - icecldf(:ncol,:pver) = ast(:ncol,:pver) - - ! naai and naai_hom are the outputs from this parameterization - call pbuf_get_field(pbuf, naai_idx, naai) - call pbuf_get_field(pbuf, naai_hom_idx, naai_hom) - naai(1:ncol,1:pver) = 0._r8 - naai_hom(1:ncol,1:pver) = 0._r8 - - ! Use the same criteria that is used in chemistry and in CLUBB (for cloud fraction) - ! to determine whether to use tropospheric or stratospheric settings. Include the - ! tropopause level so that the cold point tropopause will use the stratospheric values. - call tropopause_findChemTrop(state, troplev) - - if ((nucleate_ice_subgrid .eq. -1._r8) .or. (nucleate_ice_subgrid_strat .eq. -1._r8)) then - call pbuf_get_field(pbuf, qsatfac_idx, qsatfac) - end if - - trop_pd(:,:) = 0._r8 - - do k = top_lev, pver - do i = 1, ncol - trop_pd(i, troplev(i)) = 1._r8 - - if (k <= troplev(i)) then - if (nucleate_ice_subgrid_strat .eq. -1._r8) then - subgrid(i, k) = 1._r8 / qsatfac(i, k) - else - subgrid(i, k) = nucleate_ice_subgrid_strat - end if - else - if (nucleate_ice_subgrid .eq. -1._r8) then - subgrid(i, k) = 1._r8 / qsatfac(i, k) - else - subgrid(i, k) = nucleate_ice_subgrid - end if - end if - end do - end do - - - ! initialize history output fields for ice nucleation - nihf(1:ncol,1:pver) = 0._r8 - niimm(1:ncol,1:pver) = 0._r8 - nidep(1:ncol,1:pver) = 0._r8 - nimey(1:ncol,1:pver) = 0._r8 - - if (use_preexisting_ice) then - fhom(:,:) = 0.0_r8 - wice(:,:) = 0.0_r8 - weff(:,:) = 0.0_r8 - INnso4(:,:) = 0.0_r8 - INnbc(:,:) = 0.0_r8 - INndust(:,:) = 0.0_r8 - INondust(:,:) = 0.0_r8 - INhet(:,:) = 0.0_r8 - INhom(:,:) = 0.0_r8 - INFrehom(:,:) = 0.0_r8 - INFreIN(:,:) = 0.0_r8 - endif - - do k = top_lev, pver - ! Get humidity and saturation vapor pressures - call qsat_water(t(:ncol,k), pmid(:ncol,k), es(:ncol), qs(:ncol), gam=gammas(:ncol)) - - do i = 1, ncol - relhum(i,k) = qn(i,k)/qs(i) - icldm(i,k) = max(icecldf(i,k), mincld) ! get cloud fraction, check for minimum - end do - end do - - do k = top_lev, pver - do i = 1, ncol - - if (t(i,k) < tmelt - 5._r8) then - - ! compute aerosol number for so4, soot, and dust with units #/cm^3 - so4_num = 0._r8 - soot_num = 0._r8 - dst1_num = 0._r8 - dst2_num = 0._r8 - dst3_num = 0._r8 - dst4_num = 0._r8 - dst_num = 0._r8 - - if (clim_modal_aero) then - !For modal aerosols, assume for the upper troposphere: - ! soot = accumulation mode - ! sulfate = aiken mode - ! dust = coarse mode - ! since modal has internal mixtures. - soot_num = numberConcentration(i,k,MODE_IDX_OMBC_INTMIX_COAT_AIT)*1.0e-6_r8 - - dst_num = (numberConcentration(i,k,MODE_IDX_DST_A2) & - + numberConcentration(i,k,MODE_IDX_DST_A3))*1.0e-6_r8 - !Oslo aerosols have two modes.. Need mode-fractions - dust_coarse_fraction = numberConcentration(i,k,MODE_IDX_DST_A3)*1.e-6_r8 / (dst_num+1.e-100_r8) - - - so4_num = (numberConcentration(i,k,MODE_IDX_SO4_AC))*1.0e-6_r8 - - end if !clim modal aero - ! *** Turn off soot nucleation *** - soot_num = 0.0_r8 - - call nucleati( & - wsubi(i,k), t(i,k), pmid(i,k), relhum(i,k), icldm(i,k), & - qc(i,k), qi(i,k), ni(i,k), rho(i,k), & - so4_num, dst_num, soot_num, subgrid(i,k), & - naai(i,k), nihf(i,k), niimm(i,k), nidep(i,k), nimey(i,k), & - wice(i,k), weff(i,k), fhom(i,k), regm(i,k), & - oso4_num, odst_num, osoot_num) - - ! Move aerosol used for nucleation from interstial to cloudborne, - ! otherwise the same coarse mode aerosols will be available again - ! in the next timestep and will supress homogeneous freezing. - if (use_preexisting_ice) then - - numberFromSmallDustMode = 0.0_r8 - - !Assume the coarse aerosols were activated first - !so only remove small ones if more than large ones are activated - if(odst_num .gt. dst_num*dust_coarse_fraction)then - - !A2-mode - numberFromSmallDustMode = odst_num - dst_num*dust_coarse_fraction - - masslost = (odst_num & !all removed - - dst_num*dust_coarse_fraction) & !fraction to coarse mode - / volumeToNumber(MODE_IDX_DST_A2) & - * rhopart(l_dst_a2) & - /rho(i,k)*1e6_r8 - - ptend%q(i,k,l_dst_a2) = -masslost*icldm(i,k)/ dtime - cld_dst_a2(i,k) = cld_dst_a2(i,k) + masslost*icldm(i,k) - - end if - - ! Coarse mode (is always lost) - masslost = (odst_num - numberFromSmallDustMode) & - / volumeToNumber(MODE_IDX_DST_A3) & - * rhopart(l_dst_a3) & - / rho(i,k)*1e6_r8 - - ptend%q(i,k,l_dst_a3) = -masslost * icldm(i,k) / dtime - cld_dst_a3(i,k) = cld_dst_a3(i,k) + masslost*icldm(i,k) - - end if - - !Oslo aerosols do not have explicit treatment of coarse sulfate - so4_num_cr = 0.0_r8 - - ! Liu&Penner does not generate enough nucleation in the polar winter - ! stratosphere, which affects surface area density, dehydration and - ! ozone chemistry. Part of this is that there are a larger number of - ! particles in the accumulation mode than in the Aitken mode. In volcanic - ! periods, the coarse mode may also be important. As a short - ! term work around, include the accumulation and coarse mode particles - ! and assume a larger fraction of the sulfates nucleate in the polar - ! stratosphere. - ! - ! Do not include the tropopause level, as stratospheric aerosols - ! only exist above the tropopause level. - ! - ! NOTE: This may still not represent the proper particles that - ! participate in nucleation, because it doesn't include STS and NAT - ! particles. It may not represent the proper saturation threshold for - ! nucleation, and wsubi from CLUBB is probably not representative of - ! wave driven varaibility in the polar stratosphere. - if (nucleate_ice_use_troplev) then - if ((k < troplev(i)) .and. (nucleate_ice_strat > 0._r8)) then - if (oso4_num > 0._r8) then - so4_num_ac = so4_num*rho(i,k)*1.0e-6_r8 !This is maximum sulfate which can activate - ! NCAR/MAM4-version - ! so4_num_ac = num_accum(i,k)*rho(i,k)*1.0e-6_r8 - ! NCAR/MAM4-version - dso4_num = max(0._r8, (nucleate_ice_strat * (so4_num_cr + so4_num_ac)) - oso4_num) * 1e6_r8 / rho(i,k) - naai(i,k) = naai(i,k) + dso4_num - nihf(i,k) = nihf(i,k) + dso4_num - end if - end if - else - - ! This maintains backwards compatibility with the previous version. - if (pmid(i,k) <= 12500._r8 .and. pmid(i,k) > 100._r8 .and. abs(state%lat(i)) >= 60._r8 * pi / 180._r8) then - ramp = 1._r8 - min(1._r8, max(0._r8, (pmid(i,k) - 10000._r8) / 2500._r8)) - - if (oso4_num > 0._r8) then - dso4_num = (max(oso4_num, ramp * nucleate_ice_strat * so4_num) - oso4_num) * 1e6_r8 / rho(i,k) - naai(i,k) = naai(i,k) + dso4_num - nihf(i,k) = nihf(i,k) + dso4_num - end if - end if - end if - - naai_hom(i,k) = nihf(i,k) - - ! output activated ice (convert from #/kg -> #/m3) - nihf(i,k) = nihf(i,k) *rho(i,k) - niimm(i,k) = niimm(i,k)*rho(i,k) - nidep(i,k) = nidep(i,k)*rho(i,k) - nimey(i,k) = nimey(i,k)*rho(i,k) - - if (use_preexisting_ice) then - INnso4(i,k) =so4_num*1e6_r8 ! (convert from #/cm3 -> #/m3) - INnbc(i,k) =soot_num*1e6_r8 - INndust(i,k)=dst_num*1e6_r8 - INondust(i,k)=odst_num*1e6_r8 - INFreIN(i,k)=1.0_r8 ! 1,ice nucleation occur - INhet(i,k) = (niimm(i,k) + nidep(i,k)) ! #/m3, nimey not in cirrus - INhom(i,k) = nihf(i,k) ! #/m3 - if (INhom(i,k).gt.1e3_r8) then ! > 1/L - INFrehom(i,k)=1.0_r8 ! 1, hom freezing occur - endif - - ! exclude no ice nucleaton - if ((INFrehom(i,k) < 0.5_r8) .and. (INhet(i,k) < 1.0_r8)) then - INnso4(i,k) =0.0_r8 - INnbc(i,k) =0.0_r8 - INndust(i,k)=0.0_r8 - INondust(i,k)=0.0_r8 - INFreIN(i,k)=0.0_r8 - INhet(i,k) = 0.0_r8 - INhom(i,k) = 0.0_r8 - INFrehom(i,k)=0.0_r8 - wice(i,k) = 0.0_r8 - weff(i,k) = 0.0_r8 - fhom(i,k) = 0.0_r8 - endif - end if - - end if - end do - end do - - - call outfld('NIHF', nihf, pcols, lchnk) - call outfld('NIIMM', niimm, pcols, lchnk) - call outfld('NIDEP', nidep, pcols, lchnk) - call outfld('NIMEY', nimey, pcols, lchnk) - call outfld('NIREGM', regm, pcols, lchnk) - call outfld('NISUBGRID', subgrid, pcols, lchnk) - call outfld('NITROP_PD', trop_pd, pcols, lchnk) - - if (use_preexisting_ice) then - call outfld( 'fhom' , fhom, pcols, lchnk) - call outfld( 'WICE' , wice, pcols, lchnk) - call outfld( 'WEFF' , weff, pcols, lchnk) - call outfld('INnso4 ',INnso4 , pcols,lchnk) - call outfld('INnbc ',INnbc , pcols,lchnk) - call outfld('INndust ',INndust, pcols,lchnk) - call outfld('INondust ',INondust, pcols,lchnk) - call outfld('INhet ',INhet , pcols,lchnk) - call outfld('INhom ',INhom , pcols,lchnk) - call outfld('INFrehom',INFrehom,pcols,lchnk) - call outfld('INFreIN ',INFreIN, pcols,lchnk) - end if - - end subroutine nucleate_ice_oslo_calc - - !=============================================================================== - - subroutine nucleati( & - wbar, tair, pmid, relhum, cldn, & - qc, qi, ni_in, rhoair, & - so4_num, dst_num, soot_num, subgrid, & - nuci, onihf, oniimm, onidep, onimey, & - wpice, weff, fhom, regm, & - oso4_num, odst_num, osoot_num) - - ! Input Arguments - real(r8), intent(in) :: wbar ! grid cell mean vertical velocity (m/s) - real(r8), intent(in) :: tair ! temperature (K) - real(r8), intent(in) :: pmid ! pressure at layer midpoints (pa) - real(r8), intent(in) :: relhum ! relative humidity with respective to liquid - real(r8), intent(in) :: cldn ! new value of cloud fraction (fraction) - real(r8), intent(in) :: qc ! liquid water mixing ratio (kg/kg) - real(r8), intent(in) :: qi ! grid-mean preexisting cloud ice mass mixing ratio (kg/kg) - real(r8), intent(in) :: ni_in ! grid-mean preexisting cloud ice number conc (#/kg) - real(r8), intent(in) :: rhoair ! air density (kg/m3) - real(r8), intent(in) :: so4_num ! so4 aerosol number (#/cm^3) - real(r8), intent(in) :: dst_num ! total dust aerosol number (#/cm^3) - real(r8), intent(in) :: soot_num ! soot (hydrophilic) aerosol number (#/cm^3) - real(r8), intent(in) :: subgrid ! subgrid saturation scaling factor - - ! Output Arguments - real(r8), intent(out) :: nuci ! ice number nucleated (#/kg) - real(r8), intent(out) :: onihf ! nucleated number from homogeneous freezing of so4 - real(r8), intent(out) :: oniimm ! nucleated number from immersion freezing - real(r8), intent(out) :: onidep ! nucleated number from deposition nucleation - real(r8), intent(out) :: onimey ! nucleated number from deposition nucleation (meyers: mixed phase) - real(r8), intent(out) :: wpice ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at Shom - real(r8), intent(out) :: weff ! effective Vertical velocity for ice nucleation (m/s); weff=wbar-wpice - real(r8), intent(out) :: fhom ! how much fraction of cloud can reach Shom - real(r8), intent(out) :: regm ! nucleation regime indiator - real(r8), intent(out) :: oso4_num ! so4 aerosol number (#/cm^3) - real(r8), intent(out) :: odst_num ! total dust aerosol number (#/cm^3) - real(r8), intent(out) :: osoot_num ! soot (hydrophilic) aerosol number (#/cm^3) - - ! Local workspace - real(r8) :: nihf ! nucleated number from homogeneous freezing of so4 - real(r8) :: niimm ! nucleated number from immersion freezing - real(r8) :: nidep ! nucleated number from deposition nucleation - real(r8) :: nimey ! nucleated number from deposition nucleation (meyers) - real(r8) :: n1, ni ! nucleated number - real(r8) :: tc, A, B ! work variable - real(r8) :: esl, esi, deles ! work variable - real(r8) :: wbar1, wbar2 - - ! used in SUBROUTINE Vpreice - real(r8) :: Ni_preice ! cloud ice number conc (1/m3) - real(r8) :: lami,Ri_preice ! mean cloud ice radius (m) - real(r8) :: Shom ! initial ice saturation ratio; if <1, use hom threshold Si - real(r8) :: detaT,RHimean ! temperature standard deviation, mean cloudy RHi - real(r8) :: wpicehet ! diagnosed Vertical velocity Reduction caused by preexisting ice (m/s), at shet - real(r8) :: weffhet ! effective Vertical velocity for ice nucleation (m/s) weff=wbar-wpicehet - !------------------------------------------------------------------------------- - - RHimean = relhum*svp_water(tair)/svp_ice(tair)*subgrid - - ! temp variables that depend on use_preexisting_ice - wbar1 = wbar - wbar2 = wbar - - ! If not using prexisting ice, the homogeneous freezing happens in the - ! entire gridbox. - fhom = 1._r8 - - if (use_preexisting_ice) then - - Ni_preice = ni_in*rhoair ! (convert from #/kg -> #/m3) - Ni_preice = Ni_preice / max(mincld,cldn) ! in-cloud ice number density - - if (Ni_preice > 10.0_r8 .and. qi > 1.e-10_r8) then ! > 0.01/L = 10/m3 - Shom = -1.5_r8 ! if Shom<1 , Shom will be recalculated in SUBROUTINE Vpreice, according to Ren & McKenzie, 2005 - lami = (gamma4*ci*ni_in/qi)**(1._r8/3._r8) - Ri_preice = 0.5_r8/lami ! radius - Ri_preice = max(Ri_preice, 1e-8_r8) ! >0.01micron - call Vpreice(pmid, tair, Ri_preice, Ni_preice, Shom, wpice) - call Vpreice(pmid, tair, Ri_preice, Ni_preice, Shet, wpicehet) - else - wpice = 0.0_r8 - wpicehet = 0.0_r8 - endif - - weff = max(wbar-wpice, minweff) - wpice = min(wpice, wbar) - weffhet = max(wbar-wpicehet,minweff) - wpicehet = min(wpicehet, wbar) - - wbar1 = weff - wbar2 = weffhet - - detaT = wbar/0.23_r8 - if (use_incloud_nuc) then - call frachom(tair, 1._r8, detaT, fhom) - else - call frachom(tair, RHimean, detaT, fhom) - end if - end if - - ni = 0._r8 - tc = tair - 273.15_r8 - - ! initialize - niimm = 0._r8 - nidep = 0._r8 - nihf = 0._r8 - deles = 0._r8 - esi = 0._r8 - regm = 0._r8 - - oso4_num = 0._r8 - odst_num = 0._r8 - osoot_num = 0._r8 - - if ((so4_num >= 1.0e-10_r8 .or. (soot_num+dst_num) >= 1.0e-10_r8) .and. cldn > 0._r8) then - - if (RHimean.ge.1.2_r8) then - - if ( ((tc.le.0.0_r8).and.(tc.ge.-37.0_r8).and.(qc.lt.1.e-12_r8)).or.(tc.le.-37.0_r8)) then - - A = -1.4938_r8 * log(soot_num+dst_num) + 12.884_r8 - B = -10.41_r8 * log(soot_num+dst_num) - 67.69_r8 - regm = A * log(wbar1) + B - - ! heterogeneous nucleation only - if (tc .gt. regm .or. so4_num < 1.0e-10_r8) then - - if(tc.lt.-40._r8 .and. wbar1.gt.1._r8 .and. so4_num >= 1.0e-10_r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation - - call hf(tc,wbar1,relhum*subgrid,so4_num,nihf) - niimm=0._r8 - nidep=0._r8 - - ! If some homogeneous nucleation happened, assume all of the that heterogeneous - ! and coarse mode sulfate particles nucleated. - if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice - niimm = dst_num + soot_num ! assuming dst_num freeze firstly - odst_num = dst_num - osoot_num = soot_num - - oso4_num = nihf - endif - - nihf = nihf * fhom - oso4_num = oso4_num * fhom - - n1 = nihf + niimm - else - - call hetero(tc,wbar2,soot_num+dst_num,niimm,nidep) - - nihf = 0._r8 - n1 = niimm + nidep - - osoot_num = soot_num * (niimm + nidep) / (soot_num + dst_num) - odst_num = dst_num * (niimm + nidep) / (soot_num + dst_num) - endif - - ! homogeneous nucleation only - else if (tc.lt.regm-5._r8 .or. (soot_num+dst_num) < 1.0e-10_r8) then - - call hf(tc,wbar1,relhum*subgrid,so4_num,nihf) - niimm=0._r8 - nidep=0._r8 - - ! If some homogeneous nucleation happened, assume all of the that - ! heterogeneous and coarse mode sulfate particles nucleated. - if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice - niimm = dst_num + soot_num ! assuming dst_num freeze firstly - odst_num = dst_num - osoot_num = soot_num - - oso4_num = nihf - endif - - nihf = nihf * fhom - oso4_num = oso4_num * fhom - - n1 = nihf + niimm - - ! transition between homogeneous and heterogeneous: interpolate in-between - else - - if (tc.lt.-40._r8 .and. wbar1.gt.1._r8) then ! exclude T<-40 & W>1m/s from hetero. nucleation - - call hf(tc, wbar1, relhum*subgrid, so4_num, nihf) - niimm = 0._r8 - nidep = 0._r8 - - ! If some homogeneous nucleation happened, assume all of the - ! that heterogeneous and coarse mode sulfate particles nucleated. - if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice - niimm = dst_num + soot_num ! assuming dst_num freeze firstly - odst_num = dst_num - osoot_num = soot_num - - oso4_num = nihf - endif - - nihf = nihf * fhom - oso4_num = oso4_num * fhom - - n1 = nihf + niimm - - else - - call hf(regm-5._r8,wbar1,relhum*subgrid,so4_num,nihf) - call hetero(regm,wbar2,soot_num+dst_num,niimm,nidep) - - ! If some homogeneous nucleation happened, assume all of the - ! heterogeneous particles nucleated and add in a fraction of - ! the homogeneous freezing. - if (nihf.gt.1e-3_r8) then ! hom occur, add preexisting ice - oso4_num = nihf - endif - - osoot_num = soot_num * (niimm + nidep) / (soot_num + dst_num) - odst_num = dst_num * (niimm + nidep) / (soot_num + dst_num) - - nihf = nihf * fhom * ((regm - tc) / 5._r8)**2 - oso4_num = oso4_num * fhom * ((regm - tc) / 5._r8)**2 - - n1 = niimm + nidep + nihf - - end if - end if - - ! Scale the rates for in-cloud number, since this is what - ! MG is expecting to find. - ni = n1 - - ! If using prexsiting ice, then add it to the total. - if (use_preexisting_ice) then - ni = ni + Ni_preice * 1e-6_r8 - end if - end if - end if - end if - - ! deposition/condensation nucleation in mixed clouds (-37-64 deg) - A22_fast =-6.045_r8 !(T<=-64 deg) - B1_fast =-0.008_r8 - B21_fast =-0.042_r8 !(T>-64 deg) - B22_fast =-0.112_r8 !(T<=-64 deg) - C1_fast =0.0739_r8 - C2_fast =1.2372_r8 - - A1_slow =-0.3949_r8 - A2_slow =1.282_r8 - B1_slow =-0.0156_r8 - B2_slow =0.0111_r8 - B3_slow =0.0217_r8 - C1_slow =0.120_r8 - C2_slow =2.312_r8 - - Ni = 0.0_r8 - - !RHw parameters - A = 6.0e-4_r8*log(ww)+6.6e-3_r8 - B = 6.0e-2_r8*log(ww)+1.052_r8 - C = 1.68_r8 *log(ww)+129.35_r8 - RHw=(A*T*T+B*T+C)*0.01_r8 - - if((T.le.-37.0_r8) .and. ((RH).ge.RHw)) then - - regm = 6.07_r8*log(ww)-55.0_r8 - - if(T.ge.regm) then ! fast-growth regime - - if(T.gt.-64.0_r8) then - A2_fast=A21_fast - B2_fast=B21_fast - else - A2_fast=A22_fast - B2_fast=B22_fast - endif - - k1_fast = exp(A2_fast + B2_fast*T + C2_fast*log(ww)) - k2_fast = A1_fast+B1_fast*T+C1_fast*log(ww) - - Ni = k1_fast*Na**(k2_fast) - Ni = min(Ni,Na) - - else ! slow-growth regime - - k1_slow = exp(A2_slow + (B2_slow+B3_slow*log(ww))*T + C2_slow*log(ww)) - k2_slow = A1_slow+B1_slow*T+C1_slow*log(ww) - - Ni = k1_slow*Na**(k2_slow) - Ni = min(Ni,Na) - - endif - - end if - - end subroutine hf - - !=============================================================================== - - subroutine Vpreice(P_in, T_in, R_in, C_in, S_in, V_out) - - ! based on Karcher et al. (2006) - ! VERTICAL VELOCITY CALCULATED FROM DEPOSITIONAL LOSS TERM - - ! arguments - REAL(r8), INTENT(in) :: P_in ! [Pa],INITIAL AIR pressure - REAL(r8), INTENT(in) :: T_in ! [K] ,INITIAL AIR temperature - REAL(r8), INTENT(in) :: R_in ! [m],INITIAL MEAN ICE CRYSTAL NUMBER RADIUS - REAL(r8), INTENT(in) :: C_in ! [m-3],INITIAL TOTAL ICE CRYSTAL NUMBER DENSITY, [1/cm3] - REAL(r8), INTENT(in) :: S_in ! [-],INITIAL ICE SATURATION RATIO;; if <1, use hom threshold Si - REAL(r8), INTENT(out) :: V_out ! [m/s], VERTICAL VELOCITY REDUCTION (caused by preexisting ice) - - ! parameters - REAL(r8), PARAMETER :: ALPHAc = 0.5_r8 ! density of ice (g/cm3), !!!V is not related to ALPHAc - REAL(r8), PARAMETER :: FA1c = 0.601272523_r8 - REAL(r8), PARAMETER :: FA2c = 0.000342181855_r8 - REAL(r8), PARAMETER :: FA3c = 1.49236645E-12_r8 - REAL(r8), PARAMETER :: WVP1c = 3.6E+10_r8 - REAL(r8), PARAMETER :: WVP2c = 6145.0_r8 - REAL(r8), PARAMETER :: FVTHc = 11713803.0_r8 - REAL(r8), PARAMETER :: THOUBKc = 7.24637701E+18_r8 - REAL(r8), PARAMETER :: SVOLc = 3.23E-23_r8 ! SVOL=XMW/RHOICE - REAL(r8), PARAMETER :: FDc = 249.239822_r8 - REAL(r8), PARAMETER :: FPIVOLc = 3.89051704E+23_r8 - REAL(r8) :: T,P,S,R,C - REAL(r8) :: A1,A2,A3,B1,B2 - REAL(r8) :: T_1,PICE,FLUX,ALP4,CISAT,DLOSS,VICE - - T = T_in ! K , K - P = P_in*1e-2_r8 ! Pa , hpa - - IF (S_in.LT.1.0_r8) THEN - S = 2.349_r8 - (T/259.0_r8) ! homogeneous freezing threshold, according to Ren & McKenzie, 2005 - ELSE - S = S_in ! INPUT ICE SATURATION RATIO, -, >1 - ENDIF - - R = R_in*1e2_r8 ! m => cm - C = C_in*1e-6_r8 ! m-3 => cm-3 - T_1 = 1.0_r8/ T - PICE = WVP1c * EXP(-(WVP2c*T_1)) - ALP4 = 0.25_r8 * ALPHAc - FLUX = ALP4 * SQRT(FVTHc*T) - CISAT = THOUBKc * PICE * T_1 - A1 = ( FA1c * T_1 - FA2c ) * T_1 - A2 = 1.0_r8/ CISAT - A3 = FA3c * T_1 / P - B1 = FLUX * SVOLc * CISAT * ( S-1.0_r8 ) - B2 = FLUX * FDc * P * T_1**1.94_r8 - DLOSS = FPIVOLc * C * B1 * R**2 / ( 1.0_r8+ B2 * R ) - VICE = ( A2 + A3 * S ) * DLOSS / ( A1 * S ) ! 2006,(19) - V_out = VICE*1e-2_r8 ! cm/s => m/s - - end subroutine Vpreice - - !=============================================================================== - - subroutine frachom(Tmean,RHimean,detaT,fhom) - - ! How much fraction of cirrus might reach Shom - ! base on "A cirrus cloud scheme for general circulation models", - ! B. Karcher and U. Burkhardt 2008 - - real(r8), intent(in) :: Tmean, RHimean, detaT - real(r8), intent(out) :: fhom - - real(r8), parameter :: seta = 6132.9_r8 ! K - integer, parameter :: Nbin=200 ! (Tmean - 3*detaT, Tmean + 3*detaT) - - real(r8) :: PDF_T(Nbin) ! temperature PDF; ! PDF_T=0 outside (Tmean-3*detaT, Tmean+3*detaT) - real(r8) :: Sbin(Nbin) ! the fluctuations of Si that are driven by the T variations - real(r8) :: Sihom, deta - integer :: i - - Sihom = 2.349_r8-Tmean/259.0_r8 ! homogeneous freezing threshold, according to Ren & McKenzie, 2005 - fhom = 0.0_r8 - - do i = Nbin, 1, -1 - - deta = (i - 0.5_r8 - Nbin/2)*6.0_r8/Nbin ! PDF_T=0 outside (Tmean-3*detaT, Tmean+3*detaT) - Sbin(i) = RHimean*exp(deta*detaT*seta/Tmean**2.0_r8) - PDF_T(i) = exp(-deta**2.0_r8/2.0_r8)*6.0_r8/(sqrt(2.0_r8*Pi)*Nbin) - - - if (Sbin(i).ge.Sihom) then - fhom = fhom + PDF_T(i) - else - exit - end if - end do - - fhom = min(1.0_r8, fhom/0.997_r8) ! accounting for the finite limits (-3 , 3) - end subroutine frachom - -end module oslo_aero_nucleate_ice diff --git a/src/chemistry/oslo_aero/oslo_aero_ocean.F90 b/src/chemistry/oslo_aero/oslo_aero_ocean.F90 deleted file mode 100644 index e48270ab6a..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_ocean.F90 +++ /dev/null @@ -1,342 +0,0 @@ -module oslo_aero_ocean - - !------------------------------------------------------------------- - ! Marine DMS and POM emissions module - ! Documentation: Implementation of interactive DMS and marine organic - ! emission schemes in NorESM2, Lewinschal, 2015 - ! Manages reading and interpolation of ocean tracer concentrations from file - ! and calculates DMS and marine POM emissions. - ! Parameterisations available: - ! - Nightingale et al. Global biogeochemical cycles 2000 (DMS) - ! - Nilsson, unpublished (POM) - ! - O'Dowd et al. GRL 2008 (POM) - ! - Based on prescribed_volcaero created by Francis Vitt and mo_srf_emissions - !------------------------------------------------------------------- - - use shr_kind_mod, only : r8 => shr_kind_r8 - use ppgrid, only : pcols, pver, pverp, begchunk, endchunk - use constituents, only : cnst_get_ind, cnst_mw !molecular weight for physics constituents - use spmd_utils, only : masterproc - use cam_abortutils, only : endrun - use cam_logfile, only : iulog - use cam_history, only : addfld, add_default, horiz_only, outfld - use camsrfexch, only : cam_in_t - use physics_types, only : physics_state - use physics_buffer, only : physics_buffer_desc - use tracer_data, only : trfld, trfile, trcdata_init, advance_trcdata - ! - use oslo_aero_control, only: oslo_aero_getopts - - implicit none - private - - type :: oceanspc - character(len=16) :: species(1) ! Species name - type(trfld), pointer :: fields(:) ! where the data ends up fields%data - type(trfile) :: file - end type oceanspc - - type(oceanspc), allocatable :: oceanspcs(:) - - ! Public interfaces - public :: oslo_aero_ocean_init ! initializing, reading file - public :: oslo_aero_ocean_time ! time interpolation - public :: oslo_aero_dms_emis ! calculate dms surface emissions - public :: oslo_aero_dms_inq ! logical function which tells mo_srf_emis what to do - public :: oslo_aero_opom_emis ! calculate opom surface emissions - public :: oslo_aero_opom_inq ! logical function which tells oslo_salt what to do - - ! Private interfaces - private:: oslo_aero_ocean_getnl - - - ! These variables are settable via the namelist (with longer names) - ! For reading concentration file - character(len=16) :: dmsl_fld_name = 'dms' !not set from namelist, hard coded, name of nc var - character(len=16) :: dmsk_fld_name = 'dms_Kettle' !not set from namelist, hard coded, name of nc var - character(len=32) :: dms_data_type = 'CYCLICAL' !will be collected from NAMELIST - integer :: dms_cycle_yr = 0 !will be collected from NAMELIST - character(len=20) :: dms_source = 'emission_file' !will be collected from NAMELIST - ! - character(len=16) :: opomo_fld_name = 'chlor_a' !not set from namelist, hard coded, name of nc var - character(len=16) :: opomn_fld_name = 'poc' !not set from namelist, hard coded, name of nc var - character(len=32) :: opom_data_type= 'CYCLICAL' !will be collected from NAMELIST - integer :: opom_cycle_yr = 0 !will be collected from NAMELIST - character(len=20) :: opom_source = 'no_file' !will be collected from NAMELIST - ! - integer :: pndx_fdms !DMS surface flux physics index - integer :: n_ocean_species !Number of variables read from ocean file - character(len=256) :: filename = '' !will be collected from NAMELIST - character(len=256) :: filelist = '' !not needed? - character(len=256) :: datapath = '' !will be collected from NAMELIST - integer :: fixed_ymd = 0 !running one date only? - integer :: fixed_tod = 0 !running one time of day only? - logical :: rmv_file = .false. !delete file when finished with it - -!=============================================================================== -contains -!=============================================================================== - - subroutine oslo_aero_ocean_getnl() - - ! Read oslo namelist variables using oslo_getops - character(len=256) :: in_filename - character(len=256) :: in_datapath - character(len=20) :: in_dms_data_source - character(len=32) :: in_dms_data_type - integer :: in_dms_cycle_yr - character(len=20) :: in_opom_data_source - character(len=32) :: in_opom_data_type - integer :: in_opom_cycle_yr - - ! Initialize namelist variables from local module variables. - in_filename = filename - in_datapath = datapath - in_dms_data_type = dms_data_type - in_dms_cycle_yr = dms_cycle_yr - in_dms_data_source = dms_source - in_opom_data_type = opom_data_type - in_opom_cycle_yr = opom_cycle_yr - in_opom_data_source = opom_source - - ! Read namelist. - call oslo_aero_getopts(dms_source_out = in_dms_data_source, & - dms_source_type_out = in_dms_data_type, & - dms_cycle_year_out = in_dms_cycle_yr, & - opom_source_out = in_opom_data_source, & - opom_source_type_out= in_opom_data_type, & - opom_cycle_year_out = in_opom_cycle_yr, & - ocean_filename_out = in_filename, & - ocean_filepath_out = in_datapath) - - ! Update module variables with user settings. - filename = in_filename - datapath = in_datapath - dms_data_type = in_dms_data_type - dms_cycle_yr = in_dms_cycle_yr - dms_source = in_dms_data_source - opom_data_type= in_opom_data_type - opom_cycle_yr = in_opom_cycle_yr - opom_source = in_opom_data_source - - end subroutine oslo_aero_ocean_getnl - - !=============================================================================== - subroutine oslo_aero_ocean_init() - - ! local variables - integer :: astat - integer :: m - integer :: cycle_yr(2) - character(len=32) :: data_type(2) - character(len=16) :: emis_species(2) - - ! Collect and save namelist information in module - call oslo_aero_ocean_getnl() - - !get physics index for dms surface flux. Index for cflx - call cnst_get_ind('DMS', pndx_fdms, abort=.true.) - - if (dms_source=='lana')then - emis_species(1) = dmsl_fld_name - else - emis_species(1) = dmsk_fld_name - endif - if (opom_source=='odowd')then - emis_species(2) = opomo_fld_name - else - emis_species(2) = opomn_fld_name - endif - cycle_yr(1)= dms_cycle_yr - cycle_yr(2)= opom_cycle_yr - data_type(1) = dms_data_type - data_type(2) = opom_data_type - n_ocean_species = 2 - - if (masterproc) then - write(iulog,*) 'oslo_dms_inti: n_ocean_species = ',n_ocean_species - end if - - allocate( oceanspcs(n_ocean_species), stat=astat ) - if( astat/= 0 ) then - write(iulog,*) 'oslo_dms_inti: failed to allocate oceanspcs array; error = ',astat - call endrun - end if - - ! Setup the oceanspcs type array - ! Add support for selective reading with saved units etc.? - ! one for now... start with dms - do m = 1,n_ocean_species - ! oceanspcs(m)%spc_ndx = emis_indexes(m) ! physics index - ! oceanspcs(m)%units = 'nmol/L' - oceanspcs(m)%species = emis_species(m) ! nc var name - enddo - - ! Ocean concentrations are not stored in pbuf - do m = 1,n_ocean_species - allocate(oceanspcs(m)%file%in_pbuf(1)) - oceanspcs(m)%file%in_pbuf(:) = .false. - - call trcdata_init( oceanspcs(m)%species, filename, filelist, datapath, & - oceanspcs(m)%fields, oceanspcs(m)%file, rmv_file, & - cycle_yr(m), fixed_ymd, fixed_tod, data_type(m) ) - enddo - call addfld( 'odms', horiz_only, 'A', 'nmol/L', 'DMS upper ocean concentration' ) - call add_default('odms', 1, ' ') - - endsubroutine oslo_aero_ocean_init - - !=============================================================================== - subroutine oslo_aero_ocean_time(state, pbuf2d) - - ! arguments - type(physics_state), intent(in) :: state(begchunk:endchunk) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local variables - integer :: m - - do m = 1,n_ocean_species - call advance_trcdata( oceanspcs(m)%fields, oceanspcs(m)%file, state, pbuf2d ) - end do - - endsubroutine oslo_aero_ocean_time - - !=============================================================================== - subroutine oslo_aero_dms_emis(state, cam_in) - - ! arguments - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), target, intent(inout) :: cam_in ! import state - - ! local variables - real(r8) :: u10m(pcols) ![m/s] - real(r8), pointer :: ocnfrc(:) ! [frc] ocean fraction - real(r8), pointer :: icefrc(:) ! [frc] ice fraction - integer :: ncol ! [nbr] number of columns in use - integer :: lchnk ! chunk index - real(r8) :: rk600(pcols) ! ocean/atmos. DMS exchange factor [cm/hr] - real(r8) :: flux(pcols) ! Local flux array: DMS emission rate [kg m-2 s-1] - real(r8) :: odms(pcols) ! Ocean dms concentration [nmol/L] from file - real(r8) :: open_ocn(pcols) ! Open Ocean - real(r8) :: t(pcols) - real(r8) :: scdms(pcols) - real(r8) :: kwdms(pcols) - real(r8), parameter :: z0= 0.0001_r8 ! [m] roughness length over ocean - real(r8), parameter :: Xconvxa= 6.97e-07 ! Wanninkhof's a=0.251 converted to ms-1/(ms-1)^2 - logical , parameter :: method_oslo = .false. - logical , parameter :: method_hamocc = .true. - - !pointers to land model variables - ocnfrc => cam_in%ocnfrac - icefrc => cam_in%icefrac - ncol = state%ncol - lchnk = state%lchnk - - if (dms_source=='lana' .or. dms_source=='kettle') then - - ! if concentration file - obtain dms data from file - flux(:) = 0._r8 - odms(:) = 0._r8 - odms(:ncol) = oceanspcs(1)%fields(1)%data(:ncol,1,lchnk) - - ! open ocean - open_ocn(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) - - !start with midpoint wind speed - u10m(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) - - if (method_oslo) then - ! move the winds to 10m high from the midpoint of the gridbox: - u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) - rk600(:ncol) = (0.222_r8*(u10m(:ncol)*u10m(:ncol))) + (0.333_r8*u10m(:ncol)) ! [cm/hr] - flux (:ncol) = 2.778e-15*cnst_mw(pndx_fdms)*rk600(:ncol)*open_ocn(:ncol)*odms(:ncol) ! [kg m-2 s-1] - else if (method_hamocc) then - t(:ncol)=cam_in%sst(:ncol)-273.15_r8 - u10m (:ncol) = u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) - scdms(:ncol) = 2855.7+ (-177.63 + (6.0438 + (-0.11645 + 0.00094743*t(:ncol))*t(:ncol))*t(:ncol))*t(:ncol) - kwdms(:ncol) = open_ocn(:ncol) * Xconvxa *u10m(:ncol)**2*(660./scdms(:ncol))**0.5 - flux (:ncol) = 62.13*kwdms(:ncol)*1e-9*odms(:ncol) - endif - cam_in%cflx(:ncol, pndx_fdms ) = flux(:ncol) - - call outfld('odms', odms(:ncol), ncol, lchnk) - - elseif (dms_source=='ocean_flux') then - - ! if ocean flux - cam_in%cflx(:ncol, pndx_fdms) = cam_in%fdms(:ncol) - endif - - ! IF EMISSION FILE - ! return without changing cflx - - endsubroutine oslo_aero_dms_emis - - !=============================================================================== - subroutine oslo_aero_opom_emis(em_ss1,em_ss2,em_ss3,open_ocn,ncol,lchnk, opomem_out) - - ! arguments - integer , intent(in) :: ncol ![nbr] number of columns in use - integer , intent(in) :: lchnk !current chunk - real(r8), intent(in) :: em_ss1(pcols) !sea salt emission mode a1 - real(r8), intent(in) :: em_ss2(pcols) !sea salt emission mode a2 - real(r8), intent(in) :: em_ss3(pcols) !sea salt emission mode a3 - real(r8), intent(in) :: open_ocn(pcols) !open ocean - real(r8), intent(out) :: opomem_out(pcols) !ocean POM emission rate [kg m-2 s-1] - - ! local variables - real(r8) :: omFrac(ncol) ! OM fraction of total seaspray mass - real(r8) :: ochlor(ncol) ! Ocean chlorophyll concentration [nmol/L] - real(r8) :: flux(ncol) ! Local flux array: ocean POM emission rate [kg m-2 s-1] - - ! Variables for Nilsson parameterisation - real(r8), parameter :: c_n = 0.000507456_r8 ! OM tuning constant (Tuned for NorESM2) - real(r8), parameter :: c_a1 = 2.06_r8 ! OM fraction in a1 mode - real(r8), parameter :: c_a2 = 0.355_r8 ! OM fraction in a2 mode - real(r8), parameter :: c_a3 = 0.0623_r8 ! OM fraction in a3 mode - real(r8), parameter :: c_o = 0.5238_r8 ! Arbritraty scaling factor to make the emissions match Spracklen. - real(r8) :: opoc(ncol) ! Ocean POC concentration [mg m-3] - - if (opom_source=='nilsson') then - ! Nilsson parameterisation - collect POC data from file - flux(:) = 0._r8 - opoc(:) = 0._r8 - opoc(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) - flux(:ncol) = c_n*open_ocn(:ncol)*opoc(:ncol)* (c_a1*em_ss1(:ncol)+c_a2*em_ss2(:ncol)+c_a3*em_ss3(:ncol)) - opomem_out(:ncol) = flux(:ncol) - - elseif (opom_source=='odowd') then - ! O'Dowd parameterisation - collect dms data from file - flux(:) = 0._r8 - ochlor(:) = 0._r8 - ochlor(:ncol) = oceanspcs(2)%fields(1)%data(:ncol,1,lchnk) - - ! OM fraction saturates at 90% according to O'Dowd 2008 - omFrac(:ncol) = min(0.01_r8*(43.5_r8 * ochlor(:ncol) + 13.805_r8),0.76_r8) - omFrac(:ncol) = omFrac(:ncol) / (1._r8 - omFrac(:ncol)) - flux(:ncol) = c_o*omFrac(:ncol) * em_ss1(:ncol) - opomem_out(:ncol) = flux(:ncol) - endif - - end subroutine oslo_aero_opom_emis - - !=============================================================================== - logical function oslo_aero_dms_inq() - if (dms_source =='emission_file') then - oslo_aero_dms_inq = .true. - else - oslo_aero_dms_inq = .false. - endif - end function oslo_aero_dms_inq - - !=============================================================================== - logical function oslo_aero_opom_inq() - if (opom_source=='nilsson' .or. opom_source=='odowd') then - oslo_aero_opom_inq = .true. - else - oslo_aero_opom_inq = .false. - endif - end function oslo_aero_opom_inq - -end module oslo_aero_ocean diff --git a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 b/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 deleted file mode 100644 index c0ce77ff69..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_optical_params.F90 +++ /dev/null @@ -1,526 +0,0 @@ -module oslo_aero_optical_params - - ! Optical parameters for a composite aerosol is calculated by interpolation - ! from the tables kcomp1.out-kcomp14.out. - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver, pverp - use constituents, only: pcnst - use cam_history, only: outfld - use physconst, only: rair,pi - use physics_types, only: physics_state - use wv_saturation, only: qsat_water - ! - use oslo_aero_utils, only: calculateNumberConcentration - use oslo_aero_conc, only: calculateBulkProperties, partitionMass - use oslo_aero_sw_tables - use oslo_aero_params - use oslo_aero_const - use oslo_aero_share - - implicit none - private - - public :: oslo_aero_optical_params_calc - -!=============================================================================== -contains -!=============================================================================== - - subroutine oslo_aero_optical_params_calc(lchnk, ncol, pint, pmid, & - coszrs, state, t, cld, qm1, Nnatk, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, volc_ext_earth, volc_omega_earth, & - aodvis, absvis) - - ! Input arguments - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - real(r8), intent(in) :: coszrs(pcols) ! Cosine solar zenith angle - real(r8), intent(in) :: pint(pcols,pverp) ! Model interface pressures (10*Pa) - real(r8), intent(in) :: pmid(pcols,pver) ! Model level pressures (Pa) - real(r8), intent(in) :: t(pcols,pver) ! Model level temperatures (K) - real(r8), intent(in) :: cld(pcols,pver) ! cloud fraction - real(r8), intent(in) :: qm1(pcols,pver,pcnst) ! Specific humidity and tracers (kg/kg) - real(r8), intent(in) :: volc_ext_sun(pcols,pver,nbands) ! volcanic aerosol extinction for solar bands, CMIP6 - real(r8), intent(in) :: volc_omega_sun(pcols,pver,nbands) ! volcanic aerosol SSA for solar bands, CMIP6 - real(r8), intent(in) :: volc_g_sun(pcols,pver,nbands) ! volcanic aerosol g for solar bands, CMIP6 - real(r8), intent(in) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 - real(r8), intent(in) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 - type(physics_state), intent(in), target :: state - - ! Input-output arguments - real(r8), intent(inout) :: Nnatk(pcols,pver,0:nmodes) ! aerosol mode number concentration - - ! Output arguments - ! AOD and absorptive AOD for visible wavelength closest to 0.55 um (0.442-0.625) - ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values - real(r8), intent(out) :: per_tau (pcols,0:pver,nbands) ! aerosol extinction optical depth - real(r8), intent(out) :: per_tau_w (pcols,0:pver,nbands) ! aerosol single scattering albedo * tau - real(r8), intent(out) :: per_tau_w_g(pcols,0:pver,nbands) ! aerosol assymetry parameter * w * tau - real(r8), intent(out) :: per_tau_w_f(pcols,0:pver,nbands) ! aerosol forward scattered fraction * w * tau - real(r8), intent(out) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optical depth (LW) - real(r8), intent(out) :: aodvis(pcols) ! AOD vis - real(r8), intent(out) :: absvis(pcols) ! AAOD vis - - ! Local variables - integer :: i, k, ib, icol, mplus10 - integer :: iloop - logical :: daylight(pcols) ! SW calculations also at (polar) night in interpol* if daylight=.true. - real(r8) :: aodvisvolc(pcols) ! AOD vis for CMIP6 volcanic aerosol - real(r8) :: absvisvolc(pcols) ! AAOD vis for CMIP6 volcanic aerosol - real(r8) :: bevisvolc(pcols,pver) ! Extinction in vis wavelength band for CMIP6 volcanic aerosol - real(r8) :: rhum(pcols,pver) ! (trimmed) relative humidity for the aerosol calculations - real(r8) :: deltah_km(pcols,pver) ! Layer thickness, unit km - real(r8) :: deltah, airmassl(pcols,pver), airmass(pcols) !akc6 - real(r8) :: Ca(pcols,pver), f_c(pcols,pver), f_bc(pcols,pver), f_aq(pcols,pver) - real(r8) :: fnbc(pcols,pver), faitbc(pcols,pver), f_so4_cond(pcols,pver) - real(r8) :: f_soa(pcols,pver),f_soana(pcols,pver) - real(r8) :: v_soana(pcols,pver) - real(r8) :: dCtot(pcols,pver), Ctot(pcols,pver) - real(r8) :: Cam(pcols,pver,nbmodes), fbcm(pcols,pver,nbmodes), fcm(pcols,pver,nbmodes) - real(r8) :: faqm(pcols,pver,nbmodes), f_condm(pcols,pver,nbmodes) - real(r8) :: f_soam(pcols, pver,nbmodes), faqm4(pcols,pver) - real(r8) :: focm(pcols,pver,4) - real(r8) :: ssa(pcols,pver,0:nmodes,nbands), asym(pcols,pver,0:nmodes,nbands) - real(r8) :: be(pcols,pver,0:nmodes,nbands), ke(pcols,pver,0:nmodes,nbands) - real(r8) :: betotvis(pcols,pver), batotvis(pcols,pver) - real(r8) :: ssatot(pcols,pver,nbands) ! spectral aerosol single scattering albedo - real(r8) :: asymtot(pcols,pver,nbands) ! spectral aerosol asymmetry factor - real(r8) :: betot(pcols,pver,nbands) ! spectral aerosol extinction coefficient - real(r8) :: batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW - real(r8) :: kalw(pcols,pver,0:nmodes,nlwbands) - real(r8) :: balw(pcols,pver,0:nmodes,nlwbands) - real(r8) :: volc_balw(pcols,0:pver,nlwbands) ! volcanic aerosol absorption coefficient for terrestrial bands, CMIP6 - real(r8) :: rh0(pcols,pver), rhoda(pcols,pver) - real(r8) :: ssavis(pcols,pver), asymmvis(pcols,pver), extvis(pcols,pver), dayfoc(pcols,pver) - real(r8) :: n_aer(pcols,pver) - real(r8) :: es(pcols,pver) ! saturation vapor pressure - real(r8) :: qs(pcols,pver) ! saturation specific humidity - real(r8) :: rht(pcols,pver) ! relative humidity (fraction) (rh is already used in opptab) - real(r8) :: rh_temp(pcols,pver) ! relative humidity (fraction) for input to LUT - real(r8) :: xrh(pcols,pver) - integer :: irh1(pcols,pver) - real(r8) :: xfombg(pcols,pver) - integer :: ifombg1(pcols,pver), ifombg2(pcols,pver) - real(r8) :: xct(pcols,pver,nmodes) - integer :: ict1(pcols,pver,nmodes) - real(r8) :: xfac(pcols,pver,nbmodes) - integer :: ifac1(pcols,pver,nbmodes) - real(r8) :: xfbc(pcols,pver,nbmodes) - integer :: ifbc1(pcols,pver,nbmodes) - real(r8) :: xfaq(pcols,pver,nbmodes) - integer :: ifaq1(pcols,pver,nbmodes) - real(r8) :: xfbcbg(pcols,pver) - integer :: ifbcbg1(pcols,pver) - real(r8) :: xfbcbgn(pcols,pver) - integer :: ifbcbgn1(pcols,pver) - logical :: lw_on ! LW calculations are performed in interpol* if true - !------------------------------------------------------------------------- - - ! calculate relative humidity for table lookup into rh grid - call qsat_water(state%t(1:ncol,1:pver), state%pmid(1:ncol,1:pver), es(1:ncol,1:pver), qs(1:ncol,1:pver)) - - rht(1:ncol,1:pver) = state%q(1:ncol,1:pver,1) / qs(1:ncol,1:pver) - rh_temp(1:ncol,1:pver) = min(rht(1:ncol,1:pver),1._r8) - - do k=1,pver - do icol=1,ncol - ! Set upper and lower relative humidity for the aerosol calculations - rhum(icol,k) = min(0.995_r8, max(rh_temp(icol,k), 0.01_r8)) - rhoda(icol,k) = pmid(icol,k)/(rair*t(icol,k)) ! unit kg/m^3 - if (cld(icol,k) .lt. 1.0_r8) then - rhum(icol,k) = (rhum(icol,k) - cld(icol,k)) / (1.0_r8 - cld(icol,k)) ! clear portion - end if - rhum(icol,k) = min(0.995_r8, max(rhum(icol,k), 0.01_r8)) - end do - end do - - ! Layer thickness with unit km - do icol=1,ncol - do k=1,pver - deltah_km(icol,k)=1.e-4_r8*(pint(icol,k+1)-pint(icol,k))/(rhoda(icol,k)*9.8_r8) - end do - end do - - ! interpol-calculations only when daylight or not: - do icol=1,ncol - if (coszrs(icol) > 0.0_r8) then - daylight(icol) = .true. - else - daylight(icol) = .false. - endif - end do - - ! Set SO4, BC and OC concentrations: - - ! initialize concentration fields - do i=0,nmodes - do k=1,pver - do icol=1,ncol - Nnatk(icol,k,i) = 0.0_r8 - end do - end do - end do - do k=1,pver - do icol=1,ncol - n_aer(icol,k) = 0.0_r8 - end do - end do - kalw(:,:,:,:)=0._r8 - be(:,:,:,:)=0._r8 - ke(:,:,:,:)=0._r8 - asym(:,:,:,:)=0._r8 - ssa(:,:,:,:)=0._r8 - ! Find process tagged bulk aerosol properies (from the life cycle module): - - call calculateBulkProperties(ncol, qm1, rhoda, Nnatk, Ca, f_c, f_bc, & - f_aq, f_so4_cond, f_soa, faitbc, fnbc, f_soana) - - ! calculating vulume fractions from mass fractions: - do k=1,pver - do icol=1,ncol - v_soana(icol,k) = f_soana(icol,k)/(f_soana(icol,k) & - +(1.0_r8-f_soana(icol,k))*rhopart(l_soa_na)/rhopart(l_so4_na)) - end do - end do - - ! Avoid very small numbers - do k=1,pver - do icol=1,ncol - Ca(icol,k) = max(eps,Ca(icol,k)) - f_c(icol,k) = max(eps,f_c(icol,k)) - f_bc(icol,k) = max(eps,f_bc(icol,k)) - f_aq(icol,k) = max(eps,f_aq(icol,k)) - fnbc(icol,k) = max(eps,fnbc(icol,k)) - faitbc(icol,k) = max(eps,faitbc(icol,k)) - end do - end do - - ! Calculation of the apportionment of internally mixed SO4, BC and OC - ! mass between the various background modes. - - !==> calls modalapp to partition the mass - call partitionMass(ncol, nnatk, Ca, f_c, f_bc, f_aq, f_so4_cond, f_soa , & - cam, fcm, fbcm, faqm, f_condm, f_soam ) - - !The following uses non-standard units, #/cm3 and ug/m3 - Nnatk(:ncol,:,:) = Nnatk(:ncol,:,:)*1.e-6_r8 - cam(:ncol,:,:)=cam(:ncol,:,:)*1.e9_r8 - - ! Calculate fraction of added mass which is either SOA condensate or OC coagulate, - ! which in AeroTab are both treated as condensate for kcomp=1-4. - do i=1,4 - do k=1,pver - do icol=1,ncol - focm(icol,k,i) = fcm(icol,k,i)*(1.0_r8-fbcm(icol,k,i)) - enddo - enddo - enddo - do k=1,pver - do icol=1,ncol - faqm4(icol,k) = faqm(icol,k,4) - end do - enddo - - ! find common input parameters for use in the interpolation routines - call inputForInterpol (lchnk, ncol, rhum, xrh, irh1, & - f_soana, xfombg, ifombg1, faitbc, xfbcbg, ifbcbg1, & - fnbc, xfbcbgn, ifbcbgn1, Nnatk, Cam, xct, ict1, & - focm, fcm, xfac, ifac1, fbcm, xfbc, ifbc1, faqm, xfaq, ifaq1) - - ! (Wet) Optical properties for each of the aerosol modes: - lw_on = .true. ! No LW optics needed for RH=0 (interpol returns 0-values) - - ! BC(ax) mode (dry only): - call interpol0 (lchnk, ncol, daylight, Nnatk, ssa, asym, be, ke, lw_on, kalw) - - mplus10=0 - ! SO4/SOA(Ait) mode: - call interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xfombg, ifombg1, xct, ict1, & - xfac, ifac1, ssa, asym, be, ke, lw_on, kalw) - - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - - ! BC&OC(Ait) mode: ------ fcm invalid here (=0). Using faitbc instead - call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xfbcbg, ifbcbg1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - - ! SO4(Ait75) (5), Mineral (6-7) and Sea-salt (8-10) modes: - call interpol5to10 (lchnk, ncol, daylight, xrh, irh1, & - Nnatk, xct, ict1, xfac, ifac1, & - xfbc, ifbc1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - - ! total aerosol number concentrations - do i=0,nmodes ! mode 0 to 14 - do k=1,pver - do icol=1,ncol - n_aer(icol,k)=n_aer(icol,k)+Nnatk(icol,k,i) - end do - enddo - enddo - call outfld('N_AER ',n_aer ,pcols,lchnk) - - mplus10=1 - ! SO4/SOA(Ait) mode: - !does no longer exist as an externally mixed mode - - ! BC(Ait) and OC(Ait) modes: - call interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xct, ict1, xfac, ifac1, & - ssa, asym, be, ke, lw_on, kalw) - - ! BC&OC(n) mode: ------ fcm not valid here (=0). Use fnbc instead - call interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, & - Nnatk, xfbcbgn, ifbcbgn1, xct, ict1, & - xfac, ifac1, xfaq, ifaq1, ssa, asym, be, ke, lw_on, kalw) - - do k=1,pver - do icol=1,ncol - Ctot(icol,k)=0.0_r8 - end do - enddo - - do i=0,nmodes ! mode 0 to 14 - do k=1,pver - do icol=1,ncol - dCtot(icol,k)=1.e3_r8*be(icol,k,i,4)/(ke(icol,k,i,4)+eps) - Ctot(icol,k)=Ctot(icol,k)+dCtot(icol,k)*Nnatk(icol,k,i) - end do - enddo - enddo - - ! SW Optical properties of total aerosol: - do ib=1,nbands - do k=1,pver - do icol=1,ncol - betot(icol,k,ib)=0.0_r8 - ssatot(icol,k,ib)=0.0_r8 - asymtot(icol,k,ib)=0.0_r8 - end do - enddo - enddo - do ib=1,nbands - do i=0,nmodes - do k=1,pver - do icol=1,ncol - betot(icol,k,ib)=betot(icol,k,ib)+Nnatk(icol,k,i)*be(icol,k,i,ib) - ssatot(icol,k,ib)=ssatot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib) - asymtot(icol,k,ib)=asymtot(icol,k,ib)+Nnatk(icol,k,i) & - *be(icol,k,i,ib)*ssa(icol,k,i,ib)*asym(icol,k,i,ib) - end do - enddo - enddo - enddo - - ! Adding also the volcanic contribution (CMIP6), which is using a CMIP6 - ! band numbering identical to the AeroTab numbering (unlike CAM) both - ! for SW and LW. I.e., no remapping is required here. - ! Info from CMIP_CAM6_radiation_v3.nc - ! wl1_sun = 0.2, 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, - ! 1.2987, 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615 ; - ! wl2_sun = 0.263158, 0.344828, 0.441501, 0.625, 0.77821, 1.24224, 1.2987, - ! 1.62602, 1.94175, 2.15054, 2.5, 3.07692, 3.84615, 12.1951 ; - ! wl1_earth = 3.07692, 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, - ! 7.19424, 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714 ; - ! wl2_earth = 3.84615, 4.20168, 4.44444, 4.80769, 5.55556, 6.75676, 7.19424, - ! 8.47458, 9.25926, 10.2041, 12.1951, 14.2857, 15.873, 20, 28.5714, 1000 ; - do ib=1,nbands - betot(1:ncol,1:pver,ib) = betot(1:ncol,1:pver,ib) & - + volc_ext_sun(1:ncol,1:pver,ib) - ssatot(1:ncol,1:pver,ib) = ssatot(1:ncol,1:pver,ib) & - + volc_ext_sun(1:ncol,1:pver,ib)*volc_omega_sun(1:ncol,1:pver,ib) - asymtot(1:ncol,1:pver,ib) = asymtot(1:ncol,1:pver,ib) & - + volc_ext_sun(1:ncol,1:pver,ib)*volc_omega_sun(1:ncol,1:pver,ib) & - *volc_g_sun(1:ncol,1:pver,ib) - enddo - bevisvolc(1:ncol,1:pver) = volc_ext_sun(1:ncol,1:pver,4) - - ! and then calculate the total bulk optical parameters - do ib=1,nbands - do k=1,pver - do icol=1,ncol - ssatot(icol,k,ib)=ssatot(icol,k,ib)/(betot(icol,k,ib)+eps) - asymtot(icol,k,ib)=asymtot(icol,k,ib) & - /(betot(icol,k,ib)*ssatot(icol,k,ib)+eps) - end do - enddo - enddo - - !------------------------------------------------------------------------------------------------ - ! Replace CAM5 standard aerosol optics with CAM5-Oslo optics (except top layer: no aerosol) - ! Remapping from AeroTab to CAM5 SW bands, see p. 167 in the CAM5.0 description: - ! CAM5 bands AeroTab bands - ! 14 3.846 12.195 14 - ! 1 3.077 3.846 13 - ! 2 2.500 3.077 12 - ! 3 2.150 2.500 11 - ! 4 1.942 2.150 10 - ! 5 1.626 1.942 9 - ! 6 1.299 1.626 8 - ! 7 1.242 1.299 7 - ! 8 0.778 1.242 6 - ! 9 0.625 0.778 5 - ! 10 0.442 0.625 4 - ! 11 0.345 0.442 3 - ! 12 0.263 0.345 2 - ! 13 0.200 0.263 1 - - do i=1,ncol ! zero aerosol in the top layer - do ib=1,14 ! 1-nbands - per_tau(i,0,ib)= 0._r8 - per_tau_w(i,0,ib)= 0.999_r8 - per_tau_w_g(i,0,ib)= 0.5_r8 - per_tau_w_f(i,0,ib)= 0.25_r8 - end do - do ib=1,14 ! initialize also for the other layers - do k=1,pver - per_tau(i,k,ib)= 0._r8 - per_tau_w(i,k,ib)= 0.999_r8 - per_tau_w_g(i,k,ib)= 0.5_r8 - per_tau_w_f(i,k,ib)= 0.25_r8 - end do - end do - end do - ! Remapping of SW wavelength bands from AeroTab to CAM5 - do i=1,ncol - do ib=1,13 - do k=1,pver - per_tau(i,k,ib)=deltah_km(i,k)*betot(i,k,14-ib) - per_tau_w(i,k,ib)=per_tau(i,k,ib)*max(min(ssatot(i,k,14-ib),0.999999_r8),1.e-6_r8) - per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,14-ib) - per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,14-ib) - end do - end do - ib=14 - do k=1,pver - per_tau(i,k,ib)=deltah_km(i,k)*betot(i,k,ib) - per_tau_w(i,k,ib)=per_tau(i,k,ib)*max(min(ssatot(i,k,ib),0.999999_r8),1.e-6_r8) - per_tau_w_g(i,k,ib)=per_tau_w(i,k,ib)*asymtot(i,k,ib) - per_tau_w_f(i,k,ib)=per_tau_w_g(i,k,ib)*asymtot(i,k,ib) - end do - end do ! ncol - !------------------------------------------------------------------------------------------------ - - ! LW Optical properties of total aerosol: - do ib=1,nlwbands - do k=1,pver - do icol=1,ncol - batotlw(icol,k,ib)=0.0_r8 - end do - enddo - enddo - do ib=1,nlwbands - do i=0,nmodes - do k=1,pver - do icol=1,ncol - balw(icol,k,i,ib)=kalw(icol,k,i,ib)*(be(icol,k,i,4)/(ke(icol,k,i,4)+eps)) - batotlw(icol,k,ib)=batotlw(icol,k,ib)+Nnatk(icol,k,i)*balw(icol,k,i,ib) - end do - enddo - enddo - enddo - - ! Adding also the volcanic contribution (CMIP6), which is also using - ! AeroTab band numbering, so that a remapping is required here - do ib=1,nlwbands - volc_balw(1:ncol,1:pver,ib) = volc_ext_earth(:ncol,1:pver,ib) & - *(1.0_r8-volc_omega_earth(:ncol,1:pver,ib)) - batotlw(1:ncol,1:pver,ib)=batotlw(1:ncol,1:pver,ib)+volc_balw(1:ncol,1:pver,ib) - enddo - - ! Remapping of LW wavelength bands from AeroTab to CAM5 - do ib=1,nlwbands - do i=1,ncol - do k=1,pver - per_lw_abs(i,k,ib)=deltah_km(i,k)*batotlw(i,k,17-ib) - ! if(ib.eq.1.and.k.eq.pver.and.i.eq.1) then - ! write(*,*) 'per_lw_abs =', per_lw_abs(i,k,ib) - ! endif - end do - end do - end do - - ! APPROXIMATE aerosol extinction and absorption at 550nm (0.442-0.625 um) - ! (in the visible wavelength band) - do k=1,pver - do icol=1,ncol - betotvis(icol,k)=betot(icol,k,4) - batotvis(icol,k)=betotvis(icol,k)*(1.0-ssatot(icol,k,4)) - end do - enddo - - do k=1,pver - do icol=1,ncol - ssavis(icol,k) = 0.0_r8 - asymmvis(icol,k) = 0.0_r8 - extvis(icol,k) = 0.0_r8 - dayfoc(icol,k) = 0.0_r8 - enddo - end do - - do k=1,pver - do icol=1,ncol - ! dayfoc < 1 when looping only over gridcells with daylight - if(daylight(icol)) then - dayfoc(icol,k) = 1.0_r8 - ! with the new bands in CAM5, band 4 is now at ca 0.5 um (0.442-0.625) - ssavis(icol,k) = ssatot(icol,k,4) - asymmvis(icol,k) = asymtot(icol,k,4) - extvis(icol,k) = betot(icol,k,4) - endif - enddo - end do - - ! optical parameters in visible light (0.442-0.625um) - call outfld('SSAVIS ',ssavis,pcols,lchnk) - call outfld('ASYMMVIS',asymmvis,pcols,lchnk) - call outfld('EXTVIS ',extvis,pcols,lchnk) - call outfld('DAYFOC ',dayfoc,pcols,lchnk) - - ! Initialize fields - do icol=1,ncol - aodvis(icol)=0.0_r8 - absvis(icol)=0.0_r8 - aodvisvolc(icol)=0.0_r8 - absvisvolc(icol)=0.0_r8 - airmass(icol)=0.0_r8 !akc6 - enddo - - do icol=1,ncol - if(daylight(icol)) then - do k=1,pver - ! Layer thickness, unit km, and layer airmass, unit kg/m2 - deltah=deltah_km(icol,k) - airmassl(icol,k)=1.e3_r8*deltah*rhoda(icol,k) - airmass(icol)=airmass(icol)+airmassl(icol,k) !akc6 - - ! Optical depths at ca. 550 nm (0.442-0.625um) all aerosols - aodvis(icol)=aodvis(icol)+betotvis(icol,k)*deltah - absvis(icol)=absvis(icol)+batotvis(icol,k)*deltah - - ! Optical depths at ca. 550 nm (0.442-0.625um) CMIP6 volcanic aerosol - aodvisvolc(icol)=aodvisvolc(icol)+volc_ext_sun(icol,k,4)*deltah - absvisvolc(icol)=absvisvolc(icol)+volc_ext_sun(icol,k,4) & - *(1.0_r8-volc_omega_sun(icol,k,4))*deltah - - end do ! k - endif ! daylight - end do ! icol - - ! Extinction and absorption for 0.55 um for the total aerosol, and AODs - call outfld('AOD_VIS ',aodvis ,pcols,lchnk) - call outfld('ABSVIS ',absvis ,pcols,lchnk) - call outfld('AODVVOLC',aodvisvolc ,pcols,lchnk) - call outfld('ABSVVOLC',absvisvolc ,pcols,lchnk) - call outfld('BVISVOLC',bevisvolc ,pcols,lchnk) - - end subroutine oslo_aero_optical_params_calc - -end module oslo_aero_optical_params diff --git a/src/chemistry/oslo_aero/oslo_aero_params.F90 b/src/chemistry/oslo_aero/oslo_aero_params.F90 deleted file mode 100644 index f612b2845f..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_params.F90 +++ /dev/null @@ -1,79 +0,0 @@ -module oslo_aero_params - - !--------------------------------------------------------------------------------- - ! Module for aerosol hygroscopicities and dry size parameters which are common - ! in AeroTab and CAM5-Oslo. Note: This file is not yet linked with AeroTab, so - ! make sure that the look-up tables made with AeroTab (optics and the dry size - ! parameters for modified size distributions) are based on the same version of - ! commondefinitions.F90. - !--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - - implicit none - public - - ! Define some aerosol types and their properties.. - integer, parameter, public :: N_AEROSOL_TYPES = 5 - integer, parameter, public :: AEROSOL_TYPE_SULFATE = 1 - integer, parameter, public :: AEROSOL_TYPE_BC = 2 - integer, parameter, public :: AEROSOL_TYPE_OM = 3 - integer, parameter, public :: AEROSOL_TYPE_DUST = 4 - integer, parameter, public :: AEROSOL_TYPE_SALT = 5 - - ! NUMBERS BELOW ARE ESSENTIAL TO CALCULATE HYGROSCOPICITY AND THEREFORE INDIRECT EFFECT! - ! These numbers define the "hygroscopicity parameter" Numbers are selected so that they give reasonable hygroscipity - ! note that changing numbers individually changes the hygroscopicity! - ! Hygroscopicity is defined in Abdul-Razzak and S. Ghan: (B in their eqn 4) - ! A parameterization of aerosol activation 2. Multiple aerosol types, JGR, vol 105, noD5, pp 6837 - ! http://onlinelibrary.wiley.com/doi/10.1029/1999JD901161/abstract - ! - ! Further note that changing any of these numbers without changing aerotab will lead to - ! inconsistencies in the simulation since Aerotab tabulates hygroscopical growth! - ! - ! Main reference for numbers chosen: Ghan et al MIRAGE paper (JRG, vol 106, D6, pp 5295), 2001 References: - ! SULFATE : Using same numbers as MIRAGE paper (ammonium sulfate) - ! BC : Does not really matter as long as soluble mass fraction is small - ! However, numbers below reproduces values from MIRAGE paper - ! New mass density (October 2016) is based on Bond and Bergstrom (2007): Light Absorption - ! by Carbonaceous Particles: An Investigative Review, Aerosol Science and Technology, 40:27•¡¹67. - ! OM : Soluble mass fraction tuned to give B of MIRAGE Paper - ! DUST : The numbers give B of ~ 0.07 (high end of Kohler, Kreidenweis et al, GRL, vol 36, 2009. - ! (10% as soluble mass fraction seems reasonable) - ! (see also Osada et al, Atmospheric Research, vol 124, 2013, pp 101 - ! SEA SALT: Soluble mass fraction tuned to give consistent values for (r/r0) at 99% when using the parametrization in - ! Koepke, Hess, Schult and Shettle: Max-Plack-Institut fur Meteorolgie, report No. 243 "GLOBAL AEROSOL DATA SET" - ! These values give "B" of 1.20 instead of 1.16 in MIRAGE paper. - - character(len=8) :: aerosol_type_name(N_AEROSOL_TYPES) = & - (/"SULFATE ", "BC ","OM ", "DUST ", "SALT " /) - real(r8) :: aerosol_type_density(N_AEROSOL_TYPES) = & - (/1769.0_r8, 1800.0_r8, 1500.0_r8, 2600.0_r8, 2200.0_r8 /) !kg/m3 - real(r8) :: aerosol_type_molecular_weight(N_AEROSOL_TYPES) = & - (/132.0_r8, 12.0_r8, 168.2_r8, 135.0_r8, 58.44_r8 /) !kg/kmol - real(r8) :: aerosol_type_osmotic_coefficient(N_AEROSOL_TYPES) = & - (/0.7_r8, 1.111_r8, 1.0_r8, 1.0_r8, 1.0_r8 /) ![-] - real(r8) :: aerosol_type_soluble_mass_fraction(N_AEROSOL_TYPES) = & - (/1.0_r8, 1.67e-7_r8, 0.8725_r8, 0.1_r8, 0.885_r8 /) ![-] - real(r8) :: aerosol_type_number_of_ions(N_AEROSOL_TYPES) = & - (/3.0_r8, 1.0_r8, 1.0_r8, 2.0_r8, 2.0_r8 /) ![-] - - ! Define lognormal size parameters for each size mode (dry, at point of emission/production) - integer, parameter :: nmodes = 14 - integer, parameter :: nbmodes = 10 - - ! Number median radius of background emissions THESE DO NOT ASSUME IMPLICIT GROWTH!! - real(r8), parameter :: originalNumberMedianRadius(0:nmodes) = & - 1.e-6_r8* (/ 0.0626_r8, & !0 - 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8, 0.075_r8, & !1-5 - 0.22_r8, 0.63_r8, 0.0475_r8, 0.30_r8, 0.75_r8, & !6-10 ! SS: Salter et al. (2015) - 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8 /) !11-14 - - ! sigma of background aerosols ) - real(r8), parameter :: originalSigma(0:nmodes) = & - (/1.6_r8, & !0 - 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8, 1.59_r8, & !1-5 - 1.59_r8, 2.0_r8, 2.1_r8, 1.72_r8, 1.60_r8, & !6-10 ! SS: Salter et al. (2015) - 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 /) !11-14 - -end module oslo_aero_params diff --git a/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 b/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 deleted file mode 100644 index 77944a529d..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_seasalt.F90 +++ /dev/null @@ -1,148 +0,0 @@ -module oslo_aero_seasalt - - !----------------------------------------------------------------------- - ! compute emission of sea salt - !----------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8, cl => shr_kind_cl - use ppgrid, only: pcols, pver - use constituents, only: cnst_name - use camsrfexch, only: cam_in_t - use physics_types, only: physics_state - ! - use oslo_aero_const, only: volumeToNumber - use oslo_aero_ocean, only: oslo_aero_opom_inq, oslo_aero_opom_emis - use oslo_aero_share, only: rhopart, l_om_ni, l_ss_a1, l_ss_a2, l_ss_a3 - use oslo_aero_share, only: MODE_IDX_SS_A1, MODE_IDX_SS_A2, MODE_IDX_SS_A3 - - implicit none - private - - integer , parameter :: numberOfSaltModes = 3 - - character(len=6) , public :: seasalt_names(10) - integer, parameter, public :: seasalt_nbin = numberOfSaltModes ! needed by mo_photo.F90 - logical, parameter, public :: seasalt_active = .true. - - integer :: modeMap(numberOfSaltModes) ! [idx] which modes are we modifying - integer :: tracerMap(numberOfSaltModes) ! [idx] which tracers are we modifying - - public :: oslo_aero_seasalt_init - public :: oslo_aero_seasalt_emis - -!=============================================================================== -contains -!=============================================================================== - - subroutine oslo_aero_seasalt_init() - - integer :: i - - modeMap(1) = MODE_IDX_SS_A1 - modeMap(2) = MODE_IDX_SS_A2 - modeMap(3) = MODE_IDX_SS_A3 - - tracerMap(1) = l_ss_a1 - tracerMap(2) = l_ss_a2 - tracerMap(3) = l_ss_a3 - - seasalt_names(:) = " " - do i = 1,numberOfSaltModes - seasalt_names(i) = cnst_name(tracerMap(i)) - end do - - end subroutine oslo_aero_seasalt_init - - !=============================================================================== - subroutine oslo_aero_seasalt_emis(state, cam_in) - - ! Arguments: - type(physics_state), intent(in) :: state ! Physics state variables - type(cam_in_t), target, intent(inout) :: cam_in ! import state - - ! Local variables - integer :: n ![] counter for modes - integer :: ncol ![nbr] number of columns in use - integer :: lchnk !chunk index - real(r8) :: whiteCapAreaFraction(pcols) ![fraction] - real(r8) :: open_ocean(pcols) ![fraction] - real(r8) :: numberFlux(pcols,numberofSaltModes) ![#/m2/sec] - real(r8) :: u10m(pcols) ![m/s] - real(r8), pointer :: sst(:) ![frc] sea surface temperature - real(r8), pointer :: ocnfrc(:) ![frc] ocean fraction - real(r8), pointer :: icefrc(:) ![frc] ice fraction - real(r8) :: spracklenOMOceanSource(pcols) ![kg/m2/s] spracklen ocean source - real(r8) :: onOMOceanSource(pcols) ![kg/m2/s] OM source from Nilsson/O'Dowd - real(r8) :: OMOceanSource(pcols) ![kg/m2/s] new OM ocean source - real(r8), parameter :: z0= 0.0001_r8 ![m] roughness length over ocean - - !New numbers are based on Salter et al. (2105): - !www.atmos-chem-phys-discuss.net/15/13783/2015/doi:10.5194/acpd-15-13783-2015 - !Values from Table 1 in Salter et al. (2015): - real(r8), parameter :: coeffA(numberOfSaltModes) = (/-5.2168e5_r8, 0.0_r8, 0.0_r8 /) - real(r8), parameter :: coeffB(numberOfSaltModes) = (/ 3.31725e7_r8, 7.374e5_r8, 1.4210e4_r8 /) - real(r8), parameter :: coeffC(numberOfSaltModes) = (/-6.95275e8_r8,-2.4803e7_r8, 1.4662e7_r8 /) - real(r8), parameter :: coeffD(numberOfSaltModes) = (/ 1.0684e10_r8, 7.7373e8_r8, 1.7075e8_r8 /) - - !After discussions with Alf K, it is better to scale with only smallest SS-mode since POM is small - !and assume same production mechanism. Nudged 1 degree simulations give 2.52 Tg/yr of SS_A1, so - !to obtain 7.7, we need to scale them by 7.7 / 2.52 ==> 3.03 - !updated value for Salter et al. sea-salt treatment, which gives global annual SS_A1 emissions of - !2.663 instead of 0.153 ng m-2 s-1 (i.e. ca 17 times more than the old sea-salt treatment): - real(r8), parameter :: seasaltToSpracklenOM2 = 3.03_r8*0.153_r8/2.663_r8 - - !number of columns in use - ncol = state%ncol - lchnk = state%lchnk - - !pointers to land model variables - ocnfrc => cam_in%ocnfrac - icefrc => cam_in%icefrac - sst => cam_in%sst - - !start with midpoint wind speed - u10m(:ncol)=sqrt(state%u(:ncol,pver)**2+state%v(:ncol,pver)**2) - - ! move the winds to 10m high from the midpoint of the gridbox: - u10m(:ncol)=u10m(:ncol)*log(10._r8/z0)/log(state%zm(:ncol,pver)/z0) - - ! New whitecap area fraction / air entrainment flux from eqn. 6 in Salter et al. (2015) - ! JCA & MS Using Hanson & Phillips 99 air entrainment vs. wind speed - ! (Note the uncertainty in the factor 2, written as 2 pluss/minus 1 in Eq. 6 -> possible tuning factor) - whitecapAreaFraction(:ncol) = (2.0_r8*10.0_r8**(-8.0_r8))*(u10m(:ncol)**3.74_r8) - whitecapAreaFraction(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) * whitecapAreaFraction(:ncol) - - ! Determine open ocean fraction on gridcell - open_ocean(:ncol) = ocnfrc(:ncol) * (1._r8-icefrc(:ncol)) - - ! Eqn. 9 in Salter et al. (2015) - do n=1,numberOfSaltModes - numberFlux(:ncol,n) = whitecapAreaFraction(:ncol)* & - ( coeffA(n)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8) & - + coeffB(n)*(sst(:ncol)-273.15_r8)*(sst(:ncol)-273.15_r8) & - + coeffC(n)*(sst(:ncol)-273.15_r8) & - + coeffD(n) ) - end do - - do n=1,numberOfSaltModes - cam_in%cflx(:ncol, tracerMap(n)) = numberFlux(:ncol,n) & !#/m2/sec - / volumeToNumber(modeMap(n)) & !==> m3/m2/sec - * rhopart(tracerMap(n)) !==> kg/m2/sec - end do - spracklenOMOceanSource(:ncol) = cam_in%cflx(:ncol, tracerMap(1))*seasaltToSpracklenOM2 - - if (oslo_aero_opom_inq())then - call oslo_aero_opom_emis(cam_in%cflx(:ncol, tracerMap(1)), & - cam_in%cflx(:ncol,tracerMap(2)), cam_in%cflx(:ncol,tracerMap(3)), & - open_ocean, ncol, lchnk, onOMOceanSource ) - OMOceanSource(:ncol) = onOMOceanSource(:ncol) - else - OMOceanSource(:ncol) = spracklenOMOceanSource(:ncol) - endif - - !Add OM ocean source to cam_in - cam_in%cflx(:ncol,l_om_ni) = cam_in%cflx(:ncol,l_om_ni) + OMOceanSource(:ncol) - - end subroutine oslo_aero_seasalt_emis - -end module oslo_aero_seasalt diff --git a/src/chemistry/oslo_aero/oslo_aero_share.F90 b/src/chemistry/oslo_aero/oslo_aero_share.F90 deleted file mode 100644 index c73a18423d..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_share.F90 +++ /dev/null @@ -1,714 +0,0 @@ -module oslo_aero_share - - !--------------------------------------------------------------------------------- - ! Module to set up register aerosols indexes, number of gas and particle - ! species and their scavenging rates. Tables for humidity growth - !--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - use constituents, only: pcnst, cnst_name, cnst_get_ind - use mo_tracname, only: solsym - use cam_abortutils, only: endrun - ! - use oslo_aero_params - - implicit none - private ! Make default type private to the module - - integer, public, parameter :: max_tracers_per_mode = 7 - real(r8), public, dimension (pcnst) :: rhopart - real(r8), public, dimension (pcnst) :: sgpart - real(r8), public, dimension (pcnst) :: osmoticCoefficient - real(r8), public, dimension (pcnst) :: numberOfIons - real(r8), public, dimension (pcnst) :: solubleMassFraction - integer, public, dimension (pcnst) :: aerosolType - real(r8), public, dimension(nbmodes) :: numberFractionAvailableAqChem - real(r8), public, dimension (pcnst) :: invrhopart - real(r8), public, parameter :: smallConcentration = 1.e-100_r8 !duplicate, sync with smallNumber in Const - ! - ! Public interfaces - ! - public :: aero_register ! register consituents - public :: is_process_mode ! Check is an aerosol specie is a process mode - public :: isAerosol ! Check is specie is aerosol (i.e. gases get .FALSE. here) - public :: getTracerIndex - public :: getNumberOfTracersInMode - public :: getNumberOfBackgroundTracersInMode - public :: getCloudTracerIndex - public :: getCloudTracerIndexDirect - public :: getCloudTracerName - public :: chemistryIndex - public :: physicsIndex - public :: getDryDensity - public :: getConstituentFraction - public :: isTracerInMode - public :: fillAerosolTracerList - public :: getNumberOfAerosolTracers - public :: fillInverseAerosolTracerList - public :: qqcw_get_field - - integer, parameter, public :: MODE_IDX_BC_EXT_AC = 0 !Externally mixed BC accumulation mode - integer, parameter, public :: MODE_IDX_SO4SOA_AIT = 1 !SO4 and SOA in aitken mode, Created from 11 by growth (condensation) of SO4 - integer, parameter, public :: MODE_IDX_BC_AIT = 2 !Created from 12 by growth (condensation) SO4 - integer, parameter, public :: MODE_IDX_NOT_USED = 3 !Not used - integer, parameter, public :: MODE_IDX_OMBC_INTMIX_COAT_AIT = 4 !Created from 14 by growth (condensation) of SO4 and from cloud processing/wet-phas - integer, parameter, public :: MODE_IDX_SO4_AC = 5 !Accumulation mode SO4 (mode will have other comps added) - integer, parameter, public :: MODE_IDX_DST_A2 = 6 !Accumulation mode dust (mode will have other comps added) - integer, parameter, public :: MODE_IDX_DST_A3 = 7 !Coarse mode dust (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SS_A1 = 8 !Fine mode sea-salt (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SS_A2 = 9 !Accumulation mode sea-salt (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SS_A3 = 10 !Coarse mode sea-salt (mode will have other comps added) - integer, parameter, public :: MODE_IDX_SO4SOA_NUC = 11 !SO4 and SOA nucleation mode - integer, parameter, public :: MODE_IDX_BC_NUC = 12 !BC nucleation mode - integer, parameter, public :: MODE_IDX_LUMPED_ORGANICS = 13 !not used in lifecycle, but some extra mass goes here when max. allowed LUT conc. are too small - integer, parameter, public :: MODE_IDX_OMBC_INTMIX_AIT = 14 !mix quickly formed in fire-plumes - - integer, parameter, public :: numberOfExternallyMixedModes = 4 !Modes 0;11-14 (13 is not used in lifecycle) - integer, parameter, public :: numberOfInternallyMIxedMOdes = 9 !Modes 1-10 (3 is not used in lifecycle) - - integer, parameter, public :: numberOfProcessModeTracers = 6 - integer, public, dimension(numberOfProcessModeTracers) :: tracerInProcessMode - integer, public, dimension(pcnst) :: processModeMap - - !These tables describe how the tracers behave chemically - integer, dimension(numberOfExternallyMixedModes), public :: externallyMixedMode = & - (/MODE_IDX_BC_EXT_AC, & - MODE_IDX_SO4SOA_NUC, & - MODE_IDX_BC_NUC, & - MODE_IDX_OMBC_INTMIX_AIT /) - - integer, dimension(numberOfInternallyMixedMOdes), public :: internallyMixedMode = & - (/MODE_IDX_SO4SOA_AIT, & - MODE_IDX_BC_AIT, & - MODE_IDX_OMBC_INTMIX_COAT_AIT, & - MODE_IDX_SO4_AC, & - MODE_IDX_DST_A2, & - MODE_IDX_DST_A3, & - MODE_IDX_SS_A1, & - MODE_IDX_SS_A2, & - MODE_IDX_SS_A3 /) - - ! species indices for individual camuio species - integer,public :: l_so4_na, l_so4_a1, l_so4_a2, l_so4_ac - integer,public :: l_bc_n, l_bc_ax, l_bc_ni, l_bc_a, l_bc_ai,l_bc_ac - integer,public :: l_om_ni, l_om_ai, l_om_ac - integer,public :: l_so4_pr - integer,public :: l_dst_a2, l_dst_a3 - integer,public :: l_ss_a1, l_ss_a2, l_ss_a3, l_h2so4 - integer,public :: l_soa_na, l_soa_a1, l_soa_lv, l_soa_sv - - integer :: n_aerosol_tracers !number of aerosol tracers - integer :: imozart - - !Number of transported tracers in each mode - integer, parameter, dimension(0:nmodes) :: n_tracers_in_mode = (/ 1, 4, 3, 0, 5, 7, 7, 7, 7, 7, 7, 0, 1, 0, 2 /) - integer, parameter, dimension(0:nmodes) :: n_background_tracers_in_mode = (/ 1,2,1,0,2,1,1,1,1,1,1,0,1,0,2 /) - integer, dimension(0:nmodes, max_tracers_per_mode) :: tracer_in_mode - - !Radius used for the modes in the lifeCycle MAY ASSUME SOME GROWTH ALREADY HAPPENED - real(r8), parameter, public, dimension(0:nmodes) :: lifeCycleNumberMedianRadius = & - 1.e-6_r8*(/ 0.0626_r8, 0.025_r8, 0.025_r8, 0.04_r8, 0.06_r8, 0.075_r8, & - 0.22_r8, 0.63_r8, 0.0475_r8, 0.30_r8, 0.75_r8, & ! Salter et al. (2015) - 0.0118_r8, 0.024_r8, 0.04_r8, 0.04_r8 /) - - !Sigma based on original lifecycle code (taken from "sigmak" used previously in lifecycle code) - real(r8), parameter, public, dimension(0:nmodes) :: lifeCycleSigma = (/1.6_r8, 1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 & !0-4 - ,1.59_r8, 1.59_r8, 2.0_r8 & !5,6,7 (SO4+dust) - ,2.1_r8, 1.72_r8, 1.6_r8 & !8-10 (SS) ! Salter et al. (2015) - ,1.8_r8, 1.8_r8, 1.8_r8, 1.8_r8 & !11-14 - /) - - !Below cloud scavenging coefficients for modes which have an actual size - real(r8), parameter, public, dimension(0:nmodes) :: belowCloudScavengingCoefficient= & - (/ 0.01_r8 , 0.02_r8 , 0.02_r8 , 0.0_r8 , 0.02_r8, 0.01_r8, & !(0-5) - 0.02_r8 , 0.2_r8 , 0.02_r8 , 0.02_r8, 0.5_r8, & !6-10 (DUST+SS) - 0.04_r8 , 0.08_r8 , 0.0_r8 , 0.02_r8 /) ! SO4_n, bc_n, N/A og bc/oc - - !Treatment of process-modes! - !The tracers indices can not be set here since they are not known on compile time - !tracerInProcessMode = (/l_so4_a1, l_so4_a2, l_so4_ac, l_om_ac, l_bc_ac, l_soa_a1 /) - - !The process modes need an "efficient size" (Why does A1 have a different size than the others??) - real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeNumberMedianRadius = & - (/ 0.04e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.1e-6_r8, 0.04e-6_r8 /) - - !The process modes need an "efficient sigma" - real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: processModeSigma = & - (/ 1.8_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.59_r8, 1.8_r8 /) - - - real(r8), parameter, public, dimension(numberOfProcessModeTracers) :: belowCloudScavengingCoefficientProcessModes = & - (/0.02_r8, 0.01_r8, 0.02_r8, 0.02_r8, 0.02_r8, 0.02_r8 /) - - !Growth of aerosols, duplicated in oslo_aero_sw_tables - real(r8), public,dimension (10) :: rhtab - real(r8), public,dimension (10,pcnst):: rdivr0(10,pcnst) - - data rhtab/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, 0.80_r8, 0.85_r8, 0.90_r8, 0.95_r8, 0.98_r8 / - - integer, dimension(pcnst) :: cloudTracerIndex - character(len=20) :: cloudTracerName(pcnst) - - integer, private :: qqcw(pcnst)=-1 ! Remaps modal_aero indices into pbuf - -contains - - !=============================================================================== - function is_process_mode(l_index_in, isChemistry) result(answer) - !For a tracer in an aerosol mode, check if this is!actually a real tracer or a process mode - - integer, intent(in) :: l_index_in - logical, intent(in) :: isChemistry !true if called from chemistry - - integer :: l_index_phys - logical :: answer - - l_index_phys = l_index_in - if (isChemistry) then - l_index_phys = l_index_phys + iMozart - 1 - endif - - ! return true if tracer is a "process mode" - answer = .false. - if(l_index_phys .eq. l_so4_a1 .or. & - l_index_phys .eq. l_so4_a2 .or. & - l_index_phys .eq. l_so4_ac .or. & - l_index_phys .eq. l_bc_ac .or. & - l_index_phys .eq. l_om_ac .or. & - l_index_phys .eq. l_soa_a1 ) then - answer = .true. - endif - - end function is_process_mode - - !=============================================================================== - subroutine aero_register - - !----------------------------------------------------------------------- - ! Register aerosol modes and indices, should be changed to read in values - ! instead of hard-coding it. - !----------------------------------------------------------------------- - - use mpishorthand - use physics_buffer, only: pbuf_add_field, dtype_r8 - use ppgrid, only: pcols, pver, pverp - - integer :: idx_dum, l,m,mm - logical :: isAlreadyCounted(pcnst) - - ! register the species - - call cnst_get_ind('SO4_NA' ,l_so4_na, abort=.true.) !Aitken mode sulfate (growth from so4_n) - call cnst_get_ind('SO4_A1' ,l_so4_a1, abort=.true.) !sulfate condensate (gas phase production) - call cnst_get_ind('SO4_A2' ,l_so4_a2, abort=.true.) !sulfate produced in aq. chemistry - call cnst_get_ind('SO4_AC' ,l_so4_ac, abort=.true.) !sulfate from coagulation processes - call cnst_get_ind('SO4_PR' ,l_so4_pr, abort=.true.) !sulfate emitted as primary - - call cnst_get_ind('BC_N' ,l_bc_n, abort=.true.) !emissions (mainly industry) lost through coagulation - call cnst_get_ind('BC_AX' ,l_bc_ax, abort=.true.) !externally mixed (fluffy and impossible to activate) - call cnst_get_ind('BC_NI' ,l_bc_ni, abort=.true.) !mixed with oc (mainly biomass), externally mixed otherwise (before condensation etc) - call cnst_get_ind('BC_A' ,l_bc_a, abort=.true.) !formed when bc_n grows by condensation - call cnst_get_ind('BC_AI' ,l_bc_ai, abort=.true.) !formed when bc_ni grows by condensation - call cnst_get_ind('BC_AC' ,l_bc_ac, abort=.true.) !bc from coagulation processes - - call cnst_get_ind('OM_NI' ,l_om_ni, abort=.true.) !om (mainly from biomass), emitted - call cnst_get_ind('OM_AI' ,l_om_ai, abort=.true.) !om formed when condensation growth of om_ni - call cnst_get_ind('OM_AC' ,l_om_ac, abort=.true.) !om from coagulation processes - - call cnst_get_ind('DST_A2' ,l_dst_a2, abort=.true.) !Dust accumulation mode - call cnst_get_ind('DST_A3' ,l_dst_a3, abort=.true.) !Dust coarse mode - - call cnst_get_ind('SS_A1' ,l_ss_a1, abort=.true.) !Sea salt fine mode - call cnst_get_ind('SS_A2' ,l_ss_a2, abort=.true.) !Sea salt accumulation mode - call cnst_get_ind('SS_A3' ,l_ss_a3, abort=.true.) !Sea salt coarse mode - - ! register SOA species - call cnst_get_ind('SOA_NA' ,l_soa_na, abort=.true.) !Aitken mode SOA with SO4 and SOA condensate - call cnst_get_ind('SOA_A1' ,l_soa_a1, abort=.true.) !SOA condensate - call cnst_get_ind('SOA_LV' ,l_soa_lv, abort=.true.) !Gas phase low volatile SOA - call cnst_get_ind('SOA_SV' ,l_soa_sv, abort=.true.) !Gas phase semi volatile SOA - - ! gas phase h2so4 - call cnst_get_ind('H2SO4' ,l_h2so4, abort=.true.) - - ! Register the tracers in modes - call registerTracersInMode() - - ! Set the aerosol types - aerosolType(:) = -99 - aerosolType(l_so4_na) = AEROSOL_TYPE_SULFATE - aerosolType(l_so4_a1) = AEROSOL_TYPE_SULFATE - aerosolType(l_so4_a2) = AEROSOL_TYPE_SULFATE - aerosolType(l_so4_ac) = AEROSOL_TYPE_SULFATE - aerosolType(l_so4_pr) = AEROSOL_TYPE_SULFATE - aerosolType(l_bc_n) = AEROSOL_TYPE_BC - aerosolType(l_bc_ax) = AEROSOL_TYPE_BC - aerosolType(l_bc_ni) = AEROSOL_TYPE_BC - aerosolType(l_bc_a) = AEROSOL_TYPE_BC - aerosolType(l_bc_ai) = AEROSOL_TYPE_BC - aerosolType(l_bc_ac) = AEROSOL_TYPE_BC - aerosolType(l_om_ni) = AEROSOL_TYPE_OM - aerosolType(l_om_ai) = AEROSOL_TYPE_OM - aerosolType(l_om_ac) = AEROSOL_TYPE_OM - aerosolType(l_dst_a2) = AEROSOL_TYPE_DUST - aerosolType(l_dst_a3) = AEROSOL_TYPE_DUST - aerosolType(l_ss_a1) = AEROSOL_TYPE_SALT - aerosolType(l_ss_a2) = AEROSOL_TYPE_SALT - aerosolType(l_ss_a3) = AEROSOL_TYPE_SALT - aerosolType(l_soa_na) = AEROSOL_TYPE_OM - aerosolType(l_soa_a1) = AEROSOL_TYPE_OM - - rhopart(:)= 1000.0_r8 - - ! assign values based on aerosol type - do m=0,nmodes - do l=1,n_tracers_in_mode(m) - mm= getTracerIndex(m,l,.false.) - osmoticCoefficient(mm) = aerosol_type_osmotic_coefficient(aerosolType(mm)) - rhopart(mm) = aerosol_type_density(aerosolType(mm)) - solubleMassFraction(mm) = aerosol_type_soluble_mass_fraction(aerosolType(mm)) - numberOfIons(mm) = aerosol_type_number_of_ions(aerosolType(mm)) - end do - end do - - !SPECIAL CASES OF AEROSOL PROPERTIES: - !Density of bc_ax is rewritten later (calculated from fractal dimension) - !so4_a2 is different since it is ammonium sulfate and not sulf. acid. - rhopart(l_so4_a2) = 1769.0_r8 - - !These are not really particles, but set densities for the condenseable vapours - !used by condtend - rhopart(l_h2so4)= 1841.0_r8 - rhopart(l_soa_lv) = aerosol_type_density(AEROSOL_TYPE_OM) - rhopart(l_soa_sv) = aerosol_type_density(AEROSOL_TYPE_OM) - - ! Inverse calculated to avoid unneeded divisions in loop - invrhopart(:)=1._r8/rhopart(:) - - !Set process mode sizes - tracerInProcessMode = (/l_so4_a1, l_so4_a2, l_so4_ac, l_om_ac, l_bc_ac, l_soa_a1 /) - processModeMap(:)=-99 !Force error if using unset values - do l =1,pcnst - do m=1,numberOfProcessModeTracers - if(tracerInProcessMode(m) .eq. l)then - processModeMap(l)=m - end if - end do - end do - - ! Find out first mozart tracers (fxm: short lived species might mess up this!) - call cnst_get_ind(trim(solsym(1)), imozart, abort=.true.) - - !Add the cloud-tracers - isAlreadyCounted(:) = .false. - cloudTracerIndex(:) = -1 - do m=1,nmodes - do l=1,n_tracers_in_mode(m) - mm= getTracerIndex(m,l,.false.) - if(.not. isAlreadyCounted(mm))then - cloudTracerName(mm) = trim(cnst_name(mm))//"_OCW" - call pbuf_add_field(trim(cloudTracerName(mm)), 'global', dtype_r8, (/pcols,pver/), idx_dum) - ! Set the module variable qqcw(mm) to be set to idx_dum - call qqcw_set_ptr(mm,idx_dum) - cloudTracerIndex(mm) = idx_dum - isAlreadyCounted(mm) = .true. - endif - end do - end do - - !Find out how many aerosol-tracers we carry - isAlreadyCounted(:) = .false. - n_aerosol_tracers = 0 - do m=1,nmodes - do l=1,n_tracers_in_mode(m) - mm=getTracerIndex(m,l,.false.) - if(.not. isAlreadyCounted(mm))then - n_aerosol_tracers = n_aerosol_tracers + 1 - isAlreadyCounted(mm)=.true. - endif - end do - end do - - !Tabulated rh-growth for all species - call inittabrh - - end subroutine aero_register - - !============================================================================= - function getNumberOfAerosolTracers()RESULT(numberOfTracers) - integer :: numberOfTracers - numberOfTracers = n_aerosol_tracers - end function getNumberOfAerosolTracers - - !============================================================================= - function chemistryIndex(phys_index) RESULT (chemistryIndexOut) - integer, intent(in) :: phys_index - integer :: chemistryIndexOut - chemistryIndexOut = phys_index - imozart + 1 - end function chemistryIndex - - !============================================================================= - function physicsIndex(chem_index) RESULT(physIndexOut) - integer, intent(in) :: chem_index - integer :: physIndexOut - physIndexOut = chem_index + imozart - 1 - end function physicsIndex - - !============================================================================= - function isAerosol(phys_index) RESULT(answer) - integer, intent(in) :: phys_index - logical answer - answer=.FALSE. - if(aerosolType(phys_index) .gt. 0)then - answer = .TRUE. - endif - end function isAerosol - - !============================================================================= - function getNumberOfTracersInMode(modeIndex) RESULT(numberOfSpecies) - integer, intent(in) :: modeIndex - integer numberOfSpecies - numberOfSpecies = n_tracers_in_mode(modeIndex) - end function getNumberOfTracersInMode - - !============================================================================= - function getNumberOfBackgroundTracersInMode(modeIndex) RESULT (numberOfBackgroundSpecies) - integer, intent(in) :: modeIndex - integer numberOfBackgroundSpecies - numberOfBackgroundSpecies = n_background_tracers_in_mode(modeIndex) - end function getNumberOfBackgroundTracersInMode - - !============================================================================= - function getTracerIndex(modeIndex, componentIndex, isChemistry) RESULT(tracerIndex) - !purpose: Ask for an index in mode - !The index is the index in the q-array - !Some tracers may exist in several modes (is that a problem??) - integer, intent(in) :: modeIndex - integer, intent(in) :: componentIndex - logical, intent(in) :: isChemistry - integer tracerIndex - if(isChemistry)then - !This is tracer index in physics array - tracerIndex = tracer_in_mode(modeIndex,componentIndex)-imozart+1 - else - tracerIndex = tracer_in_mode(modeIndex,componentIndex) - endif - end function getTracerIndex - - !=============================================================================== - function getCloudTracerIndex(modeIndex, componentIndex) RESULT(cloud_tracer_index) - - ! Obtain an index in the physics-buffer for a component in the lifecycle scheme - - integer, intent(in) :: modeIndex - integer, intent(in) :: componentIndex - - integer :: tracerIndex - integer :: cloud_tracer_index - - if(componentIndex == 0)then - !Special key for number concentration of a mode - call endrun("error no such species") - else if (componentIndex > 0)then - !Lifecycle specie in a mode - tracerIndex = getTracerIndex(modeIndex,componentIndex,.false.) - cloud_tracer_index = cloudTracerIndex(tracerIndex) !ak: Index in phys-buffer - else - call endrun("negative componentindex in getCloudTracerIndex") - endif - end function getCloudTracerIndex - - !=============================================================================== - function getCloudTracerIndexDirect(tracerIndex) RESULT(cloudTracerIndexOut) - !returns index in pbuf for the corresponding cloud tracer with physics index "tracerIndex" - !returns "-1" if the tracer does not have any corresponding cloud tracer - integer, intent(in) :: tracerIndex - integer :: cloudTracerIndexOut - cloudTracerIndexOut = cloudTracerIndex(tracerIndex) - end function getCloudTracerIndexDirect - - !=============================================================================== - function getDryDensity(m,l) RESULT(density) - integer, intent(in) :: m !mode index - integer, intent(in) :: l !tracer index - real(r8) :: density - density = rhopart(tracer_in_mode(m,l)) - end function getDryDensity - - !=============================================================================== - function getCloudTracerName(tracerIndex) RESULT(cloudTracerNameOut) - integer, intent(in) :: tracerIndex - character(len=20) :: cloudTracerNameOut - cloudTracerNameOut = trim(cloudTracerName(tracerIndex)) - end function getCloudTracerName - - !=============================================================================== - subroutine fillAerosolTracerList(aerosolTracerList) - integer, dimension (:), intent(out) :: aerosolTracerList - logical, dimension(pcnst) :: alreadyFound - integer :: m,l,mm,nTracer - alreadyFound(:) = .FALSE. - nTracer = 0 - do m=1,nmodes - do l=1,n_tracers_in_mode(m) - mm=getTracerIndex(m,l,.FALSE.) - if(.NOT.alreadyFound(mm))then - nTracer = nTracer + 1 - alreadyFound(mm) = .TRUE. - aerosolTracerList(nTracer) = mm - end if - end do - end do - end subroutine fillAerosolTracerList - - !=============================================================================== - subroutine fillInverseAerosolTracerList(aerosolTracerList, inverseAerosolTracerList, n_aerosol_tracers) - integer, dimension(:), intent(in) :: aerosolTracerList - integer, intent(in) :: n_aerosol_tracers - integer, dimension(pcnst), intent(out) :: inverseAerosolTracerList - integer :: i - - inverseAerosolTracerList(:) = -99 - do i=1,n_aerosol_tracers - inverseAerosolTracerList(aerosolTracerList(i)) = i - end do - end subroutine fillInverseAerosolTracerList - - !=============================================================================== - subroutine registerTracersInMode() - !Register tracer index in modes - tracer_in_mode(:,:) = -1 !undefined - - !externally mixed bc - tracer_in_mode(MODE_IDX_BC_EXT_AC, 1:n_tracers_in_mode(MODE_IDX_BC_EXT_AC)) = (/l_bc_ax/) - - !sulphate + soa, sulfate condensate. - tracer_in_mode(MODE_IDX_SO4SOA_AIT, 1:n_tracers_in_mode(MODE_IDX_SO4SOA_AIT) ) = & - (/l_so4_na, l_soa_na, l_so4_a1, l_soa_a1/) - - !bc + sulfate condensate - tracer_in_mode(MODE_IDX_BC_AIT,1:n_tracers_in_mode(MODE_IDX_BC_AIT)) = & - (/l_bc_a, l_so4_a1, l_soa_a1/) - - !index not used - !tracer_in_mode(MODE_IDX_NOT_USED, 1:n_tracers_in_mode(MODE_IDX_NOT_USED)) = (/-1/) - - !om / bc internally mixed with sulfate condensate and aquous phase sulfate - tracer_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_COAT_AIT))= & - (/l_bc_ai, l_om_ai, l_so4_a1, l_so4_a2, l_soa_a1 /) - - !accumulation mode sulfate with coagulate, condensate and aquous phase sulfate - tracer_in_mode(MODE_IDX_SO4_AC, 1:n_tracers_in_mode(MODE_IDX_SO4_AC)) = & - (/l_so4_pr, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - - !ac-mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_DST_A2, 1:n_tracers_in_mode(MODE_IDX_DST_A2)) = & - (/l_dst_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - - !coarse mode dust with sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_DST_A3, 1:n_tracers_in_mode(MODE_IDX_DST_A3)) = & - (/l_dst_a3, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - - !at-mode ss with sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_SS_A1, 1:n_tracers_in_mode(MODE_IDX_SS_A1)) = & - (/l_ss_a1, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - - !ac mode ss with sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_SS_A2, 1:n_tracers_in_mode(MODE_IDX_SS_A2)) = & - (/l_ss_a2, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - - !coarse mode ss sulfate coagulate, condensate sulfate and wet-phase sulfate - tracer_in_mode(MODE_IDX_SS_A3, 1:n_tracers_in_mode(MODE_IDX_SS_A3)) = & - (/l_ss_a3, l_bc_ac, l_om_ac, l_so4_a1, l_so4_ac, l_so4_a2, l_soa_a1 /) - - !sulfate + soa nucleation mode (mode no longer used) - !tracer_in_mode(MODE_IDX_SO4SOA_NUC, 1:n_tracers_in_mode(MODE_IDX_SO4SOA_NUC)) = (/ -1 /) - - !bc in nucleation mode - tracer_in_mode(MODE_IDX_BC_NUC, 1:n_tracers_in_mode(MODE_IDX_BC_NUC)) = (/l_bc_n/) - - !lumped organics - !tracer_in_mode(MODE_IDX_LUMPED_ORGANICS, 1:n_tracers_in_mode(MODE_IDX_LUMPED_ORGANICS)) = (/-1/) - - !intermal mixture bc/oc coated - tracer_in_mode(MODE_IDX_OMBC_INTMIX_AIT, 1:n_tracers_in_mode(MODE_IDX_OMBC_INTMIX_AIT)) = (/l_bc_ni, l_om_ni/) - end subroutine registerTracersInMode - - !=============================================================================== - function isTracerInMode(modeIndex, constituentIndex)RESULT(answer) - integer, intent(in) :: modeIndex - integer, intent(in) :: constituentIndex - integer :: i - logical :: answer - answer = .FALSE. - do i=1,n_tracers_in_mode(modeIndex) - if(tracer_in_mode(modeIndex,i) == constituentIndex)then - answer = .TRUE. - endif - enddo - end function isTracerInMode - - !=============================================================================== - function getConstituentFraction(CProcessModes, f_c, f_bc, f_aq, f_so4_cond, f_soa & - ,Cam, f_acm, f_bcm, f_aqm, f_so4_condm,f_soam, constituentIndex,debugPrint ) RESULT(fraction) ! mass fraction - - real(r8), intent(in) :: CProcessModes - real(r8), intent(in) :: f_c - real(r8), intent(in) :: f_bc - real(r8), intent(in) :: f_aq - real(r8), intent(in) :: f_so4_cond - real(r8), intent(in) :: f_soa - real(r8), intent(in) :: cam - real(r8), intent(in) :: f_aqm - real(r8), intent(in) :: f_bcm - real(r8), intent(in) :: f_acm - real(r8), intent(in) :: f_so4_condm - real(r8), intent(in) :: f_soam - integer, intent(in) :: constituentIndex - logical, optional, intent(in) :: debugPrint - - logical :: doPrint = .false. - real(r8) :: fraction - - if(present(debugPrint))then - if(debugPrint) then - doPrint=.true. - endif - endif - - fraction = 1.0_r8 ! fraction = 1 for all tracers, except special cases (process modes) below - - !This fraction is the mass of a certain tracer in a specific size-mode divided by the total - !mass of the same tracer for (i.e. summed up over) all size-modes. This total mass is what - !is transported in the model, in the life cycle scheme. The word size-mode is here used for a mode in the - !aerosol size-distribution, which is assumed to be log-normal prior to growth. - if((l_so4_a1 .eq. constituentIndex))then !so4 condensation - fraction= (cam & - *(1.0_r8-f_acm) & !sulfate fraction - *(1.0_r8-f_aqm) & !fraction not from aq phase - *(f_so4_condm) & !fraction being condensate - ) & - / & - (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*f_so4_cond+smallConcentration) !total so4 condensate - - if (doPrint) then - print*, " " - print*, "conc ==>", CProcessmodes, cam - print*, "modefrc ==>", f_acm, f_aqm, f_so4_condm - print*, "totfrc ==>", f_c, f_aq, f_so4_cond - print*, "fraction ==>", cam/(CProcessModes+smallConcentration)*100.0, fraction*100 , "%" - endif - - else if(l_so4_ac .eq. constituentIndex)then !so4 coagulation - fraction = (cam & - * (1.0_r8 - f_acm) & !sulfate fraction - * (1.0_r8 - f_aqm) & !fraction not from aq phase - * (1.0_r8 - f_so4_condm) & !fraction not being condensate - ) & - / & - (CProcessModes*(1.0_r8-f_c)*(1.0_r8-f_aq)*(1.0_r8-f_so4_cond) & !total non-aq sulf - +smallConcentration) - - else if(l_so4_a2 .eq. constituentIndex) then !so4 wet phase - fraction = (cam & - *(1.0_r8-f_acm) & !sulfate fraction - *f_aqm) & !aq phase fraction of sulfate - / & - (CProcessModes*(1.0_r8-f_c)*(f_aq)+smallConcentration) - - else if(l_bc_ac .eq. constituentIndex)then !bc coagulated - fraction = (cam & - *f_acm & ! carbonaceous fraction - *f_bcm) & ! bc fraction of carbonaceous - / & - (CProcessModes*f_c*f_bc+smallConcentration) - - else if(l_om_ac .eq. constituentIndex ) then !oc coagulated - fraction = (cam & - *f_acm & ! carbonaceous fraction - *(1.0_r8-f_bcm) & ! oc fraction of carbonaceous - *(1.0_r8-f_soam))& ! oc fraction which is soa - / & - (CProcessModes*f_c*(1.0_r8-f_bc)*(1.0_r8-f_soa)+smallConcentration) - - else if (l_soa_a1 .eq. constituentIndex) then !SOA condensate - fraction = cam & - *f_acm & !carbonaceous fraction - *(1.0_r8 -f_bcm) & !om fraction - *(f_soam) & !fraction of OM is SOA - / & - (CProcessModes * f_c* (1.0_r8 -f_bc)*f_soa + smallConcentration) - end if - - if (fraction .gt. 1.0_r8)then - fraction = 1.0_r8 - endif - end function getConstituentFraction - - !=============================================================================== - subroutine inittabrh() - - ! Tables for hygroscopic growth - - integer :: i - real(r8) :: rr0ss(10),rr0so4(10),rr0bcoc(10) - - data rr0ss / 1.00_r8, 1.00_r8, 1.02_r8, 1.57_r8, 1.88_r8, 1.97_r8, 2.12_r8, 2.35_r8, 2.88_r8, 3.62_r8 / - data rr0so4 / 1.00_r8, 1.34_r8, 1.39_r8, 1.52_r8, 1.62_r8, 1.69_r8, 1.78_r8, 1.92_r8, 2.22_r8, 2.79_r8 / - data rr0bcoc / 1.00_r8, 1.02_r8, 1.03_r8, 1.12_r8, 1.17_r8, 1.20_r8, 1.25_r8, 1.31_r8, 1.46_r8, 1.71_r8 / - - rdivr0(:,:)=1._r8 - - do i=1,10 - rdivr0(i,l_so4_na)=rr0so4(i) - rdivr0(i,l_so4_a1)=rr0so4(i) - rdivr0(i,l_so4_a2)=rr0so4(i) - rdivr0(i,l_so4_ac)=rr0so4(i) - rdivr0(i,l_so4_pr)=rr0so4(i) - - rdivr0(i,l_bc_a)=rr0bcoc(i) - - rdivr0(i,l_bc_ni)=rr0bcoc(i) - rdivr0(i,l_bc_ai)=rr0bcoc(i) - rdivr0(i,l_bc_ac)=rr0bcoc(i) - - rdivr0(i,l_om_ni)=rr0bcoc(i) - rdivr0(i,l_om_ai)=rr0bcoc(i) - rdivr0(i,l_om_ac)=rr0bcoc(i) - - rdivr0(i,l_ss_a1)=rr0ss(i) - rdivr0(i,l_ss_a2)=rr0ss(i) - rdivr0(i,l_ss_a3)=rr0ss(i) - - rdivr0(i,l_soa_na)=rr0bcoc(i) - end do - end subroutine inittabrh - - !=============================================================================== - subroutine qqcw_set_ptr(index, iptr) - integer, intent(in) :: index, iptr - if(index>0 .and. index <= pcnst ) then - qqcw(index)=iptr - else - call endrun('qqcw_set_ptr: attempting to set qqcw pointer already defined') - end if - end subroutine qqcw_set_ptr - - !=============================================================================== - function qqcw_get_field(pbuf, index) - use physics_buffer, only : physics_buffer_desc, pbuf_get_field - - type(physics_buffer_desc), pointer :: pbuf(:) - integer, intent(in) :: index - - real(r8), pointer :: qqcw_get_field(:,:) - - nullify(qqcw_get_field) - if (index>0 .and. index <= pcnst) then - if (qqcw(index)>0) then - call pbuf_get_field(pbuf, qqcw(index), qqcw_get_field) - endif - end if - end function qqcw_get_field - -end module oslo_aero_share diff --git a/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 b/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 deleted file mode 100644 index a15e140a4a..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_sox_cldaero.F90 +++ /dev/null @@ -1,473 +0,0 @@ -module oslo_aero_sox_cldaero - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver - use cam_abortutils, only: endrun - use mo_chem_utls, only: get_spc_ndx - use mo_constants, only: pi - use chem_mods, only: adv_mass - use physconst, only: gravit - use chem_mods, only: gas_pcnst - ! - use oslo_aero_share, only: l_so4_a2, chemistryIndex - - implicit none - private - - public :: sox_cldaero_init - public :: sox_cldaero_create_obj - public :: sox_cldaero_update - public :: sox_cldaero_destroy_obj - - private :: cldaero_uptakerate - private :: cldaero_allocate - private :: cldaero_deallocate - - type :: cldaero_conc_t - real(r8), pointer :: so4c(:,:) - real(r8), pointer :: nh4c(:,:) - real(r8), pointer :: no3c(:,:) - real(r8), pointer :: xlwc(:,:) - real(r8) :: so4_fact - end type cldaero_conc_t - public :: cldaero_conc_t - - integer :: id_msa, id_h2so4, id_so2, id_h2o2, id_nh3 - integer :: id_so4_1a - - real(r8), parameter :: small_value = 1.e-20_r8 - -!=============================================================================== -contains -!=============================================================================== - - subroutine sox_cldaero_init() - - ! module variables - id_msa = get_spc_ndx( 'MSA' ) - id_h2so4 = get_spc_ndx( 'H2SO4' ) - id_so2 = get_spc_ndx( 'SO2' ) - id_h2o2 = get_spc_ndx( 'H2O2' ) - id_nh3 = get_spc_ndx( 'NH3' ) - - if (id_h2so4<1 .or. id_so2<1 .or. id_h2o2<1) then - call endrun('sox_cldaero_init: oslo aero does not include necessary species' & - //' -- should not invoke sox_cldaero_init ') - endif - - id_so4_1a = chemistryIndex(l_so4_a2) - - end subroutine sox_cldaero_init - - !=============================================================================== - - function sox_cldaero_create_obj(cldfrc, qcw, lwc, cfact, ncol, loffset) result( conc_obj ) - - ! arguments - real(r8), intent(in) :: cldfrc(:,:) - real(r8), intent(in) :: qcw(:,:,:) - real(r8), intent(in) :: lwc(:,:) - real(r8), intent(in) :: cfact(:,:) - integer, intent(in) :: ncol - integer, intent(in) :: loffset - type(cldaero_conc_t), pointer :: conc_obj - - ! local variables - integer :: l,n - integer :: i,k - - conc_obj => cldaero_allocate() - - do k = 1,pver - do i = 1,ncol - if (cldfrc(i,k) >0._r8) then - conc_obj%xlwc(i,k) = lwc(i,k) *cfact(i,k) ! cloud water L(water)/L(air) - conc_obj%xlwc(i,k) = conc_obj%xlwc(i,k) / cldfrc(i,k) ! liquid water in the cloudy fraction of cell - else - conc_obj%xlwc(i,k) = 0._r8 - endif - enddo - enddo - - conc_obj%no3c(:,:) = 0._r8 - - ! Set concenctration of cloud so4 - conc_obj%so4c(:ncol,:) = qcw(:ncol,:,id_so4_1a) - - ! current version does not have nh3/nh4 tracers - so so4 is assumed to be nh4hso4 - ! the partial neutralization of so4 is handled by using a - ! -1 charge (instead of -2) in the electro-neutrality equation - conc_obj%nh4c(:ncol,:) = 0._r8 - - ! with 3-mode, assume so4 is nh4hso4, and so half-neutralized - conc_obj%so4_fact = 1._r8 - - end function sox_cldaero_create_obj - - !=============================================================================== - - subroutine sox_cldaero_update( & - ncol, lchnk, loffset, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, xlwc, & - delso4_hprxn, xh2so4, xso4, xso4_init, nh3g, hno3g, xnh3, xhno3, xnh4c, xno3c, xmsa, xso2, xh2o2, qcw, qin, & - aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d, aqso4_o3_3d) - - !---------------------------------------------------------------------------------- - ! Update the mixing ratios - !---------------------------------------------------------------------------------- - - ! arguments - integer, intent(in) :: ncol - integer, intent(in) :: lchnk ! chunk id - integer, intent(in) :: loffset - real(r8), intent(in) :: dtime ! time step (sec) - real(r8), intent(in) :: mbar(:,:) ! mean wet atmospheric mass ( amu ) - real(r8), intent(in) :: pdel(:,:) - real(r8), intent(in) :: press(:,:) - real(r8), intent(in) :: tfld(:,:) - real(r8), intent(in) :: cldnum(:,:) - real(r8), intent(in) :: cldfrc(:,:) - real(r8), intent(in) :: cfact(:,:) - real(r8), intent(in) :: xlwc(:,:) - real(r8), intent(in) :: delso4_hprxn(:,:) - real(r8), intent(in) :: xh2so4(:,:) - real(r8), intent(in) :: xso4(:,:) - real(r8), intent(in) :: xso4_init(:,:) - real(r8), intent(in) :: nh3g(:,:) - real(r8), intent(in) :: hno3g(:,:) - real(r8), intent(in) :: xnh3(:,:) - real(r8), intent(in) :: xhno3(:,:) - real(r8), intent(in) :: xnh4c(:,:) - real(r8), intent(in) :: xmsa(:,:) - real(r8), intent(in) :: xso2(:,:) - real(r8), intent(in) :: xh2o2(:,:) - real(r8), intent(in) :: xno3c(:,:) - real(r8), intent(inout) :: qcw(:,:,:) ! cloud-borne aerosol (vmr) - real(r8), intent(inout) :: qin(:,:,:) ! xported species ( vmr ) - real(r8), intent(out) :: aqso4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqh2so4(:,:) ! aqueous phase chemistry - real(r8), intent(out) :: aqso4_h2o2(:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out) :: aqso4_o3(:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) - real(r8), intent(out), optional :: aqso4_h2o2_3d(:,:) ! SO4 aqueous phase chemistry due to H2O2 (kg/m2) - real(r8), intent(out), optional :: aqso4_o3_3d(:,:) ! SO4 aqueous phase chemistry due to O3 (kg/m2) - - - ! local variables - real(r8) :: dqdt_aqso4(ncol,pver,gas_pcnst) - real(r8) :: dqdt_aqh2so4(ncol,pver,gas_pcnst) - real(r8) :: dqdt_aqhprxn(ncol,pver), dqdt_aqo3rxn(ncol,pver) - real(r8) :: sflx(1:ncol) - real(r8) :: delso4_o3rxn - real(r8) :: dso4dt_aqrxn, dso4dt_hprxn - real(r8) :: dso4dt_gasuptk, dmsadt_gasuptk - real(r8) :: dmsadt_gasuptk_tomsa, dmsadt_gasuptk_toso4 - real(r8) :: dqdt_aq, dqdt_wr, dqdt - real(r8) :: fwetrem, sumf, uptkrate - real(r8) :: delnh3, delnh4 - integer :: l, n, m, i,k - integer :: ntot_msa_c - real(r8) :: xl - - ! make sure dqdt is zero initially, for budgets - dqdt_aqso4(:,:,:) = 0.0_r8 - dqdt_aqh2so4(:,:,:) = 0.0_r8 - dqdt_aqhprxn(:,:) = 0.0_r8 - dqdt_aqo3rxn(:,:) = 0.0_r8 - - lev_loop: do k = 1,pver - col_loop: do i = 1,ncol - cloud: if (cldfrc(i,k) >= 1.0e-5_r8) then - xl = xlwc(i,k) ! / cldfrc(i,k) - - IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED - - delso4_o3rxn = xso4(i,k) - xso4_init(i,k) - - if (id_nh3>0) then - delnh3 = nh3g(i,k) - xnh3(i,k) - delnh4 = - delnh3 - endif - - !In the case of OSLO-AEROSOLS, - !set no MSA in cloud droplets - ntot_msa_c = 0 - - ! average uptake rate over dtime - uptkrate = cldaero_uptakerate( xl, cldnum(i,k), cfact(i,k), cldfrc(i,k), tfld(i,k), press(i,k) ) - - ! average uptake rate over dtime - uptkrate = (1.0_r8 - exp(-min(100._r8,dtime*uptkrate))) / dtime - - ! dso4dt_gasuptk = so4_c tendency from h2so4 gas uptake (mol/mol/s) - ! dmsadt_gasuptk = msa_c tendency from msa gas uptake (mol/mol/s) - dso4dt_gasuptk = xh2so4(i,k) * uptkrate - if (id_msa > 0) then - dmsadt_gasuptk = xmsa(i,k) * uptkrate - else - dmsadt_gasuptk = 0.0_r8 - end if - - ! if no modes have msa aerosol, then "rename" scavenged msa gas to so4 - dmsadt_gasuptk_toso4 = 0.0_r8 - dmsadt_gasuptk_tomsa = dmsadt_gasuptk - if (ntot_msa_c == 0) then - dmsadt_gasuptk_tomsa = 0.0_r8 - dmsadt_gasuptk_toso4 = dmsadt_gasuptk - end if - - !----------------------------------------------------------------------- - ! now compute TMR tendencies - ! this includes the above aqueous so2 chemistry AND - ! the uptake of highly soluble aerosol precursor gases (h2so4, msa, ...) - ! AND the wetremoval of dissolved, unreacted so2 and h2o2 - - dso4dt_aqrxn = (delso4_o3rxn + delso4_hprxn(i,k)) / dtime - dso4dt_hprxn = delso4_hprxn(i,k) / dtime - - ! fwetrem = fraction of in-cloud-water material that is wet removed - ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*clwlrat(i,k)))) ) - fwetrem = 0.0_r8 ! don't have so4 & msa wet removal here - - !Update so4 in cloud water - l = id_so4_1a !We only have one aq-phase tracer in CAM_OSLO - - dqdt_aqso4(i,k,l) = dso4dt_aqrxn*cldfrc(i,k) - dqdt_aqh2so4(i,k,l) = (dso4dt_gasuptk + dmsadt_gasuptk_toso4)*cldfrc(i,k) - dqdt_aq = dqdt_aqso4(i,k,l) + dqdt_aqh2so4(i,k,l) - dqdt_wr = -fwetrem*dqdt_aq !wet removal set to zero above - dqdt= dqdt_aq + dqdt_wr - qcw(i,k,l) = qcw(i,k,l) + dqdt*dtime - - !Additional updates for MSA?? - ! For gas species, tendency includes - ! reactive uptake to cloud water that essentially transforms the gas to - ! a different species. Wet removal associated with this is applied - ! to the "new" species (e.g., so4_c) rather than to the gas. - ! wet removal of the unreacted gas that is dissolved in cloud water. - ! Need to multiply both these parts by cldfrc - - ! h2so4 (g) & msa (g) - qin(i,k,id_h2so4) = qin(i,k,id_h2so4) - dso4dt_gasuptk * dtime * cldfrc(i,k) - if (id_msa > 0) qin(i,k,id_msa) = qin(i,k,id_msa) - dmsadt_gasuptk * dtime * cldfrc(i,k) - - - ! so2 -- the first order loss rate for so2 is frso2_c*clwlrat(i,k) - ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frso2_c*clwlrat(i,k)))) ) - fwetrem = 0.0_r8 ! don't include so2 wet removal here - - dqdt_wr = -fwetrem*xso2(i,k)/dtime*cldfrc(i,k) - dqdt_aq = -dso4dt_aqrxn*cldfrc(i,k) - dqdt = dqdt_aq + dqdt_wr - qin(i,k,id_so2) = qin(i,k,id_so2) + dqdt * dtime - - ! h2o2 -- the first order loss rate for h2o2 is frh2o2_c*clwlrat(i,k) - ! fwetrem = max( 0.0_r8, (1.0_r8-exp(-min(100._r8,dtime*frh2o2_c*clwlrat(i,k)))) ) - fwetrem = 0.0_r8 ! don't include h2o2 wet removal here - - dqdt_wr = -fwetrem*xh2o2(i,k)/dtime*cldfrc(i,k) - dqdt_aq = -dso4dt_hprxn*cldfrc(i,k) - dqdt = dqdt_aq + dqdt_wr - qin(i,k,id_h2o2) = qin(i,k,id_h2o2) + dqdt * dtime - - ! NH3 - if (id_nh3>0) then - dqdt_aq = delnh3/dtime*cldfrc(i,k) - dqdt = dqdt_aq - qin(i,k,id_nh3) = qin(i,k,id_nh3) + dqdt * dtime - endif - - ! for SO4 from H2O2/O3 budgets - dqdt_aqhprxn(i,k) = dso4dt_hprxn*cldfrc(i,k) - dqdt_aqo3rxn(i,k) = (dso4dt_aqrxn - dso4dt_hprxn)*cldfrc(i,k) - - ENDIF !! WHEN CLOUD IS PRESENTED - - endif cloud - enddo col_loop - enddo lev_loop - - ! Update the mixing ratios - do k = 1,pver - qcw(:,k,id_so4_1a) = MAX( qcw(:,k,id_so4_1a), small_value ) - qin(:,k,id_so2) = MAX( qin(:,k,id_so2), small_value ) - if ( id_nh3 > 0 ) then - qin(:,k,id_nh3) = MAX( qin(:,k,id_nh3), small_value ) - endif - end do - - ! diagnostics - l = id_so4_1a !Index of the a2-tracer in cloud water - n = 1 !Only distribute to one "mode" - aqso4(:,n)=0._r8 - do k=1,pver - do i=1,ncol - aqso4(i,n)=aqso4(i,n)+dqdt_aqso4(i,k,l)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg/m2/s - enddo - enddo - - aqh2so4(:,n)=0._r8 - do k=1,pver - do i=1,ncol - aqh2so4(:,n)=aqh2so4(:,n)+dqdt_aqh2so4(i,k,l)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg/m2/s - enddo - enddo - - aqso4_h2o2(:) = 0._r8 - do k=1,pver - do i=1,ncol - aqso4_h2o2(i)=aqso4_h2o2(i)+dqdt_aqhprxn(i,k)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - - if (present(aqso4_h2o2_3d)) then - aqso4_h2o2_3d(:,:) = 0._r8 - do k=1,pver - do i=1,ncol - aqso4_h2o2_3d(i,k)=dqdt_aqhprxn(i,k)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - end if - - aqso4_o3(:)=0._r8 - do k=1,pver - do i=1,ncol - aqso4_o3(i)=aqso4_o3(i)+dqdt_aqo3rxn(i,k)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - - if (present(aqso4_o3_3d)) then - aqso4_o3_3d(:,:)=0._r8 - do k=1,pver - do i=1,ncol - aqso4_o3_3d(i,k)=dqdt_aqo3rxn(i,k)*adv_mass(l)/mbar(i,k) & - *pdel(i,k)/gravit ! kg SO4 /m2/s - enddo - enddo - end if - - end subroutine sox_cldaero_update - - !=============================================================================== - - subroutine sox_cldaero_destroy_obj( conc_obj ) - type(cldaero_conc_t), pointer :: conc_obj - call cldaero_deallocate( conc_obj ) - end subroutine sox_cldaero_destroy_obj - - !=============================================================================== - - function cldaero_allocate( ) result( cldconc ) - type(cldaero_conc_t), pointer:: cldconc - - allocate( cldconc ) - allocate( cldconc%so4c(pcols,pver) ) - allocate( cldconc%nh4c(pcols,pver) ) - allocate( cldconc%no3c(pcols,pver) ) - allocate( cldconc%xlwc(pcols,pver) ) - - cldconc%so4c(:,:) = 0._r8 - cldconc%nh4c(:,:) = 0._r8 - cldconc%no3c(:,:) = 0._r8 - cldconc%xlwc(:,:) = 0._r8 - cldconc%so4_fact = 2._r8 - - end function cldaero_allocate - - !=============================================================================== - - subroutine cldaero_deallocate( cldconc ) - type(cldaero_conc_t), pointer :: cldconc - - if ( associated(cldconc%so4c) ) then - deallocate(cldconc%so4c) - nullify(cldconc%so4c) - endif - - if ( associated(cldconc%nh4c) ) then - deallocate(cldconc%nh4c) - nullify(cldconc%nh4c) - endif - - if ( associated(cldconc%no3c) ) then - deallocate(cldconc%no3c) - nullify(cldconc%no3c) - endif - - if ( associated(cldconc%xlwc) ) then - deallocate(cldconc%xlwc) - nullify(cldconc%xlwc) - endif - - deallocate( cldconc ) - nullify( cldconc ) - - end subroutine cldaero_deallocate - - !=============================================================================== - - function cldaero_uptakerate( xl, cldnum, cfact, cldfrc, tfld, press ) result( uptkrate ) - - ! compute uptake of h2so4 and msa to cloud water - ! first-order uptake rate is - ! 4*pi*(drop radius)*(drop number conc) - ! *(gas diffusivity)*(fuchs sutugin correction) - - ! arguments / output - real(r8), intent(in) :: xl, cldnum, cfact, cldfrc, tfld, press - real(r8) :: uptkrate - - ! local variables - real(r8) :: rad_cd, radxnum_cd, num_cd - real(r8) :: gasdiffus, gasspeed, knudsen - real(r8) :: fuchs_sutugin, volx34pi_cd - - ! num_cd = (drop number conc in 1/cm^3) - num_cd = 1.0e-3_r8*cldnum*cfact/cldfrc - num_cd = max( num_cd, 0.0_r8 ) - - ! rad_cd = (drop radius in cm), computed from liquid water and drop number, - ! then bounded by 0.5 and 50.0 micrometers - ! radxnum_cd = (drop radius)*(drop number conc) - ! volx34pi_cd = (3/4*pi) * (liquid water volume in cm^3/cm^3) - - volx34pi_cd = xl*0.75_r8/pi - - ! following holds because volx34pi_cd = num_cd*(rad_cd**3) - radxnum_cd = (volx34pi_cd*num_cd*num_cd)**0.3333333_r8 - - ! apply bounds to rad_cd to avoid the occasional unphysical value - if (radxnum_cd .le. volx34pi_cd*4.0e4_r8) then - radxnum_cd = volx34pi_cd*4.0e4_r8 - rad_cd = 50.0e-4_r8 - else if (radxnum_cd .ge. volx34pi_cd*4.0e8_r8) then - radxnum_cd = volx34pi_cd*4.0e8_r8 - rad_cd = 0.5e-4_r8 - else - rad_cd = radxnum_cd/num_cd - end if - - ! gasdiffus = h2so4 gas diffusivity from mosaic code (cm^2/s) (pmid must be Pa) - gasdiffus = 0.557_r8 * (tfld**1.75_r8) / press - - ! gasspeed = h2so4 gas mean molecular speed from mosaic code (cm/s) - gasspeed = 1.455e4_r8 * sqrt(tfld/98.0_r8) - - ! knudsen number - knudsen = 3.0_r8*gasdiffus/(gasspeed*rad_cd) - - ! following assumes accomodation coefficient = 0.65 - ! (Adams & Seinfeld, 2002, JGR, and references therein) - ! fuchs_sutugin = (0.75*accom*(1. + knudsen)) / - ! (knudsen*(1.0 + knudsen + 0.283*accom) + 0.75*accom) - fuchs_sutugin = (0.4875_r8*(1._r8 + knudsen)) / (knudsen*(1.184_r8 + knudsen) + 0.4875_r8) - - ! instantaneous uptake rate - uptkrate = 12.56637_r8*radxnum_cd*gasdiffus*fuchs_sutugin - - end function cldaero_uptakerate - -end module oslo_aero_sox_cldaero diff --git a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 b/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 deleted file mode 100644 index 945b54a978..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_sw_tables.F90 +++ /dev/null @@ -1,2766 +0,0 @@ -module oslo_aero_sw_tables - - ! Purpose: To read in SW look-up tables for calculation of aerosol optical properties, - ! and to define the grid for discrete input-values in these look-up tables. - - ! Purpose: To interpolate between look-up table entries for SW optical aerosol properties. - ! Optimized for speed by Arild Burud and Egil Storen (NoSerC), June-July 2002 - ! Updated for new kcomp1.out including condensed SOA - Alf Kirkevaag, May 2013. - ! Extended for new SOA treatment for kcomp1-4.out and treating SOA as coagulated OC - ! for kcomp5-10 - Alf Kirkevaag, August 2015, and also rewritten to a more generalized - ! for for interpolations using common subroutines interpol*dim. - - ! Modified for new wavelength bands and look-up tables - Alf Kirkevaag Dec. 2013. - ! Updated for reading input files with extra header info - Alf Kirkevaag, May 2015. - ! Extended for new SOA treatment - Alf Kirkevaag, August 2015. - ! Added output (ASCII) Jabuary 2016: #ifdef COLTST4INTCONS -> extinction - ! koefficients (wrt. all added mass including condensed water vapour) are - ! written out for checking against the look-up tables (using xmgrace), e.g. - ! as function of RH (to be changed to whatever parameter the user is interested in) - ! Modified for optimized added masses and mass fractions for concentrations from - ! condensation, coagulation or cloud-processing - Alf Kirkevaag, May 2016. - ! Modified cate values for kcomp=2 (as in AeroTab) - Alf Kirkevaag October 2016. - - ! Internal mixtures of process-tagged mass - ! cate : total added mass (µg/m3 per particle per cm3) from condensation - ! and wet phase chemistry/cloud processing, for kcomp = 1-2. - ! cate should be scaled up/down whenever the modal parameters (modal - ! radius and width) are increased/decreased a lot. - ! cat : total added mass (µg/m3 per particle per cm-3) from coagulation, condensation - ! and wet phase chemistry/cloud processing, for kcomp = 5-10. - ! cat should be scaled up/down whenever the modal parameters (modal - ! radius and width) are increased/decreased a lot. - ! fac : mass fraction of cat or cate from coagulating carbonaceous aerosols (BC+OM). - ! The remaining mass cate*(1-fac) or cat*(1-fac) is SO4. - ! fbc : mass fraction of BC from coagulating carbonaceous aerosols, BC/(BC+OM). - ! faq : mass fraction of sulfate which is produced in wet-phase, SO4aq/SO4. - ! The remaining SO4 mass, SO4*(1-faq), is from condensation. - - use shr_kind_mod , only: r8 => shr_kind_r8 - use ppgrid , only: pcols, pver - use cam_logfile , only: iulog - ! - use oslo_aero_control , only: oslo_aero_getopts, dir_string_length - use oslo_aero_linear_interp , only: lininterpol3dim, lininterpol4dim, lininterpol5dim - use oslo_aero_params , only: nmodes, nbmodes - - implicit none - private - - ! Interfaces - public :: initopt - public :: initopt_lw - public :: inputForInterpol - public :: interpol0 - public :: interpol1 - public :: interpol2to3 - public :: interpol4 - public :: interpol5to10 - - integer, public, parameter :: nbands=14 ! number of aerosol spectral bands in SW - integer, public, parameter :: nbmp1=11 ! number of first non-background mode - - real(r8), public, dimension(10) :: rh - real(r8), public, dimension(6) :: fombg, fbcbg, fac, fbc, faq - real(r8), public, dimension(4,16) :: cate - real(r8), public, dimension(5:10,6) :: cat - - real(r8), public :: om1(nbands,10,6,16,6) - real(r8), public :: g1 (nbands,10,6,16,6) - real(r8), public :: be1(nbands,10,6,16,6) - real(r8), public :: ke1(nbands,10,6,16,6) - - real(r8), public :: om2to3(nbands,10,16,6,2:3) - real(r8), public :: g2to3 (nbands,10,16,6,2:3) - real(r8), public :: be2to3(nbands,10,16,6,2:3) - real(r8), public :: ke2to3(nbands,10,16,6,2:3) - - real(r8), public :: om4(nbands,10,6,16,6,6) - real(r8), public :: g4 (nbands,10,6,16,6,6) - real(r8), public :: be4(nbands,10,6,16,6,6) - real(r8), public :: ke4(nbands,10,6,16,6,6) - - real(r8), public :: om0(nbands) - real(r8), public :: g0(nbands) - real(r8), public :: be0(nbands) - real(r8), public :: ke0(nbands) - - real(r8), public :: om5to10(nbands,10,6,6,6,6,5:10) - real(r8), public :: g5to10(nbands,10,6,6,6,6,5:10) - real(r8), public :: be5to10(nbands,10,6,6,6,6,5:10) - real(r8), public :: ke5to10(nbands,10,6,6,6,6,5:10) - - ! relative humidity (RH, as integer for output variable names) for use in AeroCom code - integer, public, dimension(6) :: RF = (/0, 40, 55, 65, 75, 85 /) - - ! AeroCom specific RH input variables for use in opticsAtConstRh.F90 - integer , public :: irhrf1(6) - real(r8), public :: xrhrf(6) - - real(r8), public :: e, eps - parameter (e=2.718281828_r8, eps=1.0e-30_r8) - - ! Array bounds in the tabulated optical parameters - integer, public, parameter :: nlwbands=16 ! number of aerosol spectral bands in LW - - real(r8), public :: ka0(nlwbands) - real(r8), public :: ka1(nlwbands,10,6,16,6) - real(r8), public :: ka2to3(nlwbands,10,16,6,2:3) - real(r8), public :: ka4(nlwbands,10,6,16,6,6) - real(r8), public :: ka5to10(nlwbands,10,6,6,6,6,5:10) - -contains - - subroutine initopt() - - !--------------------------------------------------------------- - ! Modified for new aerosol schemes by Alf Kirkevaag in January - ! 2006. Modified for new wavelength bands and look-up tables - ! by Alf Kirkevaag in December 2013, and for SOA in August 2015. - !--------------------------------------------------------------- - - ! Local variables - integer :: kcomp, iwl, irelh, ictot, ifac, ifbc, ifaq, i, irf - integer :: ifombg, ifbcbg - integer :: ik, ic, ifil, lin, linmax - real(r8) :: catot, relh, frac, fabc, fraq, frombg, frbcbg - real(r8) :: ssa, ass, ext, spext - real(r8) :: eps2 = 1.e-2_r8 - real(r8) :: eps3 = 1.e-3_r8 - real(r8) :: eps4 = 1.e-4_r8 - real(r8) :: eps6 = 1.e-6_r8 - character(len=dir_string_length) :: aerotab_table_dir - !----------------------------------------------------------- - - ! Defining array bounds for tabulated optical parameters (and r and sigma) - ! relative humidity (only 0 value used for r and sigma tables): - rh = (/ 0.0_r8, 0.37_r8, 0.47_r8, 0.65_r8, 0.75_r8, 0.8_r8, 0.85_r8, 0.9_r8, 0.95_r8, 0.995_r8 /) - - ! AeroCom specific RH input variables for use in opticsAtConstRh.F90 - do irf=1,6 - xrhrf(irf) = real(RF(irf))*0.01_r8 - enddo - do irelh=1,9 - do irf=1,6 - if(xrhrf(irf)>=rh(irelh).and.xrhrf(irf)<=rh(irelh+1)) then - irhrf1(irf)=irelh - endif - end do - end do - - ! mass fractions internal mixtures in background (fombg and fbcbg) and mass added to the - ! background modes (fac, faq, faq) - fombg = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) - fac = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) - faq = (/ 0.0_r8, 0.2_r8, 0.4_r8, 0.6_r8, 0.8_r8, 1.0_r8 /) - - ! with more weight on low fractions (thus a logaritmic f axis) for BC, - ! which is less ambundant than sulfate and OC, and the first value - ! corresponding to a clean background mode: - fbcbg(1)=1.e-10_r8 - fbc(1)=1.e-10_r8 - do i=2,6 - fbcbg(i)=10**((i-1)/4.0_r8-1.25_r8) - fbc(i)=fbcbg(i) - end do - ! and most weight on small concentrations for added mass onto the background: - do kcomp=1,4 - cate(kcomp,1)=1.e-10_r8 - do i=2,16 - if(kcomp.eq.1.or.kcomp.eq.2) then - cate(kcomp,i)=10.0_r8**((i-1)/3.0_r8-6.222_r8) - elseif(kcomp.eq.3) then - cate(kcomp,i)=1.0e-10_r8 ! not used - else - cate(kcomp,i)=10.0_r8**((i-1)/3.0_r8-4.301_r8) - endif - end do - end do - do kcomp=5,10 - cat(kcomp,1) =1.e-10_r8 - do i=2,6 - if(kcomp.eq.5) then - cat(kcomp,i)=10.0_r8**((i-1)-3.824_r8) - elseif(kcomp.eq.6) then - cat(kcomp,i)=10.0_r8**((i-1)-3.523_r8) - elseif(kcomp.eq.7) then - cat(kcomp,i)=10.0_r8**((i-1)-3.699_r8) - elseif(kcomp.eq.8) then - cat(kcomp,i)=10.0_r8**((i-1)-4.921_r8) - elseif(kcomp.eq.9) then - cat(kcomp,i)=10.0_r8**((i-1)-3.301_r8) - else - cat(kcomp,i)=10.0_r8**((i-1)-3.699_r8) - endif - end do - end do - - call oslo_aero_getopts(aerotab_table_dir_out= aerotab_table_dir) - - ! Opening the 'kcomp'-files: - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - open(50,file=trim(aerotab_table_dir)//'/kcomp0.out' ,form='formatted',status='old') - open(40,file=trim(aerotab_table_dir)//'/kcomp1.out' ,form='formatted',status='old') - open(41,file=trim(aerotab_table_dir)//'/kcomp2.out' ,form='formatted',status='old') - open(42,file=trim(aerotab_table_dir)//'/kcomp3.out' ,form='formatted',status='old') - open(43,file=trim(aerotab_table_dir)//'/kcomp4.out' ,form='formatted',status='old') - open(44,file=trim(aerotab_table_dir)//'/kcomp5.out' ,form='formatted',status='old') - open(45,file=trim(aerotab_table_dir)//'/kcomp6.out' ,form='formatted',status='old') - open(46,file=trim(aerotab_table_dir)//'/kcomp7.out' ,form='formatted',status='old') - open(47,file=trim(aerotab_table_dir)//'/kcomp8.out' ,form='formatted',status='old') - open(48,file=trim(aerotab_table_dir)//'/kcomp9.out' ,form='formatted',status='old') - open(49,file=trim(aerotab_table_dir)//'/kcomp10.out',form='formatted',status='old') - - ! Skipping the header-text in all input files (Later: use it to check AeroTab - CAM5-Oslo consistency!) - do ifil = 40,50 - call checkTableHeader (ifil) - enddo - - ! Then reading in the look-up table entries for each file (kcomp*.out) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! Mode 0, BC(ax) - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - ifil = 11 - linmax=nbands - do lin = 1,linmax - read(39+ifil,'(2I3,f8.3,4(x,e12.5))') kcomp, iwl, relh, ssa, ass, ext, spext - om0(iwl)=ssa - g0 (iwl)=ass - be0(iwl)=ext ! unit km^-1 - ke0(iwl)=spext ! unit m^2/g - ! write(iulog,*) 'kcomp, om =', kcomp, om0(iwl) - ! write(iulog,*) 'kcomp, g =', kcomp, g0(iwl) - ! write(iulog,*) 'kcomp, be =', kcomp, be0(iwl) - ! write(iulog,*) 'kcomp, ke =', kcomp, ke0(iwl) - end do - - do iwl=1,nbands - if(be0(iwl)<=0.0_r8) then - write(iulog,*) 'be0 =', iwl, be0(iwl) - write(iulog,*) 'Error in initialization of be0' - stop - endif - enddo - - write(iulog,*)'mode 0 ok' - - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! Mode 1 (H2SO4 and SOA + condesate from H2SO4 and SOA) - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - - linmax = nbands*10*6*16*6 ! 14*10*6*16*6 - do lin = 1,linmax - - read(40,'(2I3,f8.3,3(x,e10.3),4(x,e12.5))') kcomp, iwl, relh, frombg, catot, frac, ssa, ass, ext, spext - - do ic=1,10 - if(abs(relh-rh(ic))= rh(irelh) .and. xrh(icol,k)<=rh(irelh+1)) then - irh1(icol,k)=irelh - endif - end do - end do - end do - - do k=1,pver - do icol=1,ncol - ! find common xfombg, ifombg1 and ifombg2 for use in the interpolation routines - xfombg(icol,k) =min(max(f_soana(icol,k),fombg(1)),fombg(6)) - ifombg1(icol,k)=int(5.0_r8*xfombg(icol,k)-eps10)+1 - end do - enddo - - do k=1,pver - do icol=1,ncol - ! find common xfbcbg, ifbcbg1 and ifbcbg2 for use in the interpolation routines - xfbcbg(icol,k) =min(max(faitbc(icol,k),fbcbg(1)),fbcbg(6)) - ifbcbg1(icol,k)=min(max(int(4*log10(xfbcbg(icol,k))+6),1),5) - - ! find common xfbcbgn, ifbcbgn1 and ifbcbgn2 for use in the interpolation routines - xfbcbgn(icol,k) =min(max(fnbc(icol,k),fbcbg(1)),fbcbg(6)) - ifbcbgn1(icol,k)=min(max(int(4*log10(xfbcbgn(icol,k))+6),1),5) - end do - enddo - - do i=1,4 - do k=1,pver - do icol=1,ncol - ! find common xfac, ifac1 and ifac2 for use in the interpolation routines - xfac(icol,k,i) =min(max(focm(icol,k,i),fac(1)),fac(6)) - ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 - end do - enddo - enddo - do i=5,nbmodes - do k=1,pver - do icol=1,ncol - ! find common xfac, ifac1 and ifac2 for use in the interpolation routines - xfac(icol,k,i) =min(max(fcm(icol,k,i),fac(1)),fac(6)) - ifac1(icol,k,i)=int(5.0_r8*xfac(icol,k,i)-eps10)+1 - end do - enddo - enddo - - do i=1,nbmodes - do k=1,pver - do icol=1,ncol - ! find common xfbc, ifbc1 and ifbc2 for use in the interpolation routines - xfbc(icol,k,i) =min(max(fbcm(icol,k,i),fbc(1)),fbc(6)) - ifbc1(icol,k,i)=min(max(int(4*log10(xfbc(icol,k,i))+6),1),5) - end do - enddo - enddo - - do i=1,nbmodes - do k=1,pver - do icol=1,ncol - ! find common xfaq, ifaq1 and ifaq2 for use in the interpolation routines - xfaq(icol,k,i) =min(max(faqm(icol,k,i),faq(1)),faq(6)) - ifaq1(icol,k,i)=int(5.0_r8*xfaq(icol,k,i)-eps10)+1 - end do - enddo - enddo - - ! find common xct, ict1 and ict2 for use in the interpolation routines - do i=1,4 - do k=1,pver - do icol=1,ncol - xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cate(i,1)),cate(i,16)) - if(i.le.2) then - ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+19.666_r8),1),15) - elseif(i.eq.3) then ! mode not used - xct(icol,k,i)=cate(i,1) - ict1(icol,k,i)=1 - else - ict1(icol,k,i)=min(max(int(3*log10(xct(icol,k,i))+13.903_r8),1),15) - endif - end do - end do - end do - - do i=5,10 - do k=1,pver - do icol=1,ncol - xct(icol,k,i)=min(max(Cam(icol,k,i)/(Nnatk(icol,k,i)+eps),cat(i,1)),cat(i,6)) - if(i.eq.5) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.824_r8),1),5) - elseif(i.eq.6) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.523_r8),1),5) - elseif(i.eq.7) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) - elseif(i.eq.8) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+5.921_r8),1),5) - elseif(i.eq.9) then - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.301_r8),1),5) - else - ict1(icol,k,i)=min(max(int(log10(xct(icol,k,i))+4.699_r8),1),5) - endif - end do - end do - end do - - do i=11,nmodes ! for the externally mixed modes 11-14 (now only 12 and 14) - do k=1,pver - do icol=1,ncol - xct(icol,k,i)=cate(i-10,1) - ict1(icol,k,i)=1 - end do - end do - end do - - return - - end subroutine inputForInterpol - - !******************************************************************************************** - subroutine interpol0 (lchnk, ncol, daylight, Nnatk, omega, gass, bex, ske, lw_on, kabs) - ! - ! Arguments - integer , intent(in) :: lchnk ! chunk identifier - integer , intent(in) :: ncol ! number of atmospheric columns - logical , intent(in) :: daylight(pcols) ! calculations also at (polar) night if daylight=.true. - logical , intent(in) :: lw_on ! LW calculations are performed if true - real(r8) , intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8) , intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8) , intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8) , intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8) , intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8) , intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands) ! LW spectral modal specific absorption coefficient - ! - ! Local variables - integer i, kcomp, k, icol - !--------------------------------------- - - kcomp=0 - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kcomp,i)=0.0_r8 - gass(icol,k,kcomp,i)=0.0_r8 - bex(icol,k,kcomp,i)=0.0_r8 - ske(icol,k,kcomp,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kcomp,i)=0.0_r8 - end do - end do - end do - - ! SW optical parameters - - do k=1,pver - do icol=1,ncol - ! if(Nnatk(icol,k,kcomp)>0.0_r8) then - if(daylight(icol)) then - do i=1,nbands ! i = wavelength index - omega(icol,k,kcomp,i)=om0(i) - gass(icol,k,kcomp,i)=g0(i) - bex(icol,k,kcomp,i)=be0(i) - ske(icol,k,kcomp,i)=ke0(i) - end do ! i - else ! daylight - ! Need be and ke in nband=4 for lw calculation - bex(icol,k,kcomp,4)=be0(4) - ske(icol,k,kcomp,4)=ke0(4) - end if ! daylight - end do ! icol - end do ! k - - ! LW optical parameters - - if(lw_on) then - do k=1,pver - do icol=1,ncol - do i=1,nlwbands ! i = wavelength index - kabs(icol,k,kcomp,i)=ka0(i) - end do ! i - end do ! icol - end do ! k - - endif ! lw_on - - end subroutine interpol0 - - !******************************************************************************************** - subroutine interpol1 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfombg, ifombg1, & - xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) - - ! - ! Arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xfombg(pcols,pver) ! SOA/(SOA+H2SO4) for the background mode - integer, intent(in) :: ifombg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absoption coefficient - ! - ! Local variables - integer i, kcomp, k, icol, kc10 - real(r8) a, b - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2, t_ifo1, t_ifo2 - real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2 - real(r8) t_cat1, t_cat2, t_fombg1, t_fombg2, t_xfombg - real(r8) d2mx(4), dxm1(4), invd(4) - real(r8) opt4d(2,2,2,2) - real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) kabs1, kabs2 - !--------------------------------------- - - ! write(*,*) 'Before kcomp-loop' - do kcomp=1,1 - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - ! write(*,*) 'Before init-loop', kc10 - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kc10,i)=0.0_r8 - gass(icol,k,kc10,i)=0.0_r8 - bex(icol,k,kc10,i)=0.0_r8 - ske(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifo1 = ifombg1(icol,k) - t_ifo2 = t_ifo1+1 - - t_rh1 = rh(t_irh1) - !x t_rh2 = t_rh1+1 - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fombg1 = fombg(t_ifo1) - t_fombg2 = fombg(t_ifo2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfombg = xfombg(icol,k) - - ! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fombg2-t_xfombg) - dxm1(2) = (t_xfombg-t_fombg1) - invd(2) = 1.0_r8/(t_fombg2-t_fombg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - - - ! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! single scattering albedo: - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=om1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=om1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=om1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=om1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=om1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=om1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=om1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=om1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, ome1, ome2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before omega' - omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) /(t_rh2-t_rh1) - !alt omega(icol,k,kc10,i)=(d2mx(1)*ome1+dxm1(1)*ome2)*invd(1) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! asymmetry factor - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=g1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=g1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=g1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=g1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=g1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=g1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=g1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=g1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, ge1, ge2) - - ! finally, interpolation in the rh dimension (dim. 1) - ! write(*,*) 'Before gass' - gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) /(t_rh2-t_rh1) - !alt gass(icol,k,kc10,i)=(d2mx(1)*ge1+dxm1(1)*ge2)*invd(1) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) /(t_rh2-t_rh1) - !alt bex(icol,k,kc10,i)=(d2mx(1)*bex1+dxm1(1)*bex2)*invd(1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - !alt a=(log(bex2)-log(bex1))*invd(1) - !alt b=(t_rh2*log(bex1)-t_rh1*log(bex2))*invd(1) - !alt bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - ! if(bex(icol,k,kc10,8)<1.e-20_r8) then - ! write(*,995) 'bex(8)=', kc10, t_xrh, t_xct, t_xfac, t_xfombg, bex(icol,k,kc10,8) - ! endif - else ! daylight - - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction used for size information in LW - - i=4 - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=be1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=be1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=be1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=be1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=be1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=be1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=be1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=be1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - do i=4,4 ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific extinction - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=ke1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=ke1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=ke1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=ke1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=ke1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=ke1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=ke1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=ke1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, ske1, ske2) - - ske1=max(ske1,1.e-30_r8) - ske2=max(ske2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before ske' - if(t_xrh <= 0.37_r8) then - ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - !alt ske(icol,k,kc10,i)=(d2mx(1)*ske1+dxm1(1)*ske2)*invd(1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kc10,i)=e**(a*t_xrh+b) - !alt a=(log(ske2)-log(ske1))*invd(1) - !alt b=(t_rh2*log(ske1)-t_rh1*log(ske2))*invd(1) - !alt ske(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - if (lw_on) then - - ! LW optical parameters - do i=1,nlwbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific absorption in LW - - ! end points as basis for multidimentional linear interpolation - opt4d(1,1,1,1)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc1) - opt4d(1,1,1,2)=ka1(i,t_irh1,t_ifo1,t_ict1,t_ifc2) - opt4d(1,1,2,1)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc1) - opt4d(1,1,2,2)=ka1(i,t_irh1,t_ifo1,t_ict2,t_ifc2) - opt4d(1,2,1,1)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc1) - opt4d(1,2,1,2)=ka1(i,t_irh1,t_ifo2,t_ict1,t_ifc2) - opt4d(1,2,2,1)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc1) - opt4d(1,2,2,2)=ka1(i,t_irh1,t_ifo2,t_ict2,t_ifc2) - opt4d(2,1,1,1)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc1) - opt4d(2,1,1,2)=ka1(i,t_irh2,t_ifo1,t_ict1,t_ifc2) - opt4d(2,1,2,1)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc1) - opt4d(2,1,2,2)=ka1(i,t_irh2,t_ifo1,t_ict2,t_ifc2) - opt4d(2,2,1,1)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc1) - opt4d(2,2,1,2)=ka1(i,t_irh2,t_ifo2,t_ict1,t_ifc2) - opt4d(2,2,2,1)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc1) - opt4d(2,2,2,2)=ka1(i,t_irh2,t_ifo2,t_ict2,t_ifc2) - - ! interpolation in the fac, cat and fombg dimensions - call lininterpol4dim (d2mx, dxm1, invd, opt4d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30) - kabs2=max(kabs2,1.e-30) - - ! write(*,*) 'Before kabs' - if(t_xrh <= 0.37) then - kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - - ! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) - ! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) - ! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) - ! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) - - end do ! kcomp - - return - end subroutine interpol1 - - - !******************************************************************************************** - subroutine interpol2to3 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, & - xct, ict1, xfac, ifac1, omega, gass, bex, ske, lw_on, kabs) - - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - - ! Output arguments - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient - ! - ! Local variables - integer i, kcomp, k, icol, kc10 - real(r8) a, b - integer t_irh1, t_irh2, t_ict1, t_ict2, t_ifc1, t_ifc2 - real(r8) t_fac1, t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2,t_cat1, t_cat2 - real(r8) d2mx(3), dxm1(3), invd(3) - real(r8) opt3d(2,2,2) - real(r8) ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) kabs1, kabs2 - !--------------------------------------- - - ! write(*,*) 'Before kcomp-loop' - ! do kcomp=2,3 - do kcomp=2,2 - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - ! write(*,*) 'Before init-loop', kc10 - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kc10,i)=0.0_r8 - gass(icol,k,kc10,i)=0.0_r8 - bex(icol,k,kc10,i)=0.0_r8 - ske(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - ! write(*,*) 't_irh1,t_irh2=',t_irh1,t_irh2 - ! write(*,*) 't_ict1,t_ict2=',t_ict1,t_ict2 - ! write(*,*) 't_ifc1,t_ifc2=',t_ifc1,t_ifc2 - ! write(*,*) 't_ifa1,t_ifa2=',t_ifa1,t_ifa2 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - - ! write(*,*) 't_rh1,t_rh2,t_cat1,t_cat2=',t_rh1,t_rh2,t_cat1,t_cat2 - ! write(*,*) 't_fac1,t_fac2=',t_fac1,t_fac2 - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - - ! partial lengths along each dimension (1-4) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - - - ! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! single scattering albedo: - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=om2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=om2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=om2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=om2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=om2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=om2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=om2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=om2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, ome1, ome2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before omega' - omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & - /(t_rh2-t_rh1) - ! write(*,*) omega(icol,k,kc10,i) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! asymmetry factor - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=g2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=g2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=g2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=g2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=g2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=g2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=g2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=g2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, ge1, ge2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before gass' - gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) - ! write(*,*) gass(icol,k,kc10,i) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) - - bex1=max(bex1,1.e-30) - bex2=max(bex2,1.e-30) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - else ! daylight - - - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction used for LW size information - - i=4 - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=be2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=be2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=be2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=be2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=be2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=be2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=be2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=be2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, bex1, bex2) - - bex1=max(bex1,1.e-30) - bex2=max(bex2,1.e-30) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - - - do i=4,4 ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific extinction - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=ke2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=ke2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=ke2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=ke2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=ke2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=ke2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=ke2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=ke2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, ske1, ske2) - - ske1=max(ske1,1.e-30) - ske2=max(ske2,1.e-30) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before ske' - if(t_xrh <= 0.37) then - ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - - ! LW optical parameters - do i=1,nlwbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific absorption in LW - - ! end points as basis for multidimentional linear interpolation - opt3d(1,1,1)=ka2to3(i,t_irh1,t_ict1,t_ifc1,kcomp) - opt3d(1,1,2)=ka2to3(i,t_irh1,t_ict1,t_ifc2,kcomp) - opt3d(1,2,1)=ka2to3(i,t_irh1,t_ict2,t_ifc1,kcomp) - opt3d(1,2,2)=ka2to3(i,t_irh1,t_ict2,t_ifc2,kcomp) - opt3d(2,1,1)=ka2to3(i,t_irh2,t_ict1,t_ifc1,kcomp) - opt3d(2,1,2)=ka2to3(i,t_irh2,t_ict1,t_ifc2,kcomp) - opt3d(2,2,1)=ka2to3(i,t_irh2,t_ict2,t_ifc1,kcomp) - opt3d(2,2,2)=ka2to3(i,t_irh2,t_ict2,t_ifc2,kcomp) - - ! interpolation in the (fac and) cat dimension - call lininterpol3dim (d2mx, dxm1, invd, opt3d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30_r8) - kabs2=max(kabs2,1.e-30_r8) - - ! write(*,*) 'Before kabs' - if(t_xrh <= 0.37_r8) then - kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - - ! write(*,*) 'kcomp, omega(1,26,kcomp,4)=', kcomp, omega(1,26,kcomp,4) - ! write(*,*) 'kcomp, gass(1,26,kcomp,4)=', kcomp, gass(1,26,kcomp,4) - ! write(*,*) 'kcomp, bex(1,26,kcomp,4)=', kcomp, bex(1,26,kcomp,4) - ! write(*,*) 'kcomp, ske(1,26,kcomp,4)=', kcomp, ske(1,26,kcomp,4) - - end do ! kcomp - - return - end subroutine interpol2to3 - - !******************************************************************************************** - - subroutine interpol4 (lchnk, ncol, daylight, xrh, irh1, mplus10, Nnatk, xfbcbg, ifbcbg1, & - xct, ict1, xfac, ifac1, xfaq, ifaq1, & - omega, gass, bex, ske, lw_on, kabs) - - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - integer, intent(in) :: mplus10 ! mode number (0) or number + 10 (1) - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xfbcbg(pcols,pver) ! mass fraction BC/(BC+OC) for the background mode - integer, intent(in) :: ifbcbg1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! condensed SOA/(SOA+H2SO4) (1-4) or added carbonaceous fraction (5-10) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - - ! Output arguments - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient - ! - ! Local variables - integer :: i, kcomp, k, kc10, icol - real(r8) :: a, b - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2, t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) :: t_faq1, t_faq2, t_xfaq, t_fbcbg1, t_fbcbg2, t_xfbcbg, t_fac1 - real(r8) :: t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) :: kabs1, kabs2 - !--------------------------------------- - - ! write(*,*) 'Before kcomp-loop' - do kcomp=4,4 - - if(mplus10==0) then - kc10=kcomp - else - kc10=kcomp+10 - endif - - ! write(*,*) 'Before init-loop', kc10 - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kc10,i)=0.0_r8 - gass(icol,k,kc10,i)=0.0_r8 - bex(icol,k,kc10,i)=0.0_r8 - ske(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kc10,i)=0.0_r8 - end do - end do - end do - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kc10) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - t_ifb1 = ifbcbg1(icol,k) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cate(kcomp,t_ict1) - t_cat2 = cate(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbcbg1 = fbcbg(t_ifb1) - t_fbcbg2 = fbcbg(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kc10) - t_xfac = xfac(icol,k,kcomp) - t_xfbcbg = xfbcbg(icol,k) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_fbcbg2-t_xfbcbg) - dxm1(2) = (t_xfbcbg-t_fbcbg1) - invd(2) = 1.0_r8/(t_fbcbg2-t_fbcbg1) - d2mx(3) = (t_cat2-t_xct) - dxm1(3) = (t_xct-t_cat1) - invd(3) = 1.0_r8/(t_cat2-t_cat1) - d2mx(4) = (t_fac2-t_xfac) - dxm1(4) = (t_xfac-t_fac1) - invd(4) = 1.0_r8/(t_fac2-t_fac1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - ! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! single scattering albedo: - - opt5d(1,1,1,1,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=om4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=om4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=om4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=om4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=om4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=om4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=om4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=om4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before omega' - omega(icol,k,kc10,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) /(t_rh2-t_rh1) - ! write(*,*) omega(icol,k,kc10,i) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! asymmetry factor - - opt5d(1,1,1,1,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=g4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=g4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=g4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=g4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=g4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=g4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=g4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=g4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before gass' - gass(icol,k,kc10,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction - - opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - else ! daylight - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction called for use in size estimate for use in LW - i=4 - - opt5d(1,1,1,1,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=be4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=be4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=be4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=be4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=be4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=be4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=be4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=be4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kc10,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - do i=4,4 ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific extinction - - opt5d(1,1,1,1,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=ke4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=ke4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=ke4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=ke4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=ke4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=ke4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=ke4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=ke4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) - - ske1=max(ske1,1.e-30_r8) - ske2=max(ske2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before ske' - if(t_xrh <= 0.37_r8) then - ske(icol,k,kc10,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - - ! LW optical parameters - - do i=1,nlwbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific absorption - - opt5d(1,1,1,1,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(1,1,1,1,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(1,1,1,2,1)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(1,1,1,2,2)=ka4(i,t_irh1,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(1,1,2,1,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(1,1,2,1,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(1,1,2,2,1)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(1,1,2,2,2)=ka4(i,t_irh1,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(1,2,1,1,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(1,2,1,1,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(1,2,1,2,1)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(1,2,1,2,2)=ka4(i,t_irh1,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(1,2,2,1,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(1,2,2,1,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(1,2,2,2,1)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(1,2,2,2,2)=ka4(i,t_irh1,t_ifb2,t_ict2,t_ifc2,t_ifa2) - opt5d(2,1,1,1,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa1) - opt5d(2,1,1,1,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc1,t_ifa2) - opt5d(2,1,1,2,1)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa1) - opt5d(2,1,1,2,2)=ka4(i,t_irh2,t_ifb1,t_ict1,t_ifc2,t_ifa2) - opt5d(2,1,2,1,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa1) - opt5d(2,1,2,1,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc1,t_ifa2) - opt5d(2,1,2,2,1)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa1) - opt5d(2,1,2,2,2)=ka4(i,t_irh2,t_ifb1,t_ict2,t_ifc2,t_ifa2) - opt5d(2,2,1,1,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa1) - opt5d(2,2,1,1,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc1,t_ifa2) - opt5d(2,2,1,2,1)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa1) - opt5d(2,2,1,2,2)=ka4(i,t_irh2,t_ifb2,t_ict1,t_ifc2,t_ifa2) - opt5d(2,2,2,1,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa1) - opt5d(2,2,2,1,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc1,t_ifa2) - opt5d(2,2,2,2,1)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa1) - opt5d(2,2,2,2,2)=ka4(i,t_irh2,t_ifb2,t_ict2,t_ifc2,t_ifa2) - - ! interpolation in the faq, fac, cat and fbcbg dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30_r8) - kabs2=max(kabs2,1.e-30_r8) - - ! write(*,*) 'Before kabs' - if(t_xrh <= 0.37_r8) then - kabs(icol,k,kc10,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kc10,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - - ! write(*,*) 'kcomp, omega(1,26,kc10,4)=', kcomp, omega(1,26,kc10,4) - ! write(*,*) 'kcomp, gass(1,26,kc10,4)=', kcomp, gass(1,26,kc10,4) - ! write(*,*) 'kcomp, bex(1,26,kc10,4)=', kcomp, bex(1,26,kc10,4) - ! write(*,*) 'kcomp, ske(1,26,kc10,4)=', kcomp, ske(1,26,kc10,4) - - end do ! kcomp - - end subroutine interpol4 - - !******************************************************************************************** - subroutine interpol5to10 (lchnk, ncol, daylight, xrh, irh1, Nnatk, xct, ict1, & - xfac, ifac1, xfbc, ifbc1, xfaq, ifaq1, & - omega, gass, bex, ske, lw_on, kabs) - - ! Input arguments - integer, intent(in) :: lchnk ! chunk identifier - integer, intent(in) :: ncol ! number of atmospheric columns - logical, intent(in) :: daylight(pcols) ! only daylight calculations if .true. - logical, intent(in) :: lw_on ! LW calculations are performed if true - real(r8), intent(in) :: Nnatk(pcols,pver,0:nmodes) ! modal aerosol number concentration - real(r8), intent(in) :: xrh(pcols,pver) ! level relative humidity (fraction) - integer, intent(in) :: irh1(pcols,pver) - real(r8), intent(in) :: xct(pcols,pver,nmodes) ! modal internally mixed SO4+BC+OC conc. - integer, intent(in) :: ict1(pcols,pver,nmodes) - real(r8), intent(in) :: xfac(pcols,pver,nbmodes) ! modal (OC+BC)/(SO4+BC+OC) - integer, intent(in) :: ifac1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfbc(pcols,pver,nbmodes) ! modal BC/(OC+BC) - integer, intent(in) :: ifbc1(pcols,pver,nbmodes) - real(r8), intent(in) :: xfaq(pcols,pver,nbmodes) ! modal SO4(aq)/SO4 - integer, intent(in) :: ifaq1(pcols,pver,nbmodes) - - ! Output arguments - real(r8), intent(out) :: omega(pcols,pver,0:nmodes,nbands) ! spectral modal single scattering albedo - real(r8), intent(out) :: gass(pcols,pver,0:nmodes,nbands) ! spectral modal asymmetry factor - real(r8), intent(out) :: bex(pcols,pver,0:nmodes,nbands) ! spectral modal extinction coefficient - real(r8), intent(out) :: ske(pcols,pver,0:nmodes,nbands) ! spectral modal specific extinction coefficient - real(r8), intent(out) :: kabs(pcols,pver,0:nmodes,nlwbands)! LW spectral modal specific absorption coefficient - - ! Local variables - integer :: i, kcomp, k, icol - real(r8) :: a, b - integer :: t_irh1, t_irh2, t_ict1, t_ict2, t_ifa1, t_ifa2 - integer :: t_ifb1, t_ifb2, t_ifc1, t_ifc2 - real(r8) :: t_faq1, t_faq2, t_xfaq, t_fbc1, t_fbc2, t_xfbc, t_fac1 - real(r8) :: t_fac2, t_xfac, t_xrh, t_xct, t_rh1, t_rh2, t_cat1, t_cat2 - real(r8) :: d2mx(5), dxm1(5), invd(5) - real(r8) :: opt5d(2,2,2,2,2) - real(r8) :: ome1, ome2, ge1, ge2, bex1, bex2, ske1, ske2 - real(r8) :: kabs1, kabs2 - !--------------------------------------- - - ! write(*,*) 'Before kcomp-loop' - do kcomp=5,10 - - ! write(*,*) 'Before init-loop', kcomp - do i=1,nbands - do icol=1,ncol - do k=1,pver - omega(icol,k,kcomp,i)=0.0_r8 - gass(icol,k,kcomp,i)=0.0_r8 - bex(icol,k,kcomp,i)=0.0_r8 - ske(icol,k,kcomp,i)=0.0_r8 - end do - end do - end do - do i=1,nlwbands - do icol=1,ncol - do k=1,pver - kabs(icol,k,kcomp,i)=0.0_r8 - end do - end do - end do - - do k=1,pver - do icol=1,ncol - - ! Collect all the vector elements into temporary storage - ! to avoid cache conflicts and excessive cross-referencing - - t_irh1 = irh1(icol,k) - t_irh2 = t_irh1+1 - t_ict1 = ict1(icol,k,kcomp) - t_ict2 = t_ict1+1 - t_ifc1 = ifac1(icol,k,kcomp) - t_ifc2 = t_ifc1+1 - - t_ifb1 = ifbc1(icol,k,kcomp) - t_ifb2 = t_ifb1+1 - t_ifa1 = ifaq1(icol,k,kcomp) - t_ifa2 = t_ifa1+1 - - t_rh1 = rh(t_irh1) - t_rh2 = rh(t_irh2) - t_cat1 = cat(kcomp,t_ict1) - t_cat2 = cat(kcomp,t_ict2) - t_fac1 = fac(t_ifc1) - t_fac2 = fac(t_ifc2) - t_fbc1 = fbc(t_ifb1) - t_fbc2 = fbc(t_ifb2) - t_faq1 = faq(t_ifa1) - t_faq2 = faq(t_ifa2) - - t_xrh = xrh(icol,k) - t_xct = xct(icol,k,kcomp) - t_xfac = xfac(icol,k,kcomp) - t_xfbc = xfbc(icol,k,kcomp) - t_xfaq = xfaq(icol,k,kcomp) - - ! partial lengths along each dimension (1-5) for interpolation - d2mx(1) = (t_rh2-t_xrh) - dxm1(1) = (t_xrh-t_rh1) - invd(1) = 1.0_r8/(t_rh2-t_rh1) - d2mx(2) = (t_cat2-t_xct) - dxm1(2) = (t_xct-t_cat1) - invd(2) = 1.0_r8/(t_cat2-t_cat1) - d2mx(3) = (t_fac2-t_xfac) - dxm1(3) = (t_xfac-t_fac1) - invd(3) = 1.0_r8/(t_fac2-t_fac1) - d2mx(4) = (t_fbc2-t_xfbc) - dxm1(4) = (t_xfbc-t_fbc1) - invd(4) = 1.0_r8/(t_fbc2-t_fbc1) - d2mx(5) = (t_faq2-t_xfaq) - dxm1(5) = (t_xfaq-t_faq1) - invd(5) = 1.0_r8/(t_faq2-t_faq1) - - - ! SW optical parameters - if(daylight(icol)) then - - do i=1,nbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! single scattering albedo: - - opt5d(1,1,1,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=om5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=om5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=om5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=om5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ome1, ome2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before omega' - omega(icol,k,kcomp,i)=((t_rh2-t_xrh)*ome1+(t_xrh-t_rh1)*ome2) & - /(t_rh2-t_rh1) - ! write(*,*) omega(icol,k,kcomp,i) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! asymmetry factor - - opt5d(1,1,1,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=g5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=g5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=g5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=g5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ge1, ge2) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before gass' - gass(icol,k,kcomp,i)=((t_rh2-t_xrh)*ge1+(t_xrh-t_rh1)*ge2) & - /(t_rh2-t_rh1) - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction - - opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - end do ! i - else ! daylight - - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol extinction used for aerosol size estimate needed for LW calculations - i=4 - opt5d(1,1,1,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=be5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=be5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=be5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=be5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, bex1, bex2) - - bex1=max(bex1,1.e-30_r8) - bex2=max(bex2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before bex' - if(t_xrh <= 0.37_r8) then - bex(icol,k,kcomp,i)=((t_rh2-t_xrh)*bex1+(t_xrh-t_rh1)*bex2) & - /(t_rh2-t_rh1) - else - a=(log(bex2)-log(bex1))/(t_rh2-t_rh1) - b=(t_rh2*log(bex1)-t_rh1*log(bex2))/(t_rh2-t_rh1) - bex(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - endif ! daylight - - - - do i=4,4 ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific extinction - - opt5d(1,1,1,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=ke5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=ke5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=ke5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=ke5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, ske1, ske2) - - ske1=max(ske1,1.e-30_r8) - ske2=max(ske2,1.e-30_r8) - - ! finally, interpolation in the rh dimension - ! write(*,*) 'Before ske' - if(t_xrh <= 0.37_r8) then - ske(icol,k,kcomp,i)=((t_rh2-t_xrh)*ske1+(t_xrh-t_rh1)*ske2) & - /(t_rh2-t_rh1) - else - a=(log(ske2)-log(ske1))/(t_rh2-t_rh1) - b=(t_rh2*log(ske1)-t_rh1*log(ske2))/(t_rh2-t_rh1) - ske(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - end do ! i - - - - if (lw_on) then - - ! LW optical parameters - - do i=1,nlwbands ! i = wavelength index - - !ccccccccc1ccccccccc2ccccccccc3ccccccccc4ccccccccc5ccccccccc6ccccccccc7cc - ! aerosol specific absorption - - opt5d(1,1,1,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,1,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,1,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,1,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,1,2,1,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,1,2,1,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,1,2,2,1)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,1,2,2,2)=ka5to10(i,t_irh1,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,1,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,1,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,1,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,1,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(1,2,2,1,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(1,2,2,1,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(1,2,2,2,1)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(1,2,2,2,2)=ka5to10(i,t_irh1,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,1,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,1,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,1,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,1,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,1,2,1,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,1,2,1,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,1,2,2,1)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,1,2,2,2)=ka5to10(i,t_irh2,t_ict1,t_ifc2,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,1,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,1,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,1,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,1,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc1,t_ifb2,t_ifa2,kcomp) - opt5d(2,2,2,1,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa1,kcomp) - opt5d(2,2,2,1,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb1,t_ifa2,kcomp) - opt5d(2,2,2,2,1)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa1,kcomp) - opt5d(2,2,2,2,2)=ka5to10(i,t_irh2,t_ict2,t_ifc2,t_ifb2,t_ifa2,kcomp) - - ! interpolation in the faq, fbc, fac and cat dimensions - call lininterpol5dim (d2mx, dxm1, invd, opt5d, kabs1, kabs2) - - kabs1=max(kabs1,1.e-30_r8) - kabs2=max(kabs2,1.e-30_r8) - - ! write(*,*) 'Before kabs' - if(t_xrh <= 0.37_r8) then - kabs(icol,k,kcomp,i)=((t_rh2-t_xrh)*kabs1+(t_xrh-t_rh1)*kabs2) & - /(t_rh2-t_rh1) - else - a=(log(kabs2)-log(kabs1))/(t_rh2-t_rh1) - b=(t_rh2*log(kabs1)-t_rh1*log(kabs2))/(t_rh2-t_rh1) - kabs(icol,k,kcomp,i)=e**(a*t_xrh+b) - endif - - end do ! i - - endif ! lw_on - - end do ! icol - end do ! k - end do ! kcomp - - end subroutine interpol5to10 - - !******************************************************************************************** - subroutine checkTableHeader (ifil) - ! Read the header-text in a look-up table (in file with iu=ifil). - - integer, intent(in) :: ifil - character*80 :: headertext - character*12 :: text0, text1 - - text0='X-CHECK LUT' - text1='none ' - do while (text1(2:12) .ne. text0(2:12)) - read(ifil,'(A)') headertext - text1 = headertext(2:12) - enddo - end subroutine checkTableHeader - -end module oslo_aero_sw_tables diff --git a/src/chemistry/oslo_aero/oslo_aero_utils.F90 b/src/chemistry/oslo_aero/oslo_aero_utils.F90 deleted file mode 100644 index 0660c0cfb0..0000000000 --- a/src/chemistry/oslo_aero/oslo_aero_utils.F90 +++ /dev/null @@ -1,170 +0,0 @@ -module oslo_aero_utils - - use shr_kind_mod, only: r8 => shr_kind_r8 - use ppgrid, only: pcols, pver - use physconst, only: pi - use constituents, only: pcnst - ! - use oslo_aero_share, only: getDryDensity, getNumberOfBackgroundTracersInMode, getTracerIndex - use oslo_aero_const, only: volumeToNumber, rbinMidPoint, rbinEdge, nBinsTab, nmodes - use oslo_aero_params, only: originalNumberMedianRadius - - implicit none - private - - public :: calculateNumberConcentration - public :: calculateNumberMedianRadius - public :: calculateEquivalentDensityOfFractalMode - public :: calculatedNdLogR - public :: calculateLognormalCDF - -!=================================================== -contains -!=================================================== - - subroutine calculateNumberConcentration(ncol, q, rho_air, numberConcentration) - - ! arguments - integer , intent(in) :: ncol !number of columns used - real(r8) , intent(in) :: q(pcols,pver,pcnst) ![kg/kg] mass mixing ratios - real(r8) , intent(in) :: rho_air(pcols,pver) ![kg/m3] air density - real(r8) , intent(out) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration - - ! local variables - integer :: m, l, mm, k - - numberConcentration(:,:,:) = 0.0_r8 - do m = 0, nmodes - do l=1,getNumberOfBackgroundTracersInMode(m) - mm = getTracerIndex(m,l,.false.) - do k=1,pver - numberConcentration(:ncol,k,m) = numberConcentration(:ncol,k,m) & - + ( q(:ncol,k,mm) / getDryDensity(m,l)) !Volume of this tracer - end do - end do - end do - - ! until now, the variable "numberConcentration" actually contained "volume mixing ratio" - ! the next couple of lines fixes this! - do m= 0, nmodes - do k=1,pver - numberConcentration(:ncol,k,m) = numberConcentration(:ncol,k,m) * rho_air(:ncol,k) * volumeToNumber(m) - end do - end do - - end subroutine calculateNumberConcentration - - !=================================================== - subroutine calculateNumberMedianRadius(& - numberConcentration, volumeConcentration, lnSigma, numberMedianRadius, ncol) - - !Note the "nmodes" here - real(r8) , intent(in) :: numberConcentration(pcols,pver,0:nmodes) ![#/m3] number concentration - real(r8) , intent(in) :: volumeConcentration(pcols,pver,nmodes) ![kg/kg] mass mixing ratios - real(r8) , intent(in) :: lnSigma(pcols,pver,nmodes) ![kg/m3] air density - integer , intent(in) :: ncol !number of columns used - real(r8) , intent(out) :: numberMedianRadius(pcols,pver,nmodes) ![m] - - real(r8), parameter :: aThird = 1.0_r8/3.0_r8 - integer :: n,k - - do n=1,nmodes - do k=1,pver - where(volumeConcentration(:ncol,k,n) .gt. 1.e-20_r8) - numberMedianRadius(:ncol, k, n) = 0.5_r8 & !diameter ==> radius - * (volumeConcentration(:ncol,k,n) & !conversion formula - * 6.0_r8/pi/numberConcentration(:ncol,k,n) & - *DEXP(-4.5_r8*lnsigma(:ncol,k,n)*lnsigma(:ncol,k,n)))**aThird - elsewhere - numberMedianRadius(:ncol,k,n) = originalNumberMedianRadius(n) - end where - end do - end do - - end subroutine calculateNumberMedianRadius - - !=================================================== - function calculateEquivalentDensityOfFractalMode( & - emissionDensity, emissionRadius, fractalDimension, modeNumberMedianRadius, modeStandardDeviation) & - result (equivalentDensityOfFractal) - - ! Purpose: output equivalent density of a fractal mode - - ! arguments - real(r8), intent(in) :: emissionDensity ![kg/m3] density at point of emission - real(r8), intent(in) :: emissionRadius ![kg/m3] radius at point of emission - real(r8), intent(in) :: fractalDimension ![kg/m3] fractal dimension of mode - real(r8), intent(in) :: modeNumberMedianRadius ![m] number median radius of mode - real(r8), intent(in) :: modeStandardDeviation ![m] standard deviation of mode - real(r8) :: equivalentDensityOfFractal ! Output - - ! local variables - real(r8) :: sumVolume - real(r8) :: sumMass - real(r8) :: dN, dNdLogR, dLogR - real(r8) :: densityBin - integer :: i - - sumVolume = 0.0_r8 - sumMass = 0.0_r8 - do i=1, nbinsTab - dLogR = log(rBinEdge(i+1)/rBinEdge(i)) - dNdLogR = calculatedNdLogR(rBinMidPoint(i), modeNumberMedianRadius, modeStandardDeviation) - - !Equivalent density (decreases with size since larger particles are long - !"hair like" threads..) - if(rBinMidPoint(i) < emissionRadius)then - densityBin = emissionDensity - else - densityBin = emissionDensity*(emissionRadius/rBinMidPoint(i))**(3.0 - fractalDimension) - endif - - !number concentration in this bin - dN = dNdLogR * dLogR - - !sum up volume and mass (factor of 4*pi/3 omitted since in both numerator and nominator) - sumVolume = sumVolume + dN * (rBinMidPoint(i)**3) - sumMass = sumMass + dN * densityBin * (rBinMidPoint(i)**3) - - end do - - !Equivalent density is mass by volume - equivalentDensityOfFractal = sumMass / sumVolume - - end function calculateEquivalentDensityOfFractalMode - - !=================================================== - function calculatedNdLogR(actualRadius, numberMedianRadius, sigma) result (dNdLogR) - - real(r8), intent(in) :: actualRadius - real(r8), intent(in) :: numberMedianRadius - real(r8), intent(in) :: sigma - - real(r8) :: logSigma - real(r8) :: dNdLogR - - logSigma = log(sigma) - - !This is the formula for the lognormal distribution - dNdLogR = 1.0_r8/(sqrt(2.0_r8*pi)*log(sigma)) & - * DEXP(-0.5_r8*(log(actualRadius/numberMedianRadius))**2/(logSigma**2)) - - end function calculatedNdLogR - - !=================================================== - function calculateLognormalCDF(actualRadius, numberMedianRadius, sigma) result(CDF) - - !http://en.wikipedia.org/wiki/Log-normal_distribution#Cumulative_distribution_function - real(r8), intent(in) :: actualRadius - real(r8), intent(in) :: numberMedianRadius - real(r8), intent(in) :: sigma - real(r8) :: CDF ! output - - real(r8) :: argument - - argument = -1.0_r8*(log(actualRadius/numberMedianRadius) / log(sigma) / sqrt(2.0_r8)) - CDF = 0.5_r8 * erfc(argument) - - end function calculateLognormalCDF - -end module oslo_aero_utils From b3bb05b37094adb8e02cd4749c1fed5761b89f9f Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 4 Sep 2023 21:03:57 +0200 Subject: [PATCH 57/71] pointing to chemistry/oslo_aero as an external --- Externals_CAM.cfg | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 3e0e721533..2b4625e60a 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -1,3 +1,10 @@ +[oslo_aero] +local_path = src/chemistry/oslo_aero +protocol = git +repo_url = https://github.com/NorESMhub/OSLO_AERO.git +tag = 37b5bab +required = True + [chem_proc] local_path = chem_proc protocol = svn From c7ba5800355a05311427b68e5e355d24d7d328dc Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 17 Oct 2023 10:08:59 +0200 Subject: [PATCH 58/71] minor update to radiation.F90 --- src/physics/rrtmg/radiation.F90 | 14 ++++++-------- 1 file changed, 6 insertions(+), 8 deletions(-) diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index b7727a174c..431a6f5c26 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -735,14 +735,6 @@ subroutine radiation_tend( & use oslo_aero_share #endif -#ifdef OSLO_AERO - real(r8) :: flnt_tmp(pcols) ! Net outgoing lw flux at model top for AIE calculations - real(r8) :: volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode - integer :: band - character(len=3) :: c3 - logical :: idrf -#endif - ! Arguments type(physics_state), intent(in), target :: state type(physics_ptend), intent(out) :: ptend @@ -756,6 +748,12 @@ subroutine radiation_tend( & ! Local variables +#ifdef OSLO_AERO + real(r8) :: volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode + integer :: band + character(len=3) :: c3 + logical :: idrf +#endif type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object ! if the argument is not present logical :: write_output From 5bcf671c97a59ad06512787922032a77c30933f8 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 25 Oct 2023 10:32:43 +0200 Subject: [PATCH 59/71] updates for new changes to oslo-aero --- bld/configure | 8 ++++++-- src/NorESM/physpkg.F90 | 8 +------- src/chemistry/mozart/chemistry.F90 | 18 +++--------------- src/chemistry/mozart/mo_gas_phase_chemdr.F90 | 6 +----- src/chemistry/mozart/mo_usrrxt.F90 | 4 ---- 5 files changed, 11 insertions(+), 33 deletions(-) diff --git a/bld/configure b/bld/configure index 4e996ef4bc..51c0fe8110 100755 --- a/bld/configure +++ b/bld/configure @@ -2763,7 +2763,11 @@ sub write_filepath print $fh "$camsrcdir/cam/src/NorESM/$dyn\n"; #--djlo - # offline unit driver (defaults to stub) + if ($chem =~/_oslo/) { + print $fh "$camsrcdir/src/chemistry/oslo_aero/src_cam\n"; + } + + # offline unit driver (defaults to stub) print $fh "$camsrcdir/cam/src/unit_drivers\n"; print $fh "$camsrcdir/cam/src/unit_drivers/${offline_drv}\n"; @@ -2788,7 +2792,7 @@ sub write_filepath print $fh "$chem_src_dir\n"; } if ($chem =~/_oslo/) { - print $fh "$camsrcdir/cam/src/chemistry/oslo_aero\n"; + print $fh "$camsrcdir/cam/src/chemistry/oslo_aero/src\n"; } else{ if ($chem =~ /_mam/) { diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index f7da22bd09..cc221ee864 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -1290,12 +1290,7 @@ subroutine tphysac (ztodt, cam_in, & use qneg_module, only: qneg4 use co2_cycle, only: co2_cycle_set_ptend use nudging, only: Nudge_Model,Nudge_ON,nudging_timestep_tend -#ifdef OSLO_AERO - use oslo_aero_model, only: aero_model_drydep -#else use aero_model, only: aero_model_drydep -#endif - ! ! Arguments ! @@ -1750,14 +1745,13 @@ subroutine tphysbc (ztodt, state, & use subcol, only: subcol_gen, subcol_ptend_avg use subcol_utils, only: subcol_ptend_copy, is_subcol_on use qneg_module, only: qneg3 + use aero_model, only: aero_model_wetdep #ifdef OSLO_AERO - use oslo_aero_model, only: aero_model_wetdep use oslo_aero_microp,only: oslo_aero_microp_run use oslo_aero_params use oslo_aero_share #else use microp_aero, only: microp_aero_run - use aero_model, only: aero_model_wetdep #endif implicit none diff --git a/src/chemistry/mozart/chemistry.F90 b/src/chemistry/mozart/chemistry.F90 index bad3d179cc..69eff7af52 100644 --- a/src/chemistry/mozart/chemistry.F90 +++ b/src/chemistry/mozart/chemistry.F90 @@ -172,11 +172,8 @@ subroutine chem_register use cfc11star, only : register_cfc11star use mo_photo, only : photo_register use mo_aurora, only : aurora_register -#ifdef OSLO_AERO - use oslo_aero_model, only : aero_model_register -#else use aero_model, only : aero_model_register -#endif + implicit none !----------------------------------------------------------------------- @@ -349,11 +346,10 @@ subroutine chem_readnl(nlfile) use linoz_data, only: linoz_data_defaultopts, linoz_data_setopts use tracer_cnst, only: tracer_cnst_defaultopts, tracer_cnst_setopts use tracer_srcs, only: tracer_srcs_defaultopts, tracer_srcs_setopts + use aero_model, only: aero_model_readnl #ifdef OSLO_AERO - use oslo_aero_model, only: aero_model_readnl - use oslo_aero_dust, only: oslo_aero_dust_readnl + use oslo_aero_dust, only: oslo_aero_dust_readnl #else - use aero_model, only: aero_model_readnl use dust_model, only: dust_readnl #endif use gas_wetdep_opts, only: gas_wetdep_readnl @@ -780,11 +776,7 @@ subroutine chem_init(phys_state, pbuf2d) use noy_ubc, only : noy_ubc_init use fire_emissions, only : fire_emissions_init use short_lived_species, only : short_lived_species_initic -#ifdef OSLO_AERO - use oslo_aero_model, only : aero_model_init -#else use aero_model, only : aero_model_init -#endif type(physics_buffer_desc), pointer :: pbuf2d(:,:) type(physics_state), intent(in):: phys_state(begchunk:endchunk) @@ -996,11 +988,7 @@ subroutine chem_emissions( state, cam_in ) use mo_srf_emissions, only: set_srf_emissions use cam_cpl_indices, only: index_x2a_Fall_flxvoc use fire_emissions, only: fire_emissions_srf -#ifdef OSLO_AERO - use oslo_aero_model, only: aero_model_emissions -#else use aero_model, only: aero_model_emissions -#endif ! Arguments: diff --git a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 index 3624cb5ae4..5ebeb676a3 100644 --- a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 +++ b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 @@ -359,13 +359,9 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & ! ! for aqueous chemistry and aerosol growth ! -#ifdef OSLO_AERO - use oslo_aero_model, only : aero_model_gasaerexch - use oslo_aero_model, only : aero_model_strat_surfarea -#else use aero_model, only : aero_model_gasaerexch use aero_model, only : aero_model_strat_surfarea -#endif + implicit none !----------------------------------------------------------------------- diff --git a/src/chemistry/mozart/mo_usrrxt.F90 b/src/chemistry/mozart/mo_usrrxt.F90 index 76ca25e9a0..aa7f526a94 100644 --- a/src/chemistry/mozart/mo_usrrxt.F90 +++ b/src/chemistry/mozart/mo_usrrxt.F90 @@ -446,11 +446,7 @@ subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, & use mo_setinv, only : inv_o2_ndx=>o2_ndx, inv_h2o_ndx=>h2o_ndx use physics_buffer,only : physics_buffer_desc use carma_flags_mod, only : carma_hetchem_feedback -#ifdef OSLO_AERO - use oslo_aero_model, only : aero_model_surfarea -#else use aero_model, only : aero_model_surfarea -#endif use rad_constituents,only : rad_cnst_get_info implicit none From 014d4f068981e5e05f0ab02edb85a24289f9bb82 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 25 Oct 2023 10:39:23 +0200 Subject: [PATCH 60/71] updates to get new external oslo-aero working in the release branch --- Externals_CAM.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 2b4625e60a..49dd6b1275 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -2,7 +2,7 @@ local_path = src/chemistry/oslo_aero protocol = git repo_url = https://github.com/NorESMhub/OSLO_AERO.git -tag = 37b5bab +branch = feature/oslo_aero_integrate_release required = True [chem_proc] From 7b865c77bc6420e5d9e45ae4c13c5abd7d2309a1 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 25 Oct 2023 11:10:54 +0200 Subject: [PATCH 61/71] removed trailing whitespace --- src/physics/rrtmg/radiation.F90 | 89 ++++++++++++++++----------------- 1 file changed, 44 insertions(+), 45 deletions(-) diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index 431a6f5c26..8e77504688 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -130,19 +130,19 @@ module radiation logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. ! Physics buffer indices - integer :: qrs_idx = 0 - integer :: qrl_idx = 0 - integer :: su_idx = 0 - integer :: sd_idx = 0 - integer :: lu_idx = 0 - integer :: ld_idx = 0 + integer :: qrs_idx = 0 + integer :: qrl_idx = 0 + integer :: su_idx = 0 + integer :: sd_idx = 0 + integer :: lu_idx = 0 + integer :: ld_idx = 0 integer :: fsds_idx = 0 integer :: fsns_idx = 0 integer :: fsnt_idx = 0 integer :: flns_idx = 0 integer :: flnt_idx = 0 - integer :: cldfsnow_idx = 0 - integer :: cld_idx = 0 + integer :: cldfsnow_idx = 0 + integer :: cld_idx = 0 #ifdef OSLO_AERO integer :: volc_idx = 0 #endif @@ -216,7 +216,7 @@ subroutine radiation_readnl(nlfile) if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! Print runtime options to log. !----------------------------------------------------------------------- @@ -242,8 +242,8 @@ subroutine radiation_register use physics_buffer, only: pbuf_add_field, dtype_r8 use radiation_data, only: rad_data_register - call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate - call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate + call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate + call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux @@ -311,10 +311,10 @@ real(r8) function radiation_nextsw_cday() ! Local variables integer :: nstep ! timestep counter - logical :: dosw ! true => do shosrtwave calc + logical :: dosw ! true => do shosrtwave calc integer :: offset ! offset for calendar day calculation integer :: dTime ! integer timestep size - real(r8):: calday ! calendar day of + real(r8):: calday ! calendar day of !----------------------------------------------------------------------- radiation_nextsw_cday = -1._r8 @@ -326,7 +326,7 @@ real(r8) function radiation_nextsw_cday() nstep = nstep + 1 offset = offset + dtime if (radiation_do('sw', nstep)) then - radiation_nextsw_cday = get_curr_calday(offset=offset) + radiation_nextsw_cday = get_curr_calday(offset=offset) dosw = .true. end if end do @@ -417,7 +417,7 @@ subroutine radiation_init(pbuf2d) if (is_first_restart_step()) then cosp_cnt(begchunk:endchunk) = cosp_cnt_init else - cosp_cnt(begchunk:endchunk) = 0 + cosp_cnt(begchunk:endchunk) = 0 end if call addfld('O3colAbove', horiz_only, 'A', 'DU', 'Column O3 above model top', sampling_seq='rad_lwsw') @@ -519,7 +519,7 @@ subroutine radiation_init(pbuf2d) end do #ifdef OSLO_AERO - call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') + call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') #endif @@ -689,15 +689,15 @@ end subroutine radiation_read_restart subroutine radiation_tend( & state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) - !----------------------------------------------------------------------- - ! + !----------------------------------------------------------------------- + ! ! Driver for radiation computation. - ! + ! ! Revision history: ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. ! - ! 2019-05-06 A. KirkevÃ¥g: Changes for testing the + ! 2019-05-06 A. KirkevÃ¥g: Changes for testing the ! "simple plumes" aerosols, based on NorESM1 code P. Räisänen. !----------------------------------------------------------------------- @@ -763,8 +763,8 @@ subroutine radiation_tend( & logical :: dosw, dolw #ifdef OSLO_AERO - real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr - real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) + real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr + real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) #endif real(r8) :: calday ! current calendar day real(r8) :: delta ! Solar declination angle in radians @@ -773,7 +773,7 @@ subroutine radiation_tend( & real(r8) :: clon(pcols) ! current longitudes(radians) real(r8) :: coszrs(pcols) ! Cosine solar zenith angle - ! Gathered indices of day and night columns + ! Gathered indices of day and night columns ! chunk_column_index = IdxDay(daylight_column_index) integer :: Nday ! Number of daylight columns integer :: Nnite ! Number of night columns @@ -784,8 +784,8 @@ subroutine radiation_tend( & real(r8), pointer :: cld(:,:) ! cloud fraction real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" - real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate - real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate + real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate + real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate real(r8), pointer :: fsds(:) ! Surface solar down flux real(r8), pointer :: fsns(:) ! Surface solar absorbed flux real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top @@ -854,7 +854,7 @@ subroutine radiation_tend( & #ifdef OSLO_AERO ! Local variables used for calculating aerosol optics and direct and indirect forcings. ! aodvis and absvis are AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) - ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values + ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values real(r8) :: qdirind(pcols,pver,pcnst) ! Common tracers for indirect and direct calculations real(r8) :: aodvis(pcols) ! AOD vis real(r8) :: absvis(pcols) ! absorptive AOD vis @@ -1161,7 +1161,7 @@ subroutine radiation_tend( & if (dosw) then #ifdef OSLO_AERO - ! Volcanic optics for solar (SW) bands + ! Volcanic optics for solar (SW) bands do band=1, solar_bands volc_ext_sun(1:ncol,1:pver,band)=0.0_r8 volc_omega_sun(1:ncol,1:pver,band)=0.999_r8 @@ -1170,18 +1170,18 @@ subroutine radiation_tend( & if (has_prescribed_volcaero_cmip6) then do band=1, solar_bands write(c3,'(i3)') band - volc_idx = pbuf_get_index('ext_sun'//trim(adjustl(c3))) + volc_idx = pbuf_get_index('ext_sun'//trim(adjustl(c3))) call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) volc_ext_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - volc_idx = pbuf_get_index('omega_sun'//trim(adjustl(c3))) + volc_idx = pbuf_get_index('omega_sun'//trim(adjustl(c3))) call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) volc_omega_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - volc_idx = pbuf_get_index('g_sun'//trim(adjustl(c3))) + volc_idx = pbuf_get_index('g_sun'//trim(adjustl(c3))) call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) volc_g_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) enddo endif - ! Volcanic optics for terrestrial (LW) bands (g is not used here) + ! Volcanic optics for terrestrial (LW) bands (g is not used here) do band=1, terrestrial_bands volc_ext_earth(1:ncol,1:pver,band)=0.0_r8 volc_omega_earth(1:ncol,1:pver,band)=0.999_r8 @@ -1189,11 +1189,11 @@ subroutine radiation_tend( & if (has_prescribed_volcaero_cmip6) then do band=1, terrestrial_bands write(c3,'(i3)') band - volc_idx = pbuf_get_index('ext_earth'//trim(adjustl(c3))) + volc_idx = pbuf_get_index('ext_earth'//trim(adjustl(c3))) call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) volc_ext_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - volc_idx = pbuf_get_index('omega_earth'//trim(adjustl(c3))) + volc_idx = pbuf_get_index('omega_earth'//trim(adjustl(c3))) call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) volc_omega_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) enddo @@ -1204,7 +1204,7 @@ subroutine radiation_tend( & call oslo_aero_optical_params_calc(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & coszrs, state, state%t, cld, qdirind, Nnatk, & per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, volc_ext_earth, volc_omega_earth, & + volc_ext_sun, volc_omega_sun, volc_g_sun, volc_ext_earth, volc_omega_earth, & aodvis, absvis) #endif @@ -1227,8 +1227,8 @@ subroutine radiation_tend( & ! A first call with Oslo aerosols set to zero for radiative forcing diagnostics ! follwoing the Ghan (2013) method: - ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore - ! (just nudged), but with an extra call with 0 aerosol extiction. + ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore + ! (just nudged), but with an extra call with 0 aerosol extiction. ! idrf = .true. call rad_rrtmg_sw( & @@ -1250,7 +1250,7 @@ subroutine radiation_tend( & ! ! Dump shortwave radiation information to history tape buffer (diagnostics) ! - ! Note that DRF fields are now from the per_tau=0 call (clean), no longer with per_tau from pmxsub + ! Note that DRF fields are now from the per_tau=0 call (clean), no longer with per_tau from pmxsub call outfld('QRS_DRF ',ftem ,pcols,lchnk) ftem(:ncol,:pver) = rd%qrsc(:ncol,:pver)/cpair call outfld('QRSC_DRF',ftem ,pcols,lchnk) @@ -1265,7 +1265,7 @@ subroutine radiation_tend( & call outfld('FSUS_DRF',ftem_1d,pcols,lchnk) call outfld('FSDSCDRF',rd%fsdsc(:) ,pcols,lchnk) end if - idrf = .false. + idrf = .false. #else call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) @@ -1285,7 +1285,7 @@ subroutine radiation_tend( & fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & ! Note the extra idrf + cam_out%solld, fns, fcns, idrf, Nday, Nnite, & ! Note the extra idrf IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) @@ -1322,7 +1322,7 @@ subroutine radiation_tend( & end if #ifdef OSLO_AERO - !Calculate cloud-free fraction assuming random overlap + !Calculate cloud-free fraction assuming random overlap !(kind of duplicated from cloud_cover_diags::cldsav) cloudfree(1:ncol) = 1.0_r8 cloudfreemax(1:ncol) = 1.0_r8 @@ -1334,14 +1334,14 @@ subroutine radiation_tend( & end do end do - !Calculate AOD (visible) for cloud free + !Calculate AOD (visible) for cloud free do i = 1, ncol clearodvis(i)=cloudfree(i)*aodvis(i) clearabsvis(i)=cloudfree(i)*absvis(i) end do ! clear-sky AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) - ! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values + ! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values call outfld('CAODVIS ',clearodvis,pcols,lchnk) call outfld('CABSVIS ',clearabsvis,pcols,lchnk) call outfld('CLDFREE ',cloudfree,pcols,lchnk) @@ -1382,7 +1382,7 @@ subroutine radiation_tend( & call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) - ! for calculation of direct and direct radiative forcing + ! for calculation of direct and direct radiative forcing #ifdef OSLO_AERO call rad_rrtmg_lw( & @@ -1668,7 +1668,7 @@ end subroutine radiation_output_lw subroutine calc_col_mean(state, mmr_pointer, mean_value) - ! Compute the column mean mass mixing ratio. + ! Compute the column mean mass mixing ratio. type(physics_state), intent(in) :: state real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) @@ -1697,4 +1697,3 @@ end subroutine calc_col_mean !=============================================================================== end module radiation - From 9d9bc543d0ad04634683be3f6677bd9cbde7c7de Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 25 Oct 2023 12:05:51 +0200 Subject: [PATCH 62/71] removed svn externals that are now imbedded in the source code --- Externals_CAM.cfg | 21 --------------------- 1 file changed, 21 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 49dd6b1275..f7d9774569 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -5,27 +5,6 @@ repo_url = https://github.com/NorESMhub/OSLO_AERO.git branch = feature/oslo_aero_integrate_release required = True -[chem_proc] -local_path = chem_proc -protocol = svn -repo_url = https://svn-ccsm-models.cgd.ucar.edu/tools/proc_atm/chem_proc/release_tags/ -tag = chem_proc5_0_03_rel -required = True - -[carma] -local_path = src/physics/carma/base -protocol = svn -repo_url = https://svn-ccsm-models.cgd.ucar.edu/carma/release_tags/ -tag = carma3_49_rel -required = True - -[clubb] -local_path = src/physics/clubb -protocol = svn -repo_url = https://svn-ccsm-models.cgd.ucar.edu/clubb_core/release_tags/ -tag = clubb_r8099_n02_rel -required = True - [cosp2] local_path = src/physics/cosp2/src protocol = svn From 437d3bd0923b1e4464d7524fc8f33f3e5db9dbd4 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 31 Oct 2023 17:37:13 +0100 Subject: [PATCH 63/71] nan bug fixes --- src/NorESM/physpkg.F90 | 101 ------ src/physics/cam/micro_mg_data.F90 | 550 ------------------------------ 2 files changed, 651 deletions(-) delete mode 100644 src/physics/cam/micro_mg_data.F90 diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index cc221ee864..b44fd72606 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -31,16 +31,11 @@ module physpkg use perf_mod use cam_logfile, only: iulog use camsrfexch, only: cam_export -#ifdef AEROCOM - use oslo_aero_aerocom, only: intfrh -#endif - use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg use modal_aero_wateruptake, only: modal_aero_wateruptake_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg implicit none private - save ! Public methods public phys_register ! was initindx - register physics methods @@ -1861,55 +1856,7 @@ subroutine tphysbc (ztodt, state, & real(r8) :: flx_heat(pcols) type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes real(r8) :: zero_tracers(pcols,pcnst) - logical :: lq(pcnst) - -#ifdef AEROCOM - real(r8) :: logsig3d(pcols,pver,nmodes) ! Log (log10) of standard deviation for lognormal modes, method 2. - real(r8) :: rnew3d(pcols,pver,nmodes) ! New modal radius from look-up tables, method 2. - real(r8) :: logsig1(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 1, method 2. - real(r8) :: rnew1(pcols,pver) ! New modal radius, mode 1, from look-up tables, method 2. - real(r8) :: logsig2(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 2, method 2. - real(r8) :: rnew2(pcols,pver) ! New modal radius, mode 2, from look-up tables, method 2. - real(r8) :: logsig4(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 4, method 2. - real(r8) :: rnew4(pcols,pver) ! New modal radius, mode 4, from look-up tables, method 2. - real(r8) :: logsig5(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 5, method 2. - real(r8) :: rnew5(pcols,pver) ! New modal radius, mode 5, from look-up tables, method 2. - real(r8) :: logsig6(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 6, method 2. - real(r8) :: rnew6(pcols,pver) ! New modal radius, mode 6, from look-up tables, method 2. - real(r8) :: logsig7(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 7, method 2. - real(r8) :: rnew7(pcols,pver) ! New modal radius, mode 7, from look-up tables, method 2. - real(r8) :: logsig8(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 8, method 2. - real(r8) :: rnew8(pcols,pver) ! New modal radius, mode 8, from look-up tables, method 2. - real(r8) :: logsig9(pcols,pver) ! Log (log10) of standard deviation for lognormal mode 9, method 2. - real(r8) :: rnew9(pcols,pver) ! New modal radius, mode 9, from look-up tables, method 2. - real(r8) :: logsig10(pcols,pver)! Log (log10) of standard deviation for lognormal modes 10, method 2. - real(r8) :: rnew10(pcols,pver) ! New modal radius, mode 10, from look-up tables, method 2. - real(r8) :: logsig11(pcols,pver)! Log (log10) of standard deviation for lognormal modes 11, method 2. - real(r8) :: rnew11(pcols,pver) ! New modal radius, mode 11, from look-up tables, method 2. - real(r8) :: logsig13(pcols,pver)! Log (log10) of standard deviation for lognormal modes 13, method 2. - real(r8) :: rnew13(pcols,pver) ! New modal radius, mode 13, from look-up tables, method 2. - real(r8) :: logsig14(pcols,pver)! Log (log10) of standard deviation for lognormal modes 14, method 2. - real(r8) :: rnew14(pcols,pver) ! New modal radius, mode 14, from look-up tables, method 2. - real(r8) :: rnewdry1(pcols,pver) ! New dry modal radius, mode 1, from look-up tables, method 2. - real(r8) :: rnewdry2(pcols,pver) ! New dry modal radius, mode 2, from look-up tables, method 2. - real(r8) :: rnewdry4(pcols,pver) ! New dry modal radius, mode 4, from look-up tables, method 2. - real(r8) :: rnewdry5(pcols,pver) ! New dry modal radius, mode 5, from look-up tables, method 2. - real(r8) :: rnewdry6(pcols,pver) ! New dry modal radius, mode 6, from look-up tables, method 2. - real(r8) :: rnewdry7(pcols,pver) ! New dry modal radius, mode 7, from look-up tables, method 2. - real(r8) :: rnewdry8(pcols,pver) ! New dry modal radius, mode 8, from look-up tables, method 2. - real(r8) :: rnewdry9(pcols,pver) ! New dry modal radius, mode 9, from look-up tables, method 2. - real(r8) :: rnewdry10(pcols,pver) ! New dry modal radius, mode 10, from look-up tables, method 2. - real(r8) :: rnewdry11(pcols,pver) ! New dry modal radius, mode 11, from look-up tables, method 2. - real(r8) :: rnewdry13(pcols,pver) ! New dry modal radius, mode 13, from look-up tables, method 2. - real(r8) :: rnewdry14(pcols,pver) ! New dry modal radius, mode 14, from look-up tables, method 2. - real(r8) :: relhum(pcols,pver) ! Ambient relative humidity (fraction) - real(r8) :: v3so4(pcols,pver,nmodes) ! Modal mass fraction of Sulfate - real(r8) :: v3insol(pcols,pver,nmodes)! Modal mass fraction of BC and dust - real(r8) :: v3oc(pcols,pver,nmodes) ! Modal mass fraction of OC (POM) - real(r8) :: v3ss(pcols,pver,nmodes) ! Modal mass fraction of sea-salt - real(r8) :: frh(pcols,pver,nmodes) ! Modal humidity growth factor -#endif !----------------------------------------------------------------------- call t_startf('bc_init') @@ -2341,54 +2288,6 @@ subroutine tphysbc (ztodt, state, & call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) call physics_update(state, ptend, ztodt, tend) -#ifdef AEROCOM - ! Estimating hygroscopic growth by use of linear interpolation w.r.t. mass - ! fractions of each internally mixed component for each mode (kcomp). - ! - call intfrh(lchnk, ncol, v3so4, v3insol, v3oc, v3ss, relhum, frh) - ! - do k=1,pver - do i=1,ncol - rnewdry1(i,k) = rnew3d(i,k,1) - rnewdry2(i,k) = rnew3d(i,k,2) - rnewdry4(i,k) = rnew3d(i,k,4) - rnewdry5(i,k) = rnew3d(i,k,5) - rnewdry6(i,k) = rnew3d(i,k,6) - rnewdry7(i,k) = rnew3d(i,k,7) - rnewdry8(i,k) = rnew3d(i,k,8) - rnewdry9(i,k) = rnew3d(i,k,9) - rnewdry10(i,k) = rnew3d(i,k,10) - rnewdry11(i,k) = rnew3d(i,k,11) - rnewdry13(i,k) = rnew3d(i,k,13) - rnewdry14(i,k) = rnew3d(i,k,14) - rnew1(i,k) = rnew3d(i,k,1)*frh(i,k,1) - rnew2(i,k) = rnew3d(i,k,2)*frh(i,k,2) - rnew4(i,k) = rnew3d(i,k,4)*frh(i,k,4) - rnew5(i,k) = rnew3d(i,k,5)*frh(i,k,5) - rnew6(i,k) = rnew3d(i,k,6)*frh(i,k,6) - rnew7(i,k) = rnew3d(i,k,7)*frh(i,k,7) - rnew8(i,k) = rnew3d(i,k,8)*frh(i,k,8) - rnew9(i,k) = rnew3d(i,k,9)*frh(i,k,9) - rnew10(i,k) = rnew3d(i,k,10)*frh(i,k,10) - rnew11(i,k) = rnew3d(i,k,11)*frh(i,k,11) - rnew13(i,k) = rnew3d(i,k,13)*frh(i,k,13) - rnew14(i,k) = rnew3d(i,k,14)*frh(i,k,14) - logsig1(i,k) = logsig3d(i,k,1) - logsig2(i,k) = logsig3d(i,k,2) - logsig4(i,k) = logsig3d(i,k,4) - logsig5(i,k) = logsig3d(i,k,5) - logsig6(i,k) = logsig3d(i,k,6) - logsig7(i,k) = logsig3d(i,k,7) - logsig8(i,k) = logsig3d(i,k,8) - logsig9(i,k) = logsig3d(i,k,9) - logsig10(i,k)= logsig3d(i,k,10) - logsig11(i,k)= logsig3d(i,k,11) - logsig13(i,k)= logsig3d(i,k,13) - logsig14(i,k)= logsig3d(i,k,14) - end do - end do -#endif ! AEROCOM - if (carma_do_wetdep) then ! CARMA wet deposition ! diff --git a/src/physics/cam/micro_mg_data.F90 b/src/physics/cam/micro_mg_data.F90 deleted file mode 100644 index 9a4d0c4a5e..0000000000 --- a/src/physics/cam/micro_mg_data.F90 +++ /dev/null @@ -1,550 +0,0 @@ -module micro_mg_data - -! -! Packing and time averaging for the MG interface. -! -! Use is as follows: -! -! 1) Figure out which columns will do averaging (mgncol) and the number of -! levels where the microphysics will run (nlev). -! -! 2) Create an MGPacker object and assign it as follows: -! -! packer = MGPacker(pcols, pver, mgcols, top_lev) -! -! Where [pcols, pver] is the shape of the ultimate input/output arrays -! that are defined at level midpoints. -! -! 3) Create a post-processing array of type MGPostProc: -! -! post_proc = MGPostProc(packer) -! -! 4) Add pairs of pointers for packed and unpacked representations, already -! associated with buffers of the correct dimensions: -! -! call post_proc%add_field(unpacked_pointer, packed_pointer, & -! fillvalue, accum_mean) -! -! The third value is the default value used to "unpack" for points with -! no "packed" part, and the fourth value is the method used to -! accumulate values over time steps. These two arguments can be omitted, -! in which case the default value will be 0 and the accumulation method -! will take the mean. -! -! 5) Use the packed fields in MG, and for each MG iteration, do: -! -! call post_proc%accumulate() -! -! 6) Perform final accumulation and scatter values into the unpacked arrays: -! -! call post_proc%process_and_unpack() -! -! 7) Destroy the object when complete: -! -! call post_proc%finalize() -! -! Caveat: MGFieldPostProc will hit a divide-by-zero error if you try to -! take the mean over 0 steps. -! - -! This include header defines CPP macros that only have an effect for debug -! builds. -#include "shr_assert.h" - -use shr_kind_mod, only: r8 => shr_kind_r8 -use shr_log_mod, only: & - errMsg => shr_log_errMsg, & - OOBMsg => shr_log_OOBMsg -use shr_sys_mod, only: shr_sys_abort - -implicit none -private - -public :: MGPacker -public :: MGFieldPostProc -public :: accum_null -public :: accum_mean -public :: MGPostProc - -type :: MGPacker - ! Unpacked array dimensions. - integer :: pcols - integer :: pver - ! Calculated packed dimensions, stored for convenience. - integer :: mgncol - integer :: nlev - ! Which columns are packed. - integer, allocatable :: mgcols(:) - ! Topmost level to copy into the packed array. - integer :: top_lev - contains - procedure, private :: pack_1D - procedure, private :: pack_2D - procedure, private :: pack_3D - generic :: pack => pack_1D, pack_2D, pack_3D - procedure :: pack_interface - procedure, private :: unpack_1D - procedure, private :: unpack_1D_array_fill - procedure, private :: unpack_2D - procedure, private :: unpack_2D_array_fill - procedure, private :: unpack_3D - procedure, private :: unpack_3D_array_fill - generic :: unpack => unpack_1D, unpack_1D_array_fill, & - unpack_2D, unpack_2D_array_fill, unpack_3D, unpack_3D_array_fill - procedure :: finalize => MGPacker_finalize -end type MGPacker - -interface MGPacker - module procedure new_MGPacker -end interface - -! Enum for time accumulation/averaging methods. -integer, parameter :: accum_null = 0 -integer, parameter :: accum_mean = 1 - -type :: MGFieldPostProc - integer :: accum_method = -1 - integer :: rank = -1 - integer :: num_steps = 0 - real(r8) :: fillvalue = 0._r8 - real(r8), pointer :: unpacked_1D(:) => null() - real(r8), pointer :: packed_1D(:) => null() - real(r8), allocatable :: buffer_1D(:) - real(r8), pointer :: unpacked_2D(:,:) => null() - real(r8), pointer :: packed_2D(:,:) => null() - real(r8), allocatable :: buffer_2D(:,:) - contains - procedure :: accumulate => MGFieldPostProc_accumulate - procedure :: process_and_unpack => MGFieldPostProc_process_and_unpack - procedure :: unpack_only => MGFieldPostProc_unpack_only - procedure :: finalize => MGFieldPostProc_finalize -end type MGFieldPostProc - -interface MGFieldPostProc - module procedure MGFieldPostProc_1D - module procedure MGFieldPostProc_2D -end interface MGFieldPostProc - -#define VECTOR_NAME MGFieldPostProcVec -#define TYPE_NAME type(MGFieldPostProc) -#define THROW(string) call shr_sys_abort(string) - -public :: VECTOR_NAME - -#include "dynamic_vector_typedef.inc" - -type MGPostProc - type(MGPacker) :: packer - type(MGFieldPostProcVec) :: field_procs - contains - procedure, private :: add_field_1D - procedure, private :: add_field_2D - generic :: add_field => add_field_1D, add_field_2D - procedure :: accumulate => MGPostProc_accumulate - procedure :: process_and_unpack => MGPostProc_process_and_unpack - procedure :: unpack_only => MGPostProc_unpack_only - procedure :: finalize => MGPostProc_finalize - procedure, private :: MGPostProc_copy - generic :: assignment(=) => MGPostProc_copy -end type MGPostProc - -interface MGPostProc - module procedure new_MGPostProc -end interface MGPostProc - -contains - -function new_MGPacker(pcols, pver, mgcols, top_lev) - integer, intent(in) :: pcols, pver - integer, intent(in) :: mgcols(:) - integer, intent(in) :: top_lev - - type(MGPacker) :: new_MGPacker - - new_MGPacker%pcols = pcols - new_MGPacker%pver = pver - new_MGPacker%mgncol = size(mgcols) - new_MGPacker%nlev = pver - top_lev + 1 - - allocate(new_MGPacker%mgcols(new_MGPacker%mgncol)) - new_MGPacker%mgcols = mgcols - new_MGPacker%top_lev = top_lev - -end function new_MGPacker - -! Rely on the fact that intent(out) forces the compiler to deallocate all -! allocatable components and restart the type from scratch. Although -! compiler support for finalization varies, this seems to be one of the few -! cases where all major compilers are reliable, and humans are not. -subroutine MGPacker_finalize(self) - class(MGPacker), intent(out) :: self -end subroutine MGPacker_finalize - -function pack_1D(self, unpacked) result(packed) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: unpacked(:) - - real(r8) :: packed(self%mgncol) - - SHR_ASSERT(size(unpacked) == self%pcols, errMsg(__FILE__, __LINE__)) - - packed = unpacked(self%mgcols) - -end function pack_1D - -! Separation of pack and pack_interface is to workaround a PGI bug. -function pack_2D(self, unpacked) result(packed) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: unpacked(:,:) - - real(r8) :: packed(self%mgncol,self%nlev) - - SHR_ASSERT(size(unpacked, 1) == self%pcols, errMsg(__FILE__, __LINE__)) - - packed = unpacked(self%mgcols,self%top_lev:) - -end function pack_2D - -function pack_interface(self, unpacked) result(packed) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: unpacked(:,:) - - real(r8) :: packed(self%mgncol,self%nlev+1) - - packed = unpacked(self%mgcols,self%top_lev:) - -end function pack_interface - -function pack_3D(self, unpacked) result(packed) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: unpacked(:,:,:) - - real(r8) :: packed(self%mgncol,self%nlev,size(unpacked, 3)) - - SHR_ASSERT(size(unpacked,1) == self%pcols, errMsg(__FILE__, __LINE__)) - - packed = unpacked(self%mgcols,self%top_lev:,:) - -end function pack_3D - -function unpack_1D(self, packed, fill) result(unpacked) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: packed(:) - real(r8), intent(in) :: fill - - real(r8) :: unpacked(self%pcols) - - SHR_ASSERT(size(packed) == self%mgncol, errMsg(__FILE__, __LINE__)) - - unpacked = fill - unpacked(self%mgcols) = packed - -end function unpack_1D - -function unpack_1D_array_fill(self, packed, fill) result(unpacked) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: packed(:) - real(r8), intent(in) :: fill(:) - - real(r8) :: unpacked(self%pcols) - - SHR_ASSERT(size(packed) == self%mgncol, errMsg(__FILE__, __LINE__)) - - unpacked = fill - unpacked(self%mgcols) = packed - -end function unpack_1D_array_fill - -function unpack_2D(self, packed, fill) result(unpacked) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: packed(:,:) - real(r8), intent(in) :: fill - - real(r8) :: unpacked(self%pcols,self%pver+size(packed, 2)-self%nlev) - - SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) - - unpacked = fill - unpacked(self%mgcols,self%top_lev:) = packed - -end function unpack_2D - -function unpack_2D_array_fill(self, packed, fill) result(unpacked) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: packed(:,:) - real(r8), intent(in) :: fill(:,:) - - real(r8) :: unpacked(self%pcols,self%pver+size(packed, 2)-self%nlev) - - SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) - - unpacked = fill - unpacked(self%mgcols,self%top_lev:) = packed - -end function unpack_2D_array_fill - -function unpack_3D(self, packed, fill) result(unpacked) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: packed(:,:,:) - real(r8), intent(in) :: fill - - real(r8) :: unpacked(self%pcols,self%pver,size(packed, 3)) - - SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) - - unpacked = fill - unpacked(self%mgcols,self%top_lev:,:) = packed - -end function unpack_3D - -function unpack_3D_array_fill(self, packed, fill) result(unpacked) - class(MGPacker), intent(in) :: self - real(r8), intent(in) :: packed(:,:,:) - real(r8), intent(in) :: fill(:,:,:) - - real(r8) :: unpacked(self%pcols,self%pver,size(packed, 3)) - - SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) - - unpacked = fill - unpacked(self%mgcols,self%top_lev:,:) = packed - -end function unpack_3D_array_fill - -function MGFieldPostProc_1D(unpacked_ptr, packed_ptr, fillvalue, & - accum_method) result(field_proc) - real(r8), pointer, intent(in) :: unpacked_ptr(:) - real(r8), pointer, intent(in) :: packed_ptr(:) - real(r8), intent(in), optional :: fillvalue - integer, intent(in), optional :: accum_method - type(MGFieldPostProc) :: field_proc - - field_proc%rank = 1 - field_proc%unpacked_1D => unpacked_ptr - field_proc%packed_1D => packed_ptr - if (present(fillvalue)) then - field_proc%fillvalue = fillvalue - else - field_proc%fillvalue = 0._r8 - end if - if (present(accum_method)) then - field_proc%accum_method = accum_method - else - field_proc%accum_method = accum_mean - end if - -end function MGFieldPostProc_1D - -function MGFieldPostProc_2D(unpacked_ptr, packed_ptr, fillvalue, & - accum_method) result(field_proc) - real(r8), pointer, intent(in) :: unpacked_ptr(:,:) - real(r8), pointer, intent(in) :: packed_ptr(:,:) - real(r8), intent(in), optional :: fillvalue - integer, intent(in), optional :: accum_method - type(MGFieldPostProc) :: field_proc - - field_proc%rank = 2 - field_proc%unpacked_2D => unpacked_ptr - field_proc%packed_2D => packed_ptr - if (present(fillvalue)) then - field_proc%fillvalue = fillvalue - else - field_proc%fillvalue = 0._r8 - end if - if (present(accum_method)) then - field_proc%accum_method = accum_method - else - field_proc%accum_method = accum_mean - end if - -end function MGFieldPostProc_2D - -! Use the same intent(out) trick as for MGPacker, which is actually more -! useful here. -subroutine MGFieldPostProc_finalize(self) - class(MGFieldPostProc), intent(out) :: self -end subroutine MGFieldPostProc_finalize - -subroutine MGFieldPostProc_accumulate(self) - class(MGFieldPostProc), intent(inout) :: self - - select case (self%accum_method) - case (accum_null) - ! "Null" method does nothing. - case (accum_mean) - ! Allocation is done on the first accumulation step to allow the - ! MGFieldPostProc to be copied after construction without copying the - ! allocated array (until this function is first called). - self%num_steps = self%num_steps + 1 - select case (self%rank) - case (1) - SHR_ASSERT(associated(self%packed_1D), errMsg(__FILE__, __LINE__)) - if (.not. allocated(self%buffer_1D)) then - allocate(self%buffer_1D(size(self%packed_1D))) - self%buffer_1D = 0._r8 - end if - self%buffer_1D = self%buffer_1D + self%packed_1D - case (2) - SHR_ASSERT(associated(self%packed_2D), errMsg(__FILE__, __LINE__)) - if (.not. allocated(self%buffer_2D)) then - ! Awkward; in F2008 can be replaced by source/mold. - allocate(self%buffer_2D(& - size(self%packed_2D, 1),size(self%packed_2D, 2))) - self%buffer_2D = 0._r8 - end if - self%buffer_2D = self%buffer_2D + self%packed_2D - case default - call shr_sys_abort(errMsg(__FILE__, __LINE__) // & - " Unsupported rank for MGFieldPostProc accumulation.") - end select - case default - call shr_sys_abort(errMsg(__FILE__, __LINE__) // & - " Unrecognized MGFieldPostProc accumulation method.") - end select - -end subroutine MGFieldPostProc_accumulate - -subroutine MGFieldPostProc_process_and_unpack(self, packer) - class(MGFieldPostProc), intent(inout) :: self - class(MGPacker), intent(in) :: packer - - select case (self%accum_method) - case (accum_null) - ! "Null" method just leaves the value as the last time step, so don't - ! actually need to do anything. - case (accum_mean) - select case (self%rank) - case (1) - SHR_ASSERT(associated(self%packed_1D), errMsg(__FILE__, __LINE__)) - self%packed_1D = self%buffer_1D/self%num_steps - case (2) - SHR_ASSERT(associated(self%packed_2D), errMsg(__FILE__, __LINE__)) - self%packed_2D = self%buffer_2D/self%num_steps - case default - call shr_sys_abort(errMsg(__FILE__, __LINE__) // & - " Unsupported rank for MGFieldPostProc accumulation.") - end select - case default - call shr_sys_abort(errMsg(__FILE__, __LINE__) // & - " Unrecognized MGFieldPostProc accumulation method.") - end select - - call self%unpack_only(packer) - -end subroutine MGFieldPostProc_process_and_unpack - -subroutine MGFieldPostProc_unpack_only(self, packer) - class(MGFieldPostProc), intent(inout) :: self - class(MGPacker), intent(in) :: packer - - select case (self%rank) - case (1) - SHR_ASSERT(associated(self%unpacked_1D), errMsg(__FILE__, __LINE__)) - self%unpacked_1D = packer%unpack(self%packed_1D, self%fillvalue) - case (2) - SHR_ASSERT(associated(self%unpacked_2D), errMsg(__FILE__, __LINE__)) - self%unpacked_2D = packer%unpack(self%packed_2D, self%fillvalue) - case default - call shr_sys_abort(errMsg(__FILE__, __LINE__) // & - " Unsupported rank for MGFieldPostProc unpacking.") - end select - -end subroutine MGFieldPostProc_unpack_only - -#include "dynamic_vector_procdef.inc" - -function new_MGPostProc(packer) result(post_proc) - type(MGPacker), intent(in) :: packer - - type(MGPostProc) :: post_proc - - post_proc%packer = packer - call post_proc%field_procs%clear() - -end function new_MGPostProc - -! Can't use the same intent(out) trick, because PGI doesn't get the -! recursive deallocation right. -subroutine MGPostProc_finalize(self) - class(MGPostProc), intent(inout) :: self - - integer :: i - - call self%packer%finalize() - do i = 1, self%field_procs%vsize() - call self%field_procs%data(i)%finalize() - end do - call self%field_procs%clear() - call self%field_procs%shrink_to_fit() - -end subroutine MGPostProc_finalize - -subroutine add_field_1D(self, unpacked_ptr, packed_ptr, fillvalue, & - accum_method) - class(MGPostProc), intent(inout) :: self - real(r8), pointer, intent(in) :: unpacked_ptr(:) - real(r8), pointer, intent(in) :: packed_ptr(:) - real(r8), intent(in), optional :: fillvalue - integer, intent(in), optional :: accum_method - - call self%field_procs%push_back(MGFieldPostProc(unpacked_ptr, & - packed_ptr, fillvalue, accum_method)) - -end subroutine add_field_1D - -subroutine add_field_2D(self, unpacked_ptr, packed_ptr, fillvalue, & - accum_method) - class(MGPostProc), intent(inout) :: self - real(r8), pointer, intent(in) :: unpacked_ptr(:,:) - real(r8), pointer, intent(in) :: packed_ptr(:,:) - real(r8), intent(in), optional :: fillvalue - integer, intent(in), optional :: accum_method - - call self%field_procs%push_back(MGFieldPostProc(unpacked_ptr, & - packed_ptr, fillvalue, accum_method)) - -end subroutine add_field_2D - -subroutine MGPostProc_accumulate(self) - class(MGPostProc), intent(inout) :: self - - integer :: i - - do i = 1, self%field_procs%vsize() - call self%field_procs%data(i)%accumulate() - end do - -end subroutine MGPostProc_accumulate - -subroutine MGPostProc_process_and_unpack(self) - class(MGPostProc), intent(inout) :: self - - integer :: i - - do i = 1, self%field_procs%vsize() - call self%field_procs%data(i)%process_and_unpack(self%packer) - end do - -end subroutine MGPostProc_process_and_unpack - -subroutine MGPostProc_unpack_only(self) - class(MGPostProc), intent(inout) :: self - - integer :: i - - do i = 1, self%field_procs%vsize() - call self%field_procs%data(i)%unpack_only(self%packer) - end do - -end subroutine MGPostProc_unpack_only - -! This is necessary only to work around Intel/PGI bugs. -subroutine MGPostProc_copy(lhs, rhs) - class(MGPostProc), intent(out) :: lhs - type(MGPostProc), intent(in) :: rhs - - lhs%packer = rhs%packer - lhs%field_procs = rhs%field_procs -end subroutine MGPostProc_copy - -end module micro_mg_data From 42189f93512683b852d1cd9de8cd30ca16fdbfba Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 8 Nov 2023 12:06:57 +0100 Subject: [PATCH 64/71] new oslo aero in release with aerocom --- Externals.cfg | 53 +++++++++++++++------------------- bld/configure | 5 ++-- src/NorESM/cam_diagnostics.F90 | 2 +- src/NorESM/physpkg.F90 | 1 - 4 files changed, 27 insertions(+), 34 deletions(-) diff --git a/Externals.cfg b/Externals.cfg index ae55b59381..62859ee6df 100644 --- a/Externals.cfg +++ b/Externals.cfg @@ -1,60 +1,53 @@ -[externals_description] -schema_version = 1.0.0 - [cice] -tag = cice5_cesm2_0_rel_01 +tag = cice5_20181109-Nor_v1.0.3 protocol = git -repo_url = https://github.com/ESCOMP/CESM_CICE5 -required = True +repo_url = https://github.com/NorESMHub/CESM_CICE5 local_path = components/cice +required = True [cime] -tag = cime_cesm2_0_rel_06 +tag = cime5.6.10_cesm2_1_rel_06-Nor_v1.0.6 protocol = git -repo_url = https://github.com/ESMCI/cime -required = True +repo_url = https://github.com/NorESMhub/cime local_path = cime +required = True [cism] -tag = release-cesm2.0.01 +tag = wrapper_noresm2.0.6_v0 protocol = git -repo_url = https://github.com/ESCOMP/cism-wrapper -externals = Externals_CISM.cfg -required = True +repo_url = https://github.com/NorESMhub/cism-wrapper local_path = components/cism +externals = Externals_CISM.cfg +required = False [clm] -tag = release-clm5.0.01 +tag = release-clm5.0.14-Nor_v1.0.4 protocol = git -repo_url = https://github.com/ESCOMP/ctsm +repo_url = https://github.com/NorESMhub/ctsm +local_path = components/clm externals = Externals_CLM.cfg required = True -local_path = components/clm [mosart] -tag = release-cesm2.0.00 +tag = release-cesm2.0.03-Nor_v1.0.0 protocol = git -repo_url = https://github.com/ESCOMP/mosart +repo_url = https://github.com/NorESMhub/mosart +local_path = components/mosart required = True -local_path = components/mosart [rtm] -tag = release-cesm2.0.00 +tag = release-cesm2.0.02 protocol = git repo_url = https://github.com/ESCOMP/rtm -required = True local_path = components/rtm +required = False [ww3] -tag = ww3_cesm2_0_rel_01 +tag = ww3_cesm2_1_rel_01 protocol = svn -repo_url = https://svn-ccsm-models.cgd.ucar.edu/ww3/release_tags -required = True +repo_url = https://svn-ccsm-models.cgd.ucar.edu/ww3/release_tags local_path = components/ww3 +required = False -[cam] -local_path = . -protocol = externals_only -externals = Externals_CAM.cfg -required = True - +[externals_description] +schema_version = 1.0.0 diff --git a/bld/configure b/bld/configure index 51c0fe8110..137ea4ec16 100755 --- a/bld/configure +++ b/bld/configure @@ -1416,7 +1416,8 @@ if ($chem_pkg =~ '_mam3') { } if ($chem_pkg =~ '_oslo') { - $chem_cppdefs = ' -DOSLO_AERO -DDIRIND' + $chem_cppdefs = ' -DOSLO_AERO -DAEROCOM' + #$chem_cppdefs = ' -DOSLO_AERO' } # CARMA sectional microphysics @@ -2764,7 +2765,7 @@ sub write_filepath #--djlo if ($chem =~/_oslo/) { - print $fh "$camsrcdir/src/chemistry/oslo_aero/src_cam\n"; + print $fh "$camsrcdir/cam/src/chemistry/oslo_aero/src_cam\n"; } # offline unit driver (defaults to stub) diff --git a/src/NorESM/cam_diagnostics.F90 b/src/NorESM/cam_diagnostics.F90 index b638b968b1..15ebbab3c6 100644 --- a/src/NorESM/cam_diagnostics.F90 +++ b/src/NorESM/cam_diagnostics.F90 @@ -181,7 +181,7 @@ subroutine diag_init_dry(pbuf2d) use physics_buffer, only: pbuf_set_field use tidal_diag, only: tidal_diag_init #ifdef OSLO_AERO - use oslo_aero_params, only: nbmodes + use oslo_aero_share, only: nbmodes #endif type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index b44fd72606..52362a9782 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -1743,7 +1743,6 @@ subroutine tphysbc (ztodt, state, & use aero_model, only: aero_model_wetdep #ifdef OSLO_AERO use oslo_aero_microp,only: oslo_aero_microp_run - use oslo_aero_params use oslo_aero_share #else use microp_aero, only: microp_aero_run From 3f94fb49334f7a015e99ac7b14757a474a2976ef Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 20 Nov 2023 12:23:08 +0100 Subject: [PATCH 65/71] updates to be consistent with 2_1 release updates --- Externals_CAM.cfg | 3 +- bld/config_files/definition.xml | 13 +- bld/configure | 74 +- cime_config/config_component.xml | 388 ++--- cime_config/config_compsets.xml | 525 ++---- cime_config/config_pes.xml | 2159 +++++++------------------ cime_config/testdefs/testlist_cam.xml | 1062 +----------- 7 files changed, 954 insertions(+), 3270 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index f7d9774569..8f049753f8 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -1,7 +1,7 @@ [oslo_aero] local_path = src/chemistry/oslo_aero protocol = git -repo_url = https://github.com/NorESMhub/OSLO_AERO.git +repo_url = https://github.com/mvertens/OSLO_AERO.git branch = feature/oslo_aero_integrate_release required = True @@ -14,4 +14,3 @@ required = True [externals_description] schema_version = 1.0.0 - diff --git a/bld/config_files/definition.xml b/bld/config_files/definition.xml index 332d60e8bf..f7ad495271 100644 --- a/bld/config_files/definition.xml +++ b/bld/config_files/definition.xml @@ -52,6 +52,9 @@ Ionosphere model used in WACCMX. Physics package: cam3, cam4, cam5, cam6, held_suarez, adiabatic, kessler, tj2016, spcam_sam1mom, spcam_m2005. + +Option to turn on NorESM modifications to baseline CESM/CAM physics and dynamics + Microphysics package: rk (Rasch and Kristjansson), mg1 and mg2 (Morrison and Gettelman), SPCAM_m2005, SPCAM_sam1mom. @@ -77,15 +80,15 @@ PBL package: uw (University of Washington), hb (Holtslag and Boville), hbr (Holtslag, Boville, and Rasch), clubb_sgs, spcam_sam1om, spcam_m2005, none. -Radiative transfer calculation: +Radiative transfer calculation: camrt (CAM3 and CAM4 RT package), rrtmg (RRTMG package from AER). -CARMA sectional microphysics: +CARMA sectional microphysics: none (disabled), bc_strat (Stratospheric Black Carbon), cirrus (Cirrus Clouds), -cirrus_dust (Cirrus Clouds with dust), dust (Dust), meteor_impact (Meteor Impact), +cirrus_dust (Cirrus Clouds with dust), dust (Dust), meteor_impact (Meteor Impact), meteor_smoke (Meteor Smoke), mixed_sulfate (Meteor Smoke and Sulfate), pmc (Polar Mesospheric Clouds), pmc_sulfate (PMC and Sulfate), sea_salt (Sea Salt), -sulfate (Sulfate Aerosols), tholin (early earth haze), test_detrain (Detrainment), test_growth (Particle Growth), test_passive (Passive Dust), +sulfate (Sulfate Aerosols), tholin (early earth haze), test_detrain (Detrainment), test_growth (Particle Growth), test_passive (Passive Dust), test_radiative (Radiatively Active Dust), test_swelling (Sea Salt), test_tracers (Asian Monsoon), test_tracers2 (Guam). @@ -304,7 +307,7 @@ SPCAM number of grid points in z SPCAM horizontal grid spacing, m - + SPCAM time step, s diff --git a/bld/configure b/bld/configure index 137ea4ec16..97b6fa37ec 100755 --- a/bld/configure +++ b/bld/configure @@ -114,6 +114,7 @@ OPTIONS -analytic_ic Enables the (namelist controlled) dycore testing infrastructure -aquaplanet Switch on aqua-planet mode. -build_chem_proc Switch forces the build of the chemistry preprocessor (primarily for testing). + -camnor Build CAM with CAM-Nor modifications -carma Build CAM with specified CARMA microphysics model [ none | bc_strat | cirrus | cirrus_dust | dust | meteor_impact | meteor_smoke | mixed_sulfate | pmc | pmc_sulfate | sea_salt | sulfate | tholin | @@ -121,10 +122,11 @@ OPTIONS test_tracers, test_tracers2]. Default: none. -chem Build CAM with specified prognostic chemistry package - [ trop_mam3 | trop_mam4 | trop_mam7 | trop_mozart | trop_strat_mam4_vbs | trop_strat_mam4_vbsext | - waccm_ma | waccm_mad | waccm_mad_mam4 | waccm_ma_mam4 | - waccm_ma_sulfur | waccm_sc | waccm_sc_mam4 | waccm_tsmlt_mam4 | + [ trop_mam3 | trop_mam4 | trop_mam7 | trop_mozart | trop_strat_mam4_vbs | trop_strat_mam4_vbsext | + waccm_ma | waccm_mad | waccm_mad_mam4 | waccm_ma_mam4 | + waccm_ma_sulfur | waccm_sc | waccm_sc_mam4 | waccm_tsmlt_mam4 | terminator | trop_mam_oslo | none ]. + Default: trop_mam_oslo when -camnor is specified Default: trop_mam4 for cam6 and trop_mam3 for cam5. -[no]clubb_sgs Switch on [off] CLUBB_SGS. Default: on for cam6, otherwise off. -clubb_opts Comma separated list of CLUBB options to turn on/off. By default they are all off. @@ -299,6 +301,7 @@ GetOptions( "cam_exe=s" => \$opts{'cam_exe'}, "cam_exedir=s" => \$opts{'cam_exedir'}, "camiop" => \$opts{'camiop'}, + "camnor!" => \$opts{'camnor'}, "cc=s" => \$opts{'cc'}, "ccsm_seq" => \$opts{'ccsm_seq'}, "cflags=s" => \$opts{'cflags'}, @@ -612,11 +615,26 @@ if (defined $opts{'phys'}) { $phys_pkg = lc($opts{'phys'}); } +# Special configuration for CAM-Nor options +# Currently, each CAM-Nor selection only works with the CAM6 +# ESCOMP/CAM physics suites +my $camnor = 0; +# user or compset override is only way to turn on this feature +if (defined $opts{'camnor'}) { + $camnor = $opts{'camnor'}; +} + # Add to the config object. $cfg_ref->set('phys', $phys_pkg); +$cfg_ref->set('camnor', $camnor); -if ($print>=2) { print "Physics package: $phys_pkg$eol"; } - +if ($print>=2) { + if ($camnor) { + print "Physics package: $phys_pkg with CAM-Nor modifications$eol"; + } else { + print "Physics package: $phys_pkg$eol"; + } +} # Set flag to indicate a simple physics option my $simple_phys = 0; @@ -633,6 +651,9 @@ my $chem_pkg = 'trop_mam4'; if ($simple_phys or $phys_pkg =~ m/^cam[34]$/ or $phys_pkg eq 'spcam_sam1mom') { $chem_pkg = 'none'; } +elsif ($camnor) { + $chem_pkg = 'trop_mam_oslo'; +} elsif ($phys_pkg eq 'cam5' or $phys_pkg eq 'spcam_m2005') { $chem_pkg = 'trop_mam3'; } @@ -1416,8 +1437,8 @@ if ($chem_pkg =~ '_mam3') { } if ($chem_pkg =~ '_oslo') { - $chem_cppdefs = ' -DOSLO_AERO -DAEROCOM' - #$chem_cppdefs = ' -DOSLO_AERO' + #$chem_cppdefs = ' -DOSLO_AERO -DAEROCOM' + $chem_cppdefs = ' -DOSLO_AERO' } # CARMA sectional microphysics @@ -1921,7 +1942,7 @@ if ($cfg_ref->get('analytic_ic')) { #WACCM-X extended thermosphere/ionosphere model if ($waccmx) { - $cfg_cppdefs .= ' -DWACCMX_PHYS'; + $cfg_cppdefs .= ' -DWACCMX_PHYS'; if (($dyn_pkg ne 'fv') and ($ionos ne 'none')) { die "ERROR: Ionosphere is only available for FV dycore \n"; } @@ -2732,6 +2753,7 @@ sub write_filepath my $ocn = $cfg_ref->get('ocn'); my $offline_drv = $cfg_ref->get('offline_drv'); my $inic_val = $cfg_ref->get('analytic_ic'); + my $camnor = $cfg_ref->get('camnor'); # Root directory my $camsrcdir = "$cam_root/components"; @@ -2748,24 +2770,17 @@ sub write_filepath } } - # CESM has a standard source mods location. + # Standard source mods location. if ($ccsm_seq) { my $CASEROOT = "$ENV{'CASEROOT'}"; print $fh "$CASEROOT/SourceMods/src.cam\n"; } - # NorESM-specific: - # Any files in "NorESM"-folder go before the original CAM-files - # These files MUST give back standard CAM5.3 if a standard CAM5.3 compset is chosen - # Un-commenting this line will give back standard CAM 5.3 (unmodified). - # This is used for testing. - #++djlo (should be switched off when pure NCAR version is desired) - print $fh "$camsrcdir/cam/src/NorESM\n"; - print $fh "$camsrcdir/cam/src/NorESM/$dyn\n"; - #--djlo - - if ($chem =~/_oslo/) { - print $fh "$camsrcdir/cam/src/chemistry/oslo_aero/src_cam\n"; + # CAM-Nor has precedence over everything except SourceMods + # Only active in NF or NB compsets + if ($camnor) { + print $fh "$camsrcdir/cam/src/NorESM\n"; + print $fh "$camsrcdir/cam/src/NorESM/$dyn\n"; } # offline unit driver (defaults to stub) @@ -2793,14 +2808,15 @@ sub write_filepath print $fh "$chem_src_dir\n"; } if ($chem =~/_oslo/) { - print $fh "$camsrcdir/cam/src/chemistry/oslo_aero/src\n"; - } - else{ - if ($chem =~ /_mam/) { - print $fh "$camsrcdir/cam/src/chemistry/modal_aero\n"; - } else { - print $fh "$camsrcdir/cam/src/chemistry/bulk_aero\n"; - } + # print $fh "$camsrcdir/src/chemistry/oslo_aero/object\n"; BUG: this does not compile + print $fh "$camsrcdir/cam/src/chemistry/oslo_aero/src\n"; + print $fh "$camsrcdir/cam/src/chemistry/oslo_aero/src_cam\n"; + } else { + if ($chem =~ /_mam/) { + print $fh "$camsrcdir/cam/src/chemistry/modal_aero\n"; + } else { + print $fh "$camsrcdir/cam/src/chemistry/bulk_aero\n"; + } } print $fh "$camsrcdir/cam/src/chemistry/aerosol\n"; diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index 69fa8f0c32..b78f418f36 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -9,79 +9,69 @@ =============== --> CAM cam6 physics: - CAM cam5 physics: - CAM cam4 physics: - CAM simplified and non-versioned physics : + CAM cam5 physics: + CAM cam4 physics: + CAM simplified and non-versioned physics : - abrupt quadrupling of CO2 with other forcings maintained at 1850 piControl levels (CMIP6 DECK abrupt4xCO2 experiment) : - abrupt doubling of CO2 with other forcings maintained at 1850 piControl levels : - ramped CO2 increasing by 1% per year with other forcings maintained at 1850 piControl levels (CMIP6 DECK 1pctCO2 experiment) : - - cam 5 physics and Production tagged aerosols (OSLO_AERO) - cam 6 and Production tagged aerosols (OSLO_AERO) - cam 6 and general NorESM changes + Production tagged aerosols (OSLO_AERO) - cam 5.4+Production tagged aerosols (OSLO_AERO)+clm5 - cam 5 physics and Production tagged aerosols (OSLO_AERO) - cam 6 (no clubb) physics and Production tagged aerosols (OSLO_AERO) - cam 6 physics and Production tagged aerosols (OSLO_AERO) + abrupt quadrupling of CO2 with other forcings maintained at 1850 piControl levels (CMIP6 DECK abrupt4xCO2 experiment) : + abrupt doubling of CO2 with other forcings maintained at 1850 piControl levels : + ramped CO2 increasing by 1% per year with other forcings maintained at 1850 piControl levels (CMIP6 DECK 1pctCO2 experiment) : + + cam 6 and general NorESM changes + Production tagged aerosols (OSLO_AERO) - CAM stand-alone single column mode -- need to define usermods directory with IOP settings: - CAM winds and temperature nudged towards prescribed meteorology: + CAM stand-alone single column mode -- need to define usermods directory with IOP settings: + CAM winds and temperature nudged towards prescribed meteorology: - CAM-Chem troposphere/stratosphere chem with simplified volatility basis set SOA scheme and modal aersols : - CAM-Chem troposphere/stratosphere chem with simplified volatility basis set SOA scheme and fire emissons : - CAM CLUBB - turned on by default in CAM60: - CAM-Chem troposphere/stratosphere chem with extended volatility basis set SOA scheme and modal aersols : - CAM CO2 ramp: - CAM super-parameterized CAM one moment SAM microphysics - CAM super-parameterized CAM one moment SAM microphysics using CLUBB - CAM super-parameterized CAM double moment m2005 SAM microphysics - CAM super-parameterized CAM double moment m2005 SAM microphysics using CLUBB - CAM tropospheric chemistry with bulk aerosols: + CAM-Chem troposphere/stratosphere chem with simplified volatility basis set SOA scheme and modal aersols : + CAM-Chem troposphere/stratosphere chem with simplified volatility basis set SOA scheme and fire emissons : + CAM CLUBB - turned on by default in CAM60: + CAM-Chem troposphere/stratosphere chem with extended volatility basis set SOA scheme and modal aersols : + CAM CO2 ramp: + CAM tropospheric chemistry with bulk aerosols: - WACCM with middle atmosphere chemistry: - WACCM with middle atmosphere chemistry with enhanced D-region ion chemistry: - WACCM-X enhanced ionosphere, transport, and electrodynamics: - WACCM-X enhanced ionosphere, transport, and electrodynamics with D-region ion chemistry: - WACCM specified chemistry: - WACCM with tropospheric, stratospheric, mesospheric, and lower thermospheric chemistry: + WACCM with middle atmosphere chemistry: + WACCM with middle atmosphere chemistry with enhanced D-region ion chemistry: + WACCM-X enhanced ionosphere, transport, and electrodynamics: + WACCM-X enhanced ionosphere, transport, and electrodynamics with D-region ion chemistry: + WACCM specified chemistry: + WACCM with tropospheric, stratospheric, mesospheric, and lower thermospheric chemistry: - CAM dry adiabatic configurarion (no physics forcing): - CAM dry adiabatic baroclinic instability (Polvani et al., 2004): - CAM moist Held-Suarez forcing (Thatcher and Jablonowski, 2016): - CAM dry Held-Suarez forcing (Held and Suarez (1994)): - CAM moist dynamical core test with Ullrich et al. (2014) baroclinic wave IC, Kessler physics and terminator chemistry: + CAM dry adiabatic configurarion (no physics forcing): + CAM dry adiabatic baroclinic instability (Polvani et al., 2004): + CAM moist Held-Suarez forcing (Thatcher and Jablonowski, 2016): + CAM dry Held-Suarez forcing (Held and Suarez (1994)): + CAM moist dynamical core test with Ullrich et al. (2014) baroclinic wave IC, Kessler physics and terminator chemistry: - CAM Parallel Offline Radiation Tool: + CAM Parallel Offline Radiation Tool: @@ -129,41 +119,36 @@ -chem trop_strat_mam4_vbsext -clubb_sgs -dyn eul -scam - -rad camrt -chem none -spcam_nx 32 -spcam_ny 1 -spcam_dx 4000 -spcam_dt 20 -phys spcam_sam1mom - -rad camrt -chem none -spcam_nx 32 -spcam_ny 1 -spcam_dx 4000 -spcam_dt 20 -phys spcam_sam1mom -spcam_clubb_sgs - -rad rrtmg -chem trop_mam3 -spcam_nx 32 -spcam_ny 1 -spcam_dx 4000 -spcam_dt 20 -phys spcam_m2005 - -rad rrtmg -chem trop_mam3 -spcam_nx 32 -spcam_ny 1 -spcam_dx 4000 -spcam_dt 20 -phys spcam_m2005 -spcam_clubb_sgs -chem trop_mozart - -co2_cycle - -age_of_air_trcs - -chem waccm_ma - -chem waccm_ma_mam4 - -chem waccm_mad_mam4 - -chem waccm_sc_mam4 - -chem waccm_tsmlt_mam4 - -waccmx - -ionosphere wxie - -chem waccm_ma - -chem waccm_mad - -chem waccm_mad - - -offline_dyn - -nlev 56 - -nlev 56 - -nlev 88 - -nlev 145 + -age_of_air_trcs + -chem waccm_ma + -chem waccm_ma_mam4 + -chem waccm_mad_mam4 + -chem waccm_sc_mam4 + -chem waccm_tsmlt_mam4 + -waccmx + -ionosphere wxie + -chem waccm_ma + -chem waccm_mad + -chem waccm_mad + + -offline_dyn + -nlev 56 + -nlev 56 + -nlev 88 + -nlev 145 -analytic_ic - -phys adiabatic - -phys adiabatic - -phys tj2016 -analytic_ic - -phys held_suarez - -phys kessler -chem terminator -analytic_ic + -phys adiabatic + -phys adiabatic + -phys tj2016 -analytic_ic + -phys held_suarez + -phys kessler -chem terminator -analytic_ic -aquaplanet @@ -172,18 +157,14 @@ -offline_drv rad - -phys cam5 -chem trop_mam_oslo - -chem trop_mam_oslo - -chem trop_mam_oslo - -chem trop_mam_oslo -cosp - -chem trop_mam_oslo -cosp - -chem trop_mam_oslo -cosp - -chem trop_mam_oslo -cosp - -chem trop_mam_oslo - - -phys cam5 -chem trop_mam_oslo -offline_dyn - -chem trop_mam_oslo -offline_dyn - -chem trop_mam_oslo -offline_dyn + + -chem trop_mam_oslo -camnor + -chem trop_mam_oslo -camnor -cosp + -chem trop_mam_oslo -camnor -cosp + -chem trop_mam_oslo -camnor -cosp + -chem trop_mam_oslo -camnor -cosp + -chem trop_mam_oslo -camnor-offline_dyn + build_component_cam env_build.xml @@ -259,17 +240,6 @@ waccm_tsmlt_ssp370_cam6 waccm_tsmlt_ssp534_cam6 waccm_tsmlt_ssp585_cam6 - 2005-2100_cam4_rcp26 - 2005-2100_cam4_rcp45 - 2005-2100_cam4_rcp45_bgc - 2005-2100_cam4_rcp60 - 2005-2100_cam4_rcp85 - 2005-2100_cam4_rcp85_bgc - - 2006-2100_cam5_rcp26 - 2006-2100_cam5_rcp45 - 2006-2100_cam5_rcp60 - 2006-2100_cam5_rcp85 sd_waccmx_ma_cam4 sd_waccmx_ma_cam4 @@ -286,17 +256,14 @@ dctest_baro_kessler - scam_arm97 - 2000_cam6_noclb - 1850_cam54_ptaero - 2000_cam6_noclb_oslo - 2000_cam6_oslo - 2000_cam6_noresm - 2000_cam6_noresm_frc2 - 1850_cam6_oslo - 1850_cam6_noresm + scam_arm97 + 2000_cam6_noclb + 2000_cam6_noresm + 2000_cam6_noresm_frc2 + 1850_cam6_noresm 1850_cam6_noresm_frc2 1850_cam6_noresm_frc2 + 1850_cam6_noresm_ghgonly 1850_cam6_noresm_natonly @@ -313,31 +280,31 @@ 1850_cam6_noresm_aeronly 1850_cam6_noresm_oxidonly 1850_cam6_noresm_ozoneonly + - 1850_cam6_noresm_ghg2014 - 1850_cam6_noresm_ghgnoh2o2014 - 1850_cam6_noresm_co22014 - 1850_cam6_noresm_n2o2014 - 1850_cam6_noresm_ch42014 - 1850_cam6_noresm_ch4noh2o2014 - 1850_cam6_noresm_bc2014 - 1850_cam6_noresm_oc2014 - 1850_cam6_noresm_so22014 - 1850_cam6_noresm_aer2014 - 1850_cam6_noresm_aer2014_frc2 - 1850_cam6_noresm_aeroxid2014 + 1850_cam6_noresm_ghg2014 + 1850_cam6_noresm_ghgnoh2o2014 + 1850_cam6_noresm_co22014 + 1850_cam6_noresm_n2o2014 + 1850_cam6_noresm_ch42014 + 1850_cam6_noresm_ch4noh2o2014 + 1850_cam6_noresm_bc2014 + 1850_cam6_noresm_oc2014 + 1850_cam6_noresm_so22014 + 1850_cam6_noresm_aer2014 + 1850_cam6_noresm_aer2014_frc2 + 1850_cam6_noresm_aeroxid2014 1850_cam6_noresm_aeroxid2014_frc2 - 1850_cam6_noresm_so2oxid2014 - 1850_cam6_noresm_ntcf2014 - 1850_cam6_noresm_anthro2014 - 1850_cam6_noresm_ghgozone2014 - 1850_cam6_noresm_ozone2014 - 1850_cam6_noresm_h2o2014 - 1850_cam6_noresm_oxid2014 - 1850_cam6_noresm_oxid2014_frc2 - - hist_cam6_oslo - hist_cam6_noresm + 1850_cam6_noresm_so2oxid2014 + 1850_cam6_noresm_ntcf2014 + 1850_cam6_noresm_anthro2014 + 1850_cam6_noresm_ghgozone2014 + 1850_cam6_noresm_ozone2014 + 1850_cam6_noresm_h2o2014 + 1850_cam6_noresm_oxid2014 + 1850_cam6_noresm_oxid2014_frc2 + + hist_cam6_noresm hist_cam6_noresm_frc2 hist_cam6_noresm_frc2 hist_cam6_noresm_frc2 @@ -347,31 +314,32 @@ 1850esm_cam6_noresm_frc2 histesm_cam6_noresm histesm_cam6_noresm_frc2 - + sd_hist_cam6_noresm + hist_cam6_noresm_pintcf hist_cam6_noresm_piaer hist_cam6_noresm_piaeroxid + hist_cam6_noresm_pintcf hist_cam6_noresm_piaer + ssp126_cam6_noresm_frc2 + ssp126_cam6_noresm_frc2ext + ssp245_cam6_noresm_frc2 + ssp370_cam6_noresm_frc2 + ssp370lowntcf_cam6_noresm_frc2 + ssp370refghglowntcf_cam6_noresm_frc2 + ssp585_cam6_noresm_frc2 + ssp585_cam6_noresm_frc2ext + ssp534_cam6_noresm_frc2 + ssp534_cam6_noresm_frc2ext - ssp126_cam6_noresm_frc2 - ssp126_cam6_noresm_frc2ext - ssp245_cam6_noresm_frc2 - ssp370_cam6_noresm_frc2 - ssp370lowntcf_cam6_noresm_frc2 - ssp370refghglowntcf_cam6_noresm_frc2 - ssp585_cam6_noresm_frc2 - ssp585_cam6_noresm_frc2ext - ssp534_cam6_noresm_frc2 - ssp534_cam6_noresm_frc2ext - - ssp370_cam6_noresm_frc2 - ssp370_cam6_noresm_aerlow_frc2 + ssp370_cam6_noresm_frc2 + ssp370_cam6_noresm_aerlow_frc2 ssp245_cam6_noresm_covbaslin_frc2 ssp245_cam6_noresm_covfosfue_frc2 @@ -379,22 +347,17 @@ ssp245_cam6_noresm_covstrgre_frc2 ssp245_cam6_noresm_covtwobli_frc2 - ssp245_cam6_noresm_frc2 - ssp245_cam6_noresm_ghgonly_frc2 - ssp245_cam6_noresm_natonly_frc2 - ssp245_cam6_noresm_aeronly_frc2 - ssp245_cam6_noresm_aeroxidonly_frc2 + ssp245_cam6_noresm_frc2 + ssp245_cam6_noresm_ghgonly_frc2 + ssp245_cam6_noresm_natonly_frc2 + ssp245_cam6_noresm_aeronly_frc2 + ssp245_cam6_noresm_aeroxidonly_frc2 ssp585esm_cam6_noresm_frc2 ssp534esm_cam6_noresm_frc2 - 2000_cam5_oslonudge - cam5_nudge_ptaero_up1 - 2000_cam6_noclb_oslonudge - 2000_cam6_oslonudge 2000_cam5_oslonudge - cam5_ptaero_up1 run_component_cam env_run.xml @@ -434,15 +397,17 @@ dms_source='ocean_flux' co2_cycle_rad_passive=.true.,dms_source='ocean_flux' dms_source='ocean_flux' - co2vmr=1138.8e-6 - co2vmr=1138.8e-6 - co2vmr=568.64e-6 - flbc_type='SERIAL' - flbc_file='$DIN_LOC_ROOT/atm/waccm/lb/LBC_CMIP6_1pctCO2_y1-165_GlobAnnAvg_0p5degLat_c180929.nc' - flbc_list='CO2','CH4','N2O','CFC11eq','CFC12' - flbc_type='SERIAL' - flbc_file='$DIN_LOC_ROOT/atm/waccm/lb/LBC_CMIP6_1pctCO2_y1-165_GlobAnnAvg_0p5degLat_c180929.nc' - flbc_list='CO2','CH4','N2O','CFC11eq','CFC12' + + co2vmr=1138.8e-6 + co2vmr=1138.8e-6 + co2vmr=568.64e-6 + flbc_type='SERIAL' + flbc_file='$DIN_LOC_ROOT/atm/waccm/lb/LBC_CMIP6_1pctCO2_y1-165_GlobAnnAvg_0p5degLat_c180929.nc' + flbc_list='CO2','CH4','N2O','CFC11eq','CFC12' + flbc_type='SERIAL' + flbc_file='$DIN_LOC_ROOT/atm/waccm/lb/LBC_CMIP6_1pctCO2_y1-165_GlobAnnAvg_0p5degLat_c180929.nc' + flbc_list='CO2','CH4','N2O','CFC11eq','CFC12' + ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850frc2_f09_tn14_20191012_1351-1380_cycle_version20200106.nc' ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850_f19_tn14_20190621_1751-1780_cycle_version20190726.nc' @@ -450,6 +415,7 @@ opom_cycle_year=1850 dms_source_type='CYCLICAL' opom_source_type='CYCLICAL' + ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850frc2_f09_tn14_20191012_1351-1380_cycle_version20200106.nc' ocean_filename='dms-hamocc-dow-taylor_chlor_a-lanaclim_N1850_f19_tn14_20190621_1751-1780_cycle_version20190726.nc' @@ -480,64 +446,64 @@ co2vmr=568.64e-6 - aerocomk0_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk0.out' - aerocomk1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk1.out' - aerocomk2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk2.out' - aerocomk3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk3.out' - aerocomk4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk4.out' - aerocomk5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk5.out' - aerocomk6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk6.out' - aerocomk7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk7.out' - aerocomk8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk8.out' - aerocomk9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk9.out' - aerocomk10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk10.out' - - aerodryk0_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk0.out' - aerodryk1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk1.out' - aerodryk2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk2.out' - aerodryk3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk3.out' - aerodryk4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk4.out' - aerodryk5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk5.out' - aerodryk6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk6.out' - aerodryk7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk7.out' - aerodryk8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk8.out' - aerodryk9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk9.out' - aerodryk10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk10.out' - - kcomp0_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp0.out' - kcomp1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp1.out' - kcomp2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp2.out' - kcomp3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp3.out' - kcomp4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp4.out' - kcomp5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp5.out' - kcomp6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp6.out' - kcomp7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp7.out' - kcomp8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp8.out' - kcomp9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp9.out' - kcomp10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp10.out' - - logntilp1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp1.out' - logntilp2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp2.out' - logntilp3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp3.out' - logntilp4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp4.out' - logntilp5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp5.out' - logntilp6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp6.out' - logntilp7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp7.out' - logntilp8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp8.out' - logntilp9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp9.out' - logntilp10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp10.out' - - lwkcomp0_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp0.out' - lwkcomp1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp1.out' - lwkcomp2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp2.out' - lwkcomp3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp3.out' - lwkcomp4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp4.out' - lwkcomp5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp5.out' - lwkcomp6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp6.out' - lwkcomp7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp7.out' - lwkcomp8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp8.out' - lwkcomp9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp9.out' - lwkcomp10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp10.out' + aerocomk0_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk0.out' + aerocomk1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk1.out' + aerocomk2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk2.out' + aerocomk3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk3.out' + aerocomk4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk4.out' + aerocomk5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk5.out' + aerocomk6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk6.out' + aerocomk7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk7.out' + aerocomk8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk8.out' + aerocomk9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk9.out' + aerocomk10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerocomk10.out' + + aerodryk0_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk0.out' + aerodryk1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk1.out' + aerodryk2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk2.out' + aerodryk3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk3.out' + aerodryk4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk4.out' + aerodryk5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk5.out' + aerodryk6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk6.out' + aerodryk7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk7.out' + aerodryk8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk8.out' + aerodryk9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk9.out' + aerodryk10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/aerodryk10.out' + + kcomp0_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp0.out' + kcomp1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp1.out' + kcomp2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp2.out' + kcomp3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp3.out' + kcomp4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp4.out' + kcomp5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp5.out' + kcomp6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp6.out' + kcomp7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp7.out' + kcomp8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp8.out' + kcomp9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp9.out' + kcomp10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/kcomp10.out' + + logntilp1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp1.out' + logntilp2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp2.out' + logntilp3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp3.out' + logntilp4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp4.out' + logntilp5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp5.out' + logntilp6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp6.out' + logntilp7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp7.out' + logntilp8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp8.out' + logntilp9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp9.out' + logntilp10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/logntilp10.out' + + lwkcomp0_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp0.out' + lwkcomp1_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp1.out' + lwkcomp2_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp2.out' + lwkcomp3_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp3.out' + lwkcomp4_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp4.out' + lwkcomp5_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp5.out' + lwkcomp6_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp6.out' + lwkcomp7_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp7.out' + lwkcomp8_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp8.out' + lwkcomp9_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp9.out' + lwkcomp10_file='$DIN_LOC_ROOT/noresm-only/atm/cam/camoslo/AeroTab_8jun17/lwkcomp10.out' run_component_cam diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index d89318f38e..615741931d 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -17,7 +17,7 @@ LND = [CLM45, CLM50, SLND] ICE = [CICE, DICE, SICE] OCN = [DOCN, ,AQUAP, SOCN] - ROF = [RTM, SROF] + ROF = [RTM, MOSART, SROF] GLC = [CISM1, CISM2, SGLC] WAV = [SWAV] BGC = optional BGC scenario @@ -32,6 +32,7 @@ - lname - alias - support (optional description of the support level for this compset) + Each compset node can also have the following attributes - grid (optional regular expression match for grid to work with the compset) @@ -42,111 +43,95 @@ F2000climo - 2000_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + 2000_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FHIST - HIST_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + HIST_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FHIST_BGC - HIST_CAM60_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + HIST_CAM60_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850 - 1850_CAM60%PTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + 1850_CAM60%NORESM_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV NFHIST - HIST_CAM60%PTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - + HIST_CAM60%NORESM_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV NFHISTfsst HIST_CAM60%NORESM%FSST_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTfsstfrc2 HIST_CAM60%NORESM%FSST%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorpddmsbc HIST_CAM60%NORESM%NORPDDMSBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - - NFHISTnorpddmsbcsdyn HIST_CAM60%NORESM%NORPDDMSBC%SDYN_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTfrc2norpddmsbc HIST_CAM60%NORESM%NORPDDMSBC%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - - @@ -261,11 +246,10 @@ NF2000climo - 2000_CAM60%PTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - + 2000_CAM60%NORESM_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - + NF1850norbc 1850_CAM60%NORESM%NORBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV @@ -451,15 +435,11 @@ QPC6 2000_CAM60_SLND_SICE_DOCN%AQP3_SROF_SGLC_SWAV - - QSC6 2000_CAM60_SLND_SICE_DOCN%SOMAQP_SROF_SGLC_SWAV - - @@ -468,32 +448,22 @@ F2010climo - 2010_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + 2010_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV F1850 - 1850_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - - - - FSPCAMM - 2000_CAM%SPCAMM_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - - FSPCAMS - 2000_CAM%SPCAMS_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV + 1850_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV F1850_BDRD - 1850_CAM60_CLM50%BGC_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV_BGC%BDRD + 1850_CAM60_CLM50%BGC_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV_BGC%BDRD FHIST_BDRD - HIST_CAM60_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV_BGC%BDRD + HIST_CAM60_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV_BGC%BDRD @@ -504,6 +474,7 @@ + FHIST_DARTC6 HIST_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV @@ -539,42 +510,29 @@ - - - - FSPCAMCLBS - 2000_CAM%SPCAMCLBS_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - - FSPCAMCLBM - 2000_CAM%SPCAMCLBM_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - FC2000climo - 2000_CAM60%CCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + 2000_CAM60%CCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FC2010climo - 2010_CAM60%CCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + 2010_CAM60%CCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FCHIST - HIST_CAM60%CCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + HIST_CAM60%CCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FCvbsxHIST - HIST_CAM60%CVBSX_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + HIST_CAM60%CVBSX_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FCfireHIST - HIST_CAM60%CFIRE_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + HIST_CAM60%CFIRE_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV @@ -616,81 +574,46 @@ QSC6O - 2000_CAM60%PTAERO_SLND_SICE_DOCN%SOMAQP_SROF_SGLC_SWAV - - - - NFPTAERO - 2000_CAM5%PTAEROUPD1_CLM40%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - NFPTAERO60 - - 2000_CAM60%PTAERO_CLM50%BGC_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + 2000_CAM60%NORESM_SLND_SICE_DOCN%SOMAQP_SROF_SGLC_SWAV - - NFPTAERO60NC - 2000_CAM54%PTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - NFAMIPNUDGEPTAEROUPD1 - 2000_CAM5%NUDGEPTAEROUPD1_CLM45%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - NFAMIPNUDGEPTAERONCLB - 2000_CAM54%NUDGEPTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - NFAMIPNUDGEPTAEROCLB - 2000_CAM60%NUDGEPTAERO_CLM50%SP_CICE%PRES_DOCN%DOM_RTM_SGLC_SWAV - - - - - + + FWHIST - HIST_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + HIST_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FWHIST_BGC - HIST_CAM60%WCTS_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + HIST_CAM60%WCTS_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FWsc2010climo - 2010_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + 2010_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FWsc2000climo - 2000_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + 2000_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FWsc1850 - 1850_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + 1850_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FWscHIST - HIST_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + HIST_CAM60%WCSC_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FW1850 - 1850_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV - + 1850_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV @@ -699,12 +622,12 @@ FW2000climo - 2000_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + 2000_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV FW2010climo - 2010_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + 2010_CAM60%WCTS_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV @@ -719,7 +642,7 @@ FWmaHIST - HIST_CAM60%WCCM_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + HIST_CAM60%WCCM_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV @@ -729,7 +652,7 @@ FWmadHIST - HIST_CAM60%WCMD_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_CISM2%NOEVOLVE_SWAV + HIST_CAM60%WCMD_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV @@ -779,75 +702,29 @@ - - - domain.lnd.fv0.9x1.25_tnx1v4.170609.nc - domain.lnd.fv1.9x2.5_tnx1v4.170609.nc - domain.lnd.fv0.9x1.25_tnx1v4.170609.nc - domain.lnd.fv1.9x2.5_tnx1v4.170609.nc - - - - - - domain.lnd.fv0.9x1.25_tnx1v4.170609.nc - domain.lnd.fv1.9x2.5_tnx1v4.170609.nc - domain.lnd.fv0.9x1.25_tnx1v4.170609.nc - domain.lnd.fv1.9x2.5_tnx1v4.170609.nc - - - - - - domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc - domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc - domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc - domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc - - - - - - domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc - domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc - domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc - domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc - - - - - - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc - - - - 1997-06-18 - 1979-01-01 - 2000-01-01 - 1979-01-01 - 1950-01-01 - 1995-01-01 - 1995-01-01 - 1995-01-01 - 2005-01-01 - 2015-01-01 - 2005-01-01 - 2010-01-01 - 2000-01-01 - - 2004-01-01 - 1950-01-01 + 1997-06-18 + 1979-01-01 + 2000-01-01 + 1979-01-01 + 1950-01-01 + 1995-01-01 + 1995-01-01 + 1995-01-01 + 2005-01-01 + 2015-01-01 + 2005-01-01 + 2010-01-01 + 2000-01-01 + 2004-01-01 + 1950-01-01 - 84585 + 84585 @@ -867,229 +744,143 @@ - GREGORIAN - GREGORIAN - + GREGORIAN + GREGORIAN + + - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_clim_c050526.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_clim_c061031.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_c040926.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_clim_c061106.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_clim_c110526.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/"sst_HadOIBl_bc_48x96_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_1850_2017_c180507.nc - - - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_NHIST_f19_tn14_20190625_1849-2015_series_version20190726_ts.nc - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_NSSP370frc2_f19_tn14_20191014_2014-2101_series_version20200109_ts.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_clim_pi_c101029.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_clim_pi_c101028.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_clim_pi_c101028.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_pi_c101028.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_clim_pi_c101028.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_clim_pi_c101028.nc - + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_clim_c050526.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_clim_c061031.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_c040926.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_clim_c061106.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_clim_c110526.nc + + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_1850_2017_c180507.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_1850_2017_c180507.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_1850_2017_c180507.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_1850_2017_c180507.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_1850_2017_c180507.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_1850_2017_c180507.nc + + + $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_NHIST_f19_tn14_20190625_1849-2015_series_version20190726_ts.nc + $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_NSSP370frc2_f19_tn14_20191014_2014-2101_series_version20200109_ts.nc + + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_clim_pi_c101029.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_clim_pi_c101028.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_clim_pi_c101028.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_pi_c101028.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_clim_pi_c101028.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_clim_pi_c101028.nc + - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850frc2_f09_tn14_20191012_1351-1380_series_version20200106_clim.nc - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850_f19_tn14_20190621_1751-1780_series_version20190726_clim.nc - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850frc2_f09_tn14_20191012_1351-1380_series_version20200106_clim.nc - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850_f19_tn14_20190621_1751-1780_series_version20190726_clim.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_2000climo_c180511.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_c040926.nc - $DIN_LOC_ROOT/atm/cam/sst/f2000.waccm-mam3_1.9x2.5_L70.cam2.i.0017-01-01.c120410.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_2010climo_c180511.nc + $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850frc2_f09_tn14_20191012_1351-1380_series_version20200106_clim.nc + $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850_f19_tn14_20190621_1751-1780_series_version20190726_clim.nc + $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850frc2_f09_tn14_20191012_1351-1380_series_version20200106_clim.nc + $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850_f19_tn14_20190621_1751-1780_series_version20190726_clim.nc + + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_2000climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_2000climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_2000climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_2000climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_2000climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_2000climo_c180511.nc + + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_c040926.nc + $DIN_LOC_ROOT/atm/cam/sst/f2000.waccm-mam3_1.9x2.5_L70.cam2.i.0017-01-01.c120410.nc + + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_2010climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_2010climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_2010climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_2010climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_2010climo_c180511.nc + $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_2010climo_c180511.nc - + - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.48x96_gx3v7_100114.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.1.9x2.5_gx1v6_090403.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.9x1.25_gx1v6_090403.nc - $DIN_LOC_ROOT/share/domains/domain.ocn.fv0.9x1.25_gx1v7.151020.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.47x0.63_gx1v6_090408.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.23x0.31_gx1v6_101108.nc - $DIN_LOC_ROOT/ocn/docn7/domain.ocn.1x1.111007.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.48x96_gx3v7_100114.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.1.9x2.5_gx1v6_090403.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.9x1.25_gx1v6_090403.nc - $DIN_LOC_ROOT/share/domains/domain.ocn.fv0.9x1.25_gx1v7.151020.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.47x0.63_gx1v6_090408.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.23x0.31_gx1v6_101108.nc - $DIN_LOC_ROOT/ocn/docn7/domain.ocn.1x1.111007.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.48x96_gx3v7_100114.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.1.9x2.5_gx1v6_090403.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.9x1.25_gx1v6_090403.nc - $DIN_LOC_ROOT/share/domains/domain.ocn.fv0.9x1.25_gx1v7.151020.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.47x0.63_gx1v6_090408.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.23x0.31_gx1v6_101108.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.48x96_gx3v7_100114.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.1.9x2.5_gx1v6_090403.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.9x1.25_gx1v6_090403.nc + $DIN_LOC_ROOT/share/domains/domain.ocn.fv0.9x1.25_gx1v7.151020.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.47x0.63_gx1v6_090408.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.23x0.31_gx1v6_101108.nc + $DIN_LOC_ROOT/ocn/docn7/domain.ocn.1x1.111007.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.48x96_gx3v7_100114.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.1.9x2.5_gx1v6_090403.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.9x1.25_gx1v6_090403.nc + $DIN_LOC_ROOT/share/domains/domain.ocn.fv0.9x1.25_gx1v7.151020.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.47x0.63_gx1v6_090408.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.23x0.31_gx1v6_101108.nc + $DIN_LOC_ROOT/ocn/docn7/domain.ocn.1x1.111007.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.48x96_gx3v7_100114.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.1.9x2.5_gx1v6_090403.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.9x1.25_gx1v6_090403.nc + $DIN_LOC_ROOT/share/domains/domain.ocn.fv0.9x1.25_gx1v7.151020.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.47x0.63_gx1v6_090408.nc + $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.23x0.31_gx1v6_101108.nc + 0 - 2016 + 2016 - hybrid - hybrid - hybrid - hybrid - hybrid - - hybrid - hybrid - hybrid + hybrid + hybrid - b.e20.BHIST.f09_g17.20thC.297_01_v2 - b.e20.BHIST.f09_g17.20thC.297_01_v2 - b.e20.BHIST.f09_g17.20thC.297_01_v2 - b.e16.B1850_WW3.f09_g16.lang_redi_2hr_frz_chl.003 - b.e20.B1850.f09_g16.pi_control.all.123 - - b.e16.B1850_WW3.f09_g16.lang_redi_2hr_frz_chl.003 - b.e20.B1850.f09_g16.pi_control.all.123 - b.e21.BWHIST.f09_g17.CMIP6-historical-WACCM.001 + b.e20.BHIST.f09_g17.20thC.297_01_v2 + b.e16.B1850_WW3.f09_g16.lang_redi_2hr_frz_chl.003 - 1979-01-01 - 2000-01-01 - 2000-01-01 - 0097-01-01 - 0010-01-01 - 0097-01-01 - 0010-01-01 - 1950-01-01 + 2000-01-01 + 0097-01-01 - cesm2_init - cesm2_init - cesm2_init - cesm2_init - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 - - - - - - 1 - 1 + cesm2_init + cesm2_init - + - TRUE + TRUE - 36.6 + 36.6 - 262.5 + 262.5 diff --git a/cime_config/config_pes.xml b/cime_config/config_pes.xml index ce3b1c6110..ce99d8da17 100644 --- a/cime_config/config_pes.xml +++ b/cime_config/config_pes.xml @@ -5,849 +5,255 @@ - none - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - none - - -1 - -1 - -1 - -1 - -1 - -1 - -1 - -1 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + + + + none + + -1 + -1 + -1 + -1 + -1 + -1 + -1 + -1 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - -4 - -4 - -4 - -4 - -4 - -4 - -4 - -4 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - -4 - -4 - -4 - -4 - -4 - -4 - -4 - -4 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - -40 - -40 - -40 - -40 - -40 - -40 - -40 - -40 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - -40 - -40 - -40 - -40 - -40 - -40 - -40 - -40 - - - 4 - 4 - 4 - 4 - 4 - 4 - 4 - 4 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 2048 - 2048 - 2048 - 2048 - 2048 - 2048 - 2048 - 2048 - - - 8 - 8 - 8 - 8 - 8 - 8 - 8 - 8 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - 16 - 32 - none - - 630 - 630 - 630 - 630 - 630 - 630 - 630 - 630 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + -4 + -4 + -4 + -4 + -4 + -4 + -4 + -4 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - - - 16 - 32 - none - - 900 - 900 - 900 - 900 - 900 - 900 - 900 - 900 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - none - - 1800 - 1800 - 1800 - 1800 - 1800 - 1800 - 1800 - 1800 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - none - - 1200 - 1200 - 1200 - 1200 - 1200 - 1200 - 1200 - 1200 - - - 3 - 3 - 3 - 3 - 3 - 3 - 3 - 3 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + 1200 + 1200 + 1200 + 1200 + 1200 + 1200 + 1200 + 1200 + + + 3 + 3 + 3 + 3 + 3 + 3 + 3 + 3 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - -16 - -16 - -16 - -16 - -16 - -16 - -16 - -16 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 4800 - 4800 - 4800 - 4800 - 4800 - 4800 - 4800 - 4800 - - - 4 - 4 - 4 - 4 - 4 - 4 - 4 - 4 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 4800 - 4800 - 4800 - 4800 - 4800 - 4800 - 4800 - 4800 - - - 4 - 4 - 4 - 4 - 4 - 4 - 4 - 4 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 16384 - 16384 - 16384 - 16384 - 16384 - 16384 - 16384 - 16384 - - - 8 - 8 - 8 - 8 - 8 - 8 - 8 - 8 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 8192 - 8192 - 8192 - 8192 - 8192 - 8192 - 8192 - 8192 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - 16 - 32 - none - - 7680 - 3040 - 3040 - 3840 - 7680 - 7680 - 7680 - 7680 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 3040 - 0 - 0 - 0 - 0 - + none + + -16 + -16 + -16 + -16 + -16 + -16 + -16 + -16 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - -32 - -32 - -32 - -32 - -32 - -32 - -32 - -32 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - 32 - 32 - none - - -1 - -1 - -1 - -1 - -1 - -1 - -1 - -1 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 12 - 12 - 12 - 12 - 12 - 12 - 12 - 12 - - - 4 - 4 - 4 - 4 - 4 - 4 - 4 - 4 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 64 - 64 - 64 - 64 - 64 - 64 - 64 - 64 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + -32 + -32 + -32 + -32 + -32 + -32 + -32 + -32 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - -2 - -2 - -2 - -2 - -2 - -2 - -2 - -2 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 96 - 96 - 96 - 96 - 96 - 96 - 96 - 96 - - - 4 - 4 - 4 - 4 - 4 - 4 - 4 - 4 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + -2 + -2 + -2 + -2 + -2 + -2 + -2 + -2 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + @@ -962,154 +368,6 @@ - - - - none - - 224 - 224 - 224 - 224 - 224 - 224 - 224 - 224 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 192 - 192 - 192 - 192 - 192 - 192 - 192 - 192 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 192 - 192 - 192 - 192 - 192 - 192 - 192 - 192 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 240 - 240 - 240 - 240 - 240 - 240 - 240 - 240 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - @@ -1120,10 +378,10 @@ 360 360 360 - 360 - 360 - 360 - 360 + 360 + 360 + 360 + 360 3 @@ -1151,694 +409,365 @@ - none - - 144 - 144 - 144 - 144 - 144 - 144 - 144 - 144 - - - 3 - 3 - 3 - 3 - 3 - 3 - 3 - 3 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + 144 + 144 + 144 + 144 + 144 + 144 + 144 + 144 + + + 3 + 3 + 3 + 3 + 3 + 3 + 3 + 3 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - 288 - 288 - 288 - 288 - 288 - 288 - 288 - 288 - - - 3 - 3 - 3 - 3 - 3 - 3 - 3 - 3 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + 288 + 288 + 288 + 288 + 288 + 288 + 288 + 288 + + + 3 + 3 + 3 + 3 + 3 + 3 + 3 + 3 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - - - none - - 192 - 192 - 192 - 192 - 192 - 192 - 192 - 192 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - none - - 288 - 288 - 288 - 288 - 288 - 288 - 288 - 288 - - - 3 - 3 - 3 - 3 - 3 - 3 - 3 - 3 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + 288 + 288 + 288 + 288 + 288 + 288 + 288 + 288 + + + 3 + 3 + 3 + 3 + 3 + 3 + 3 + 3 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - - - - 16 - 32 - none - - 192 - 192 - 192 - 192 - 192 - 192 - 192 - 192 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - 16 - 32 - none - - 256 - 256 - 256 - 256 - 256 - 256 - 256 - 256 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - 16 - 32 - none - - 128 - 128 - 128 - 128 - 128 - 128 - 128 - 128 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - none - - 256 - 256 - 256 - 256 - 256 - 256 - 256 - 256 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + 256 + 256 + 256 + 256 + 256 + 256 + 256 + 256 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - -4 - -4 - -4 - -4 - -4 - -4 - -4 - -4 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + -4 + -4 + -4 + -4 + -4 + -4 + -4 + -4 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - -4 - -4 - -4 - -4 - -4 - -4 - -4 - -4 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 192 - 192 - 192 - 192 - 192 - 192 - 192 - 192 - - - 4 - 4 - 4 - 4 - 4 - 4 - 4 - 4 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - -208 - -208 - -208 - -208 - -208 - -208 - -208 - -208 - - - 8 - 8 - 8 - 8 - 8 - 8 - 8 - 8 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + -4 + -4 + -4 + -4 + -4 + -4 + -4 + -4 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - - - none - - -64 - -64 - -64 - -64 - -64 - -64 - -64 - -64 - - - 2 - 2 - 2 - 2 - 2 - 2 - 2 - 2 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - + - none - - 384 - 384 - 384 - 384 - 384 - 384 - 384 - 384 - - - 3 - 3 - 3 - 3 - 3 - 3 - 3 - 3 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + 384 + 384 + 384 + 384 + 384 + 384 + 384 + 384 + + + 3 + 3 + 3 + 3 + 3 + 3 + 3 + 3 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - -8 - -8 - -8 - -8 - -8 - -8 - -8 - -8 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + -8 + -8 + -8 + -8 + -8 + -8 + -8 + -8 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - 768 - 768 - 768 - 768 - 768 - 768 - 768 - 768 - - - 3 - 3 - 3 - 3 - 3 - 3 - 3 - 3 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 480 - 480 - 480 - 480 - 480 - 480 - 480 - 480 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + 768 + 768 + 768 + 768 + 768 + 768 + 768 + 768 + + + 3 + 3 + 3 + 3 + 3 + 3 + 3 + 3 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + - none - - -16 - -16 - -16 - -16 - -16 - -16 - -16 - -16 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - - - - - - - - none - - 960 - 960 - 960 - 960 - 960 - 960 - 960 - 960 - - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - - - 0 - 0 - 0 - 0 - 0 - 0 - 0 - 0 - + none + + -16 + -16 + -16 + -16 + -16 + -16 + -16 + -16 + + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + + + 0 + 0 + 0 + 0 + 0 + 0 + 0 + 0 + @@ -1846,16 +775,16 @@ - - 1 - 1 - 1 - 1 - 1 - 1 - 1 - 1 - + + 1 + 1 + 1 + 1 + 1 + 1 + 1 + 1 + diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 2f6161b26a..4918a3b0df 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -1,1108 +1,88 @@ - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - + + - - + - - + - - + - - - - + - - - - - - - - - - - - - - - - - + - + - - + - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - + - + - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - + - - + - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - From 8d068161cd9caf131b3d6080b8cdc3a4078c4a81 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 20 Nov 2023 12:28:40 +0100 Subject: [PATCH 66/71] removed cosp from externals --- Externals_CAM.cfg | 7 ------- 1 file changed, 7 deletions(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index 8f049753f8..fad862976c 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -5,12 +5,5 @@ repo_url = https://github.com/mvertens/OSLO_AERO.git branch = feature/oslo_aero_integrate_release required = True -[cosp2] -local_path = src/physics/cosp2/src -protocol = svn -repo_url = https://github.com/CFMIP/COSPv2.0/tags/ -tag = v2.0.3cesm/src -required = True - [externals_description] schema_version = 1.0.0 From 199858ce7cb67a9c74ff82582c3304f15261d44d Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Mon, 20 Nov 2023 19:30:20 +0100 Subject: [PATCH 67/71] pointing to new oslo_aero external --- Externals_CAM.cfg | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/Externals_CAM.cfg b/Externals_CAM.cfg index fad862976c..241b260fd5 100644 --- a/Externals_CAM.cfg +++ b/Externals_CAM.cfg @@ -2,7 +2,7 @@ local_path = src/chemistry/oslo_aero protocol = git repo_url = https://github.com/mvertens/OSLO_AERO.git -branch = feature/oslo_aero_integrate_release +branch = noresm2_3_develop required = True [externals_description] From 3cf41169f5b5efe278728746aa1d1c5a700d953b Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Wed, 3 Jan 2024 10:18:31 +0100 Subject: [PATCH 68/71] updates that are consistent with noresm2_1 branch goldy/fix_ice_delimiter_bug_fix --- bld/config_files/definition.xml | 3 + bld/configure | 11 +- cime_config/buildcpp | 5 + cime_config/config_component.xml | 8 + cime_config/config_compsets.xml | 283 +- cime_config/testdefs/testlist_cam.xml | 8 + .../testmods_dirs/cam/aerocom/shell_commands | 3 + .../testmods_dirs/cam/aerocom/user_nl_cam | 5 + .../testmods_dirs/cam/aerocom/user_nl_clm | 27 + .../src.cam/preprocessorDefinitions.h | 2 - .../src.cam/preprocessorDefinitions.h | 2 - .../src.cam/preprocessorDefinitions.h | 2 - src/NorESM/cam_diagnostics.F90 | 292 +- src/NorESM/micro_mg2_0.F90 | 73 +- src/NorESM/zm_conv_intr.F90 | 177 +- src/physics/cam/cam_diagnostics.F90 | 61 +- src/physics/cam/convect_shallow.F90 | 120 +- src/physics/cam/ndrop_bam.F90 | 18 +- src/physics/cam/physpkg.F90 | 6 +- src/physics/cam/physpkg.F90.beta07 | 2351 ----------------- src/physics/cam/vertical_diffusion.F90 | 21 +- src/physics/spcam/spcam_drivers.F90 | 2 +- src/physics/waccm/mo_aurora.F90 | 60 +- 23 files changed, 548 insertions(+), 2992 deletions(-) create mode 100644 cime_config/testdefs/testmods_dirs/cam/aerocom/shell_commands create mode 100644 cime_config/testdefs/testmods_dirs/cam/aerocom/user_nl_cam create mode 100644 cime_config/testdefs/testmods_dirs/cam/aerocom/user_nl_clm delete mode 100755 cime_config/usermods_dirs/cmip6_noresm/SourceMods/src.cam/preprocessorDefinitions.h delete mode 100755 cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/SourceMods/src.cam/preprocessorDefinitions.h delete mode 100755 cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/SourceMods/src.cam/preprocessorDefinitions.h delete mode 100644 src/physics/cam/physpkg.F90.beta07 diff --git a/bld/config_files/definition.xml b/bld/config_files/definition.xml index f7ad495271..b11d767f18 100644 --- a/bld/config_files/definition.xml +++ b/bld/config_files/definition.xml @@ -310,5 +310,8 @@ SPCAM horizontal grid spacing, m SPCAM time step, s + +Turns on aerocom + diff --git a/bld/configure b/bld/configure index 97b6fa37ec..6447ecb64a 100755 --- a/bld/configure +++ b/bld/configure @@ -110,6 +110,7 @@ OPTIONS Options used to determine the CAM model configuration. These options will have an effect whether running CAM as part of CCSM or running in a CAM standalone mode: + -aerocom Enable AEROCOM cpp-def for OSLO_AERO -[no]age_of_air_trcs Switch on [off] age of air tracers. Default: on for waccm_phys, otherwise off. -analytic_ic Enables the (namelist controlled) dycore testing infrastructure -aquaplanet Switch on aqua-planet mode. @@ -290,6 +291,7 @@ my %opts = ( cache => "config_cache.xml", ); GetOptions( + "aerocom!" => \$opts{'aerocom'}, "age_of_air_trcs!" => \$opts{'age_of_air_trcs'}, "analytic_ic" => \$opts{'analytic_ic'}, "aquaplanet" => \$opts{'aquaplanet'}, @@ -1437,7 +1439,6 @@ if ($chem_pkg =~ '_mam3') { } if ($chem_pkg =~ '_oslo') { - #$chem_cppdefs = ' -DOSLO_AERO -DAEROCOM' $chem_cppdefs = ' -DOSLO_AERO' } @@ -1974,6 +1975,14 @@ if ($clubb_sgs == 1) { $cfg_cppdefs .= " -DCLUBB_REAL_TYPE=dp"; } +# Turn on aerocom +my $aerocom_opt = (defined $opts{'aerocom'}) ? 1 : 0; +$cfg_ref->set('aerocom', $aerocom_opt); +my $aerocom = $cfg_ref->get('aerocom'); +if ($aerocom eq 1) { + $cfg_cppdefs .= ' -DAEROCOM'; +} + # UNICON if ($unicon) { $cfg_cppdefs .= ' -DUSE_UNICON'; } diff --git a/cime_config/buildcpp b/cime_config/buildcpp index 6fe4700825..4738a3ff70 100644 --- a/cime_config/buildcpp +++ b/cime_config/buildcpp @@ -40,6 +40,7 @@ def buildcpp(case): compiler = case.get_value("COMPILER") # for chem preprocessor nthrds_atm = case.get_value("NTHRDS_ATM") cam_config_opts = case.get_value("CAM_CONFIG_OPTS") + cam_aerocom = case.get_value("CAM_AEROCOM") # level information for CAM is part of the atm grid name - and must be stripped out nlev = '' @@ -99,6 +100,10 @@ def buildcpp(case): if "-cosp" in config_opts: config_opts += ["-cosp_libdir", os.path.join(exeroot, "atm", "obj", "cosp")] + print(f"cam_aerocom is {cam_aerocom}") + if cam_aerocom: + config_opts += [" -aerocom"] + camconf = os.path.join(caseroot, "Buildconf", "camconf") if not os.path.isdir(camconf): os.makedirs(camconf) diff --git a/cime_config/config_component.xml b/cime_config/config_component.xml index b78f418f36..62172b9226 100644 --- a/cime_config/config_component.xml +++ b/cime_config/config_component.xml @@ -105,6 +105,14 @@ CAM dynamical core + + logical + FALSE + build_component_cam + env_build.xml + If true, turn on aerocom diagnostics for oslo-aerosol package + + char diff --git a/cime_config/config_compsets.xml b/cime_config/config_compsets.xml index 615741931d..fab2d27a81 100644 --- a/cime_config/config_compsets.xml +++ b/cime_config/config_compsets.xml @@ -29,16 +29,15 @@ ALL data models must have a %phys option that corresponds to the data model mode Each compset node is associated with the following elements - - lname - - alias - - support (optional description of the support level for this compset) - + - lname + - alias + - support (optional description of the support level for this compset) Each compset node can also have the following attributes - - grid (optional regular expression match for grid to work with the compset) + - grid (optional regular expression match for grid to work with the compset) - + @@ -56,48 +55,50 @@ HIST_CAM60_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV + - - +(1) CAM60%NORESM versus CAM60%PTAERO : +CAM60%NORESM : the compsets used and created for CMIP6 use "NORESM" to activate typically NorESM2 settings +CAM60%PTAERO : older compsets use "PTAERO" to activate typically NorESM2 settings + +(2) presence of frc2 (FRC2) in the compset name : +WITHOUT "frc2" in name : uses multiple emission files per species (leads on fram HPC to irreprudicibility for fully-coupled compsets) +WITH "frc2" in name : uses sligthly differently organized emission files +- these emissions are very similar to "WITHOUT frc2" +- they avoid the non-reproducibility issue on the fram HPC for fully-coupled simulations + +In the fully-coupled simulations most CMIP6 experiments have been run in the following way (as a general rule) : +(i) f09 resolution : all simulations have been done WITH frc2. +(ii) f19 resolution : +piControl + historical + perturbed historical (hist-aer, hist-GHG, hist-nat) have been done WITHOUT frc2 +scenarios + perturbed scenarios : have been done WITH frc2 + +Therefore, to have the best correspondence between atmosphere-only and fully-coupled simulations : +some atmosphere-only compsets use FRC2, whereas others do not. + + +(3) norbc, norpibc, norpddmsbc : refers to the type of boundary condtions used for SST, sea-ice cover, and upper-ocean DMS concentration +norbc [ nor (NorESM) derived bc (boundary conditions) ] : +boundary conditions are derived from a fully-coupled NorESM2 simulation (e.g., N1850 or NHIST) +boundary conditions follow the "corresponding" fully coupled equivalent +(e.g., NFHISTnorbc will use bc from NHIST, NF1850norbc will use bc from N1850) +norpibc [ nor (NorESM) derived pi (pre-industrial) bc (boundary condtions) ] : +boundary conditions are derived from a fully-coupled pre-industrial NorESM2 simulation (N1850). +you impose explicitly that the "pre-industrial" boundary conditions are used : e.g., NFHISTnorpibc uses bc from N1850 +norpddmsbc [ nor (NorESM) derived pd (present-day) dms (DMS) bc (boundary conditions) ] : +only DMS boundary conditions come from a fully-coupled NorESM2 simulation +SST and sea-ice boundary conditions com from standard observation-based data set + +(4) grids +f09_f09 and f19_f19 : +When using NorESM-derived boundary conditions, we have opted to use the same land-sea mask (mtn14) + + --> + + NF1850 1850_CAM60%NORESM_CLM50%SP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV @@ -138,110 +139,92 @@ NFHISTnorbc HIST_CAM60%NORESM%NORBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorbc_pintcf HIST_CAM60%NORESM%NORBC%PINTCF_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorbc_piaer HIST_CAM60%NORESM%NORBC%PIAER_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorpibc HIST_CAM60%NORESM%NORPIBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorpibc_ghgonly 1850_CAM60%NORESM%NORPIBC%GHGONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorpibc_natonly 1850_CAM60%NORESM%NORPIBC%NATONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorpibc_aeroxidonly 1850_CAM60%NORESM%NORPIBC%AEROXIDONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorpibc_aeronly 1850_CAM60%NORESM%NORPIBC%AERONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorpibc_oxidonly 1850_CAM60%NORESM%NORPIBC%OXIDONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorpibc_ozoneonly 1850_CAM60%NORESM%NORPIBC%OZONEONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFHISTnorpibc_luonly 1850_CAM60%NORESM%NORPIBC%LUONLY_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFSSP370frc2norbc SSP370_CAM60%NORESM%NORBC%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFSSP370frc2norbc_aerlow SSP370_CAM60%NORESM%NORBC%AERLOW%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFSSP245frc2norpibc SSP245_CAM60%NORESM%NORPIBC%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFSSP245frc2norpibc_ghgonly SSP245_CAM60%NORESM%NORPIBC%GHGONLY%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFSSP245frc2norpibc_natonly SSP245_CAM60%NORESM%NORPIBC%NATONLY%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFSSP245frc2norpibc_aeronly SSP245_CAM60%NORESM%NORPIBC%AERONLY%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NFSSP245frc2norpibc_aeroxidonly SSP245_CAM60%NORESM%NORPIBC%AEROXIDONLY%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - @@ -253,157 +236,131 @@ NF1850norbc 1850_CAM60%NORESM%NORBC_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850frc2norbc 1850_CAM60%NORESM%NORBC%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_4xco2 1850_CAM60%NORESM%NORBC%4xCO2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850frc2norbc_4xco2 1850_CAM60%NORESM%NORBC%FRC2%4xCO2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_2xco2 1850_CAM60%NORESM%NORBC%2xCO2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_ghg2014 1850_CAM60%NORESM%NORBC%GHG2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_ghgnoh2o2014 1850_CAM60%NORESM%NORBC%GHGNOH2O2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_co22014 1850_CAM60%NORESM%NORBC%CO22014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_n2o2014 1850_CAM60%NORESM%NORBC%N2O2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_ch42014 1850_CAM60%NORESM%NORBC%CH42014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_ch4noh2o2014 1850_CAM60%NORESM%NORBC%CH4NOH2O2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_bc2014 1850_CAM60%NORESM%NORBC%BC2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_oc2014 1850_CAM60%NORESM%NORBC%OC2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_so22014 1850_CAM60%NORESM%NORBC%SO22014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_aer2014 1850_CAM60%NORESM%NORBC%AER2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850frc2norbc_aer2014 1850_CAM60%NORESM%NORBC%AER2014%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_aeroxid2014 1850_CAM60%NORESM%NORBC%AEROXID2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850frc2norbc_aeroxid2014 1850_CAM60%NORESM%NORBC%AEROXID2014%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_ntcf2014 1850_CAM60%NORESM%NORBC%NTCF2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_anthro2014 1850_CAM60%NORESM%NORBC%ANTHRO2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_ghgozonelu2014 1850_CAM60%NORESM%NORBC%GHGOZONELU2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_so2oxid2014 1850_CAM60%NORESM%NORBC%SO2OXID2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_ozone2014 1850_CAM60%NORESM%NORBC%OZONE2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_h2o2014 1850_CAM60%NORESM%NORBC%H2O2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850norbc_oxid2014 1850_CAM60%NORESM%NORBC%OXID2014_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - NF1850frc2norbc_oxid2014 1850_CAM60%NORESM%NORBC%OXID2014%FRC2_CLM50%BGC-CROP_CICE%PRES_DOCN%DOM_MOSART_SGLC_SWAV - @@ -411,23 +368,16 @@ FDABIP04 2000_CAM%DABIP04_SLND_SICE_SOCN_SROF_SGLC_SWAV - - - FSCAM 2000_CAM60%SCAM_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV - FHS94 2000_CAM%HS94_SLND_SICE_SOCN_SROF_SGLC_SWAV - - - @@ -474,7 +424,6 @@ - FHIST_DARTC6 HIST_CAM60_CLM50%SP_CICE%PRES_DOCN%DOM_SROF_SGLC_SWAV @@ -704,135 +653,27 @@ - 1997-06-18 - 1979-01-01 + 1997-06-18 + 1979-01-01 2000-01-01 - 1979-01-01 - 1950-01-01 - 1995-01-01 - 1995-01-01 - 1995-01-01 - 2005-01-01 + 1979-01-01 + 1950-01-01 + 1995-01-01 + 1995-01-01 + 1995-01-01 + 2005-01-01 2015-01-01 - 2005-01-01 - 2010-01-01 - 2000-01-01 - 2004-01-01 - 1950-01-01 + 2005-01-01 + 2010-01-01 + 2000-01-01 + 2004-01-01 + 1950-01-01 - 84585 - - - - - - - 288 - - - - - - TRUE - - - - - - - GREGORIAN - GREGORIAN - - - - - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_clim_c050526.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_clim_c061031.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_c040926.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_clim_c061106.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_clim_c110526.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_1850_2017_c180507.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_1850_2017_c180507.nc - - - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_NHIST_f19_tn14_20190625_1849-2015_series_version20190726_ts.nc - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_NSSP370frc2_f19_tn14_20191014_2014-2101_series_version20200109_ts.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_clim_pi_c101029.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_clim_pi_c101028.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_clim_pi_c101028.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_pi_c101028.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_clim_pi_c101028.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_clim_pi_c101028.nc - - - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850frc2_f09_tn14_20191012_1351-1380_series_version20200106_clim.nc - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850_f19_tn14_20190621_1751-1780_series_version20190726_clim.nc - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850frc2_f09_tn14_20191012_1351-1380_series_version20200106_clim.nc - $DIN_LOC_ROOT/noresm-only/atm/cam/sst/fice-micom-divocn_sst-micom-dow_N1850_f19_tn14_20190621_1751-1780_series_version20190726_clim.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_2000climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_2000climo_c180511.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_clim_c040926.nc - $DIN_LOC_ROOT/atm/cam/sst/f2000.waccm-mam3_1.9x2.5_L70.cam2.i.0017-01-01.c120410.nc - - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1x1_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_48x96_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_1.9x2.5_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.9x1.25_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.47x0.63_2010climo_c180511.nc - $DIN_LOC_ROOT/atm/cam/sst/sst_HadOIBl_bc_0.23x0.31_2010climo_c180511.nc - - - - - - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv0.9x1.25_tnx1v4.170609_djlo.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.ocn.fv1.9x2.5_tnx1v4.170609_djlo.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.48x96_gx3v7_100114.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.1.9x2.5_gx1v6_090403.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.9x1.25_gx1v6_090403.nc - $DIN_LOC_ROOT/share/domains/domain.ocn.fv0.9x1.25_gx1v7.151020.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.47x0.63_gx1v6_090408.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.23x0.31_gx1v6_101108.nc - $DIN_LOC_ROOT/ocn/docn7/domain.ocn.1x1.111007.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.48x96_gx3v7_100114.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.1.9x2.5_gx1v6_090403.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.9x1.25_gx1v6_090403.nc - $DIN_LOC_ROOT/share/domains/domain.ocn.fv0.9x1.25_gx1v7.151020.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.47x0.63_gx1v6_090408.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.23x0.31_gx1v6_101108.nc - $DIN_LOC_ROOT/ocn/docn7/domain.ocn.1x1.111007.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.48x96_gx3v7_100114.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.1.9x2.5_gx1v6_090403.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.9x1.25_gx1v6_090403.nc - $DIN_LOC_ROOT/share/domains/domain.ocn.fv0.9x1.25_gx1v7.151020.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.47x0.63_gx1v6_090408.nc - $DIN_LOC_ROOT/atm/cam/ocnfrac/domain.camocn.0.23x0.31_gx1v6_101108.nc - - - - - - 0 - 2016 + 84585 @@ -868,19 +709,19 @@ - TRUE + TRUE - 36.6 + 36.6 - 262.5 + 262.5 diff --git a/cime_config/testdefs/testlist_cam.xml b/cime_config/testdefs/testlist_cam.xml index 4918a3b0df..38697fd45b 100644 --- a/cime_config/testdefs/testlist_cam.xml +++ b/cime_config/testdefs/testlist_cam.xml @@ -66,6 +66,14 @@ + + + + + + + + diff --git a/cime_config/testdefs/testmods_dirs/cam/aerocom/shell_commands b/cime_config/testdefs/testmods_dirs/cam/aerocom/shell_commands new file mode 100644 index 0000000000..448f0dff8f --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/aerocom/shell_commands @@ -0,0 +1,3 @@ +./xmlchange ROF_NCPL=\$ATM_NCPL +./xmlchange GLC_NCPL=\$ATM_NCPL +./xmlchange CAM_AEROCOM=TRUE \ No newline at end of file diff --git a/cime_config/testdefs/testmods_dirs/cam/aerocom/user_nl_cam b/cime_config/testdefs/testmods_dirs/cam/aerocom/user_nl_cam new file mode 100644 index 0000000000..031b858464 --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/aerocom/user_nl_cam @@ -0,0 +1,5 @@ +mfilt=1,1,1,1,1,1 +ndens=1,1,1,1,1,1 +nhtfrq=9,9,9,9,9,9 +inithist='ENDOFRUN' +fincl2='ATMEINT:I','qv_pre_PBL:I','ql_pre_PBL:I','qi_pre_PBL:I','uten_PBL:I','vten_PBL:I','qvten_PBL:I','qlten_PBL','qiten_PBL','BC_AcondTend:I','BC_NcondTend:I','BC_AIcondTend:I','BC_AXcondTend:I','BC_NIcondTend:I','OM_AIcondTend:I','OM_NIcondTend:I','SO4_A1condTend:I','SOA_A1condTend:I','SO4_NAcondTend:I','SOA_NAcondTend:I','FSUS_DRF:I' diff --git a/cime_config/testdefs/testmods_dirs/cam/aerocom/user_nl_clm b/cime_config/testdefs/testmods_dirs/cam/aerocom/user_nl_clm new file mode 100644 index 0000000000..0d83b5367b --- /dev/null +++ b/cime_config/testdefs/testmods_dirs/cam/aerocom/user_nl_clm @@ -0,0 +1,27 @@ +!---------------------------------------------------------------------------------- +! Users should add all user specific namelist changes below in the form of +! namelist_var = new_namelist_value +! +! Include namelist variables for drv_flds_in ONLY if -megan and/or -drydep options +! are set in the CLM_NAMELIST_OPTS env variable. +! +! EXCEPTIONS: +! Set use_cndv by the compset you use and the CLM_BLDNML_OPTS -dynamic_vegetation setting +! Set use_vichydro by the compset you use and the CLM_BLDNML_OPTS -vichydro setting +! Set use_cn by the compset you use and CLM_BLDNML_OPTS -bgc setting +! Set use_crop by the compset you use and CLM_BLDNML_OPTS -crop setting +! Set spinup_state by the CLM_BLDNML_OPTS -bgc_spinup setting +! Set irrigate by the CLM_BLDNML_OPTS -irrig setting +! Set dtime with L_NCPL option +! Set fatmlndfrc with LND_DOMAIN_PATH/LND_DOMAIN_FILE options +! Set finidat with RUN_REFCASE/RUN_REFDATE/RUN_REFTOD options for hybrid or branch cases +! (includes $inst_string for multi-ensemble cases) +! Set glc_grid with CISM_GRID option +! Set glc_smb with GLC_SMB option +! Set maxpatch_glcmec with GLC_NEC option +! Set glc_do_dynglacier with GLC_TWO_WAY_COUPLING env variable +!---------------------------------------------------------------------------------- +hist_nhtfrq = 9 +hist_mfilt = 1 +hist_ndens = 1 + diff --git a/cime_config/usermods_dirs/cmip6_noresm/SourceMods/src.cam/preprocessorDefinitions.h b/cime_config/usermods_dirs/cmip6_noresm/SourceMods/src.cam/preprocessorDefinitions.h deleted file mode 100755 index 3803258bdf..0000000000 --- a/cime_config/usermods_dirs/cmip6_noresm/SourceMods/src.cam/preprocessorDefinitions.h +++ /dev/null @@ -1,2 +0,0 @@ -#define AEROCOM -#define AEROFFL diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/SourceMods/src.cam/preprocessorDefinitions.h b/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/SourceMods/src.cam/preprocessorDefinitions.h deleted file mode 100755 index 3803258bdf..0000000000 --- a/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/SourceMods/src.cam/preprocessorDefinitions.h +++ /dev/null @@ -1,2 +0,0 @@ -#define AEROCOM -#define AEROFFL diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/SourceMods/src.cam/preprocessorDefinitions.h b/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/SourceMods/src.cam/preprocessorDefinitions.h deleted file mode 100755 index 3803258bdf..0000000000 --- a/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/SourceMods/src.cam/preprocessorDefinitions.h +++ /dev/null @@ -1,2 +0,0 @@ -#define AEROCOM -#define AEROFFL diff --git a/src/NorESM/cam_diagnostics.F90 b/src/NorESM/cam_diagnostics.F90 index 15ebbab3c6..f58ca9491f 100644 --- a/src/NorESM/cam_diagnostics.F90 +++ b/src/NorESM/cam_diagnostics.F90 @@ -77,17 +77,17 @@ module cam_diagnostics ! Physics buffer indices -integer :: psl_idx = 0 -integer :: relhum_idx = 0 -integer :: qcwat_idx = 0 -integer :: tcwat_idx = 0 -integer :: lcwat_idx = 0 -integer :: cld_idx = 0 -integer :: concld_idx = 0 -integer :: tke_idx = 0 -integer :: kvm_idx = 0 -integer :: kvh_idx = 0 -integer :: cush_idx = 0 +integer :: psl_idx = 0 +integer :: relhum_idx = 0 +integer :: qcwat_idx = 0 +integer :: tcwat_idx = 0 +integer :: lcwat_idx = 0 +integer :: cld_idx = 0 +integer :: concld_idx = 0 +integer :: tke_idx = 0 +integer :: kvm_idx = 0 +integer :: kvh_idx = 0 +integer :: cush_idx = 0 integer :: t_ttend_idx = 0 integer :: prec_dp_idx = 0 @@ -171,7 +171,7 @@ subroutine diag_register() end subroutine diag_register !============================================================================== - + subroutine diag_init_dry(pbuf2d) ! Declare the history fields for which this module contains outfld calls. @@ -181,7 +181,7 @@ subroutine diag_init_dry(pbuf2d) use physics_buffer, only: pbuf_set_field use tidal_diag, only: tidal_diag_init #ifdef OSLO_AERO - use oslo_aero_share, only: nbmodes + use oslo_aero_share, only: nbmodes #endif type(physics_buffer_desc), pointer, intent(in) :: pbuf2d(:,:) @@ -317,14 +317,14 @@ subroutine diag_init_dry(pbuf2d) call addfld ('ABSVIS ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um call addfld ('AODVVOLC ',horiz_only, 'A','unitless','CMIP6 volcanic aerosol optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um call addfld ('ABSVVOLC ',horiz_only, 'A','unitless','CMIP6 volcanic aerosol absorptive optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um - call addfld ('CAODVIS ',horiz_only, 'A','unitless','Clear air aerosol optical depth') + call addfld ('CAODVIS ',horiz_only, 'A','unitless','Clear air aerosol optical depth') call addfld ('CABSVIS ',horiz_only, 'A','unitless','Clear air aerosol absorptive optical depth') call addfld ('CLDFREE ',horiz_only, 'A','unitless','Cloud free fraction wrt CAODVIS and CABSVIS') call addfld ('DAYFOC ',horiz_only, 'A','unitless','Daylight fraction') call addfld ('N_AER ',(/'lev'/), 'A', 'unitless','Aerosol number concentration') - call addfld ('SSAVIS ',(/'lev'/), 'A','unitless','Aerosol single scattering albedo in visible wavelength band') - call addfld ('ASYMMVIS',(/'lev'/), 'A','unitless','Aerosol assymetry factor in visible wavelength band') - call addfld ('EXTVIS ',(/'lev'/), 'A','1/km ','Aerosol extinction') + call addfld ('SSAVIS ',(/'lev'/), 'A','unitless','Aerosol single scattering albedo in visible wavelength band') + call addfld ('ASYMMVIS',(/'lev'/), 'A','unitless','Aerosol assymetry factor in visible wavelength band') + call addfld ('EXTVIS ',(/'lev'/), 'A','1/km ','Aerosol extinction') call addfld ('BVISVOLC ',(/'lev'/), 'A','1/km ','CMIP6 volcanic aerosol extinction at 0.442-0.625um') ! AEROFFL start @@ -344,132 +344,132 @@ subroutine diag_init_dry(pbuf2d) ! AEROFFL end if (do_aerocom) then - call addfld ('AKCXS ',horiz_only, 'A','mg/m2 ','Scheme excess aerosol mass burden') + call addfld ('AKCXS ',horiz_only, 'A','mg/m2 ','Scheme excess aerosol mass burden') call addfld ('PMTOT ',horiz_only, 'A','ug/m3 ','Aerosol PM, all sizes') call addfld ('PM25 ',horiz_only, 'A','ug/m3 ','Aerosol PM2.5') call addfld ('PM2P5 ',(/'lev'/), 'A','ug/m3 ','3D aerosol PM2.5') call addfld ('MMRPM2P5',(/'lev'/), 'A','kg/kg ','3D aerosol PM2.5 mass mixing ratio') call addfld ('MMRPM1 ',(/'lev'/), 'A','kg/kg ','3D aerosol PM1.0 mass mixing ratio') - call addfld ('MMRPM2P5_SRF',horiz_only, 'A','kg/kg ','Aerosol PM2.5 mass mixing ratio in bottom layer') + call addfld ('MMRPM2P5_SRF',horiz_only, 'A','kg/kg ','Aerosol PM2.5 mass mixing ratio in bottom layer') call addfld ('GRIDAREA',horiz_only, 'A','m2 ','Grid area for 1.9x2.5 horizontal resolution') call addfld ('DAERH2O ',horiz_only, 'A', 'mg/m2 ','Aerosol water load') call addfld ('MMR_AH2O',(/'lev'/), 'A', 'kg/kg ','Aerosol water mmr') - call addfld ('ECDRYAER',(/'lev'/), 'A', 'kg/kg ','Dry aerosol extinction at 550nm') - call addfld ('ABSDRYAE',(/'lev'/), 'A','m-1 ','Dry aerosol absorption at 550nm') - call addfld ('ECDRY440',(/'lev'/), 'A','m-1 ','Dry aerosol extinction at 440nm') - call addfld ('ABSDR440',(/'lev'/),'A','m-1 ','Dry aerosol absorption at 440nm') - call addfld ('ECDRY870',(/'lev'/),'A','m-1 ','Dry aerosol extinction at 870nm') - call addfld ('ABSDR870',(/'lev'/),'A','m-1 ','Dry aerosol absorption at 870nm') - call addfld ('ASYMMDRY',(/'lev'/),'A','unitless','Dry asymmetry factor in visible wavelength band') + call addfld ('ECDRYAER',(/'lev'/), 'A', 'kg/kg ','Dry aerosol extinction at 550nm') + call addfld ('ABSDRYAE',(/'lev'/), 'A','m-1 ','Dry aerosol absorption at 550nm') + call addfld ('ECDRY440',(/'lev'/), 'A','m-1 ','Dry aerosol extinction at 440nm') + call addfld ('ABSDR440',(/'lev'/),'A','m-1 ','Dry aerosol absorption at 440nm') + call addfld ('ECDRY870',(/'lev'/),'A','m-1 ','Dry aerosol extinction at 870nm') + call addfld ('ABSDR870',(/'lev'/),'A','m-1 ','Dry aerosol absorption at 870nm') + call addfld ('ASYMMDRY',(/'lev'/),'A','unitless','Dry asymmetry factor in visible wavelength band') call addfld ('ECDRYLT1',(/'lev'/),'A','m-1 ','Dry aerosol extinction at 550nm lt05') call addfld ('ABSDRYBC',(/'lev'/),'A','m-1 ','Dry BC absorption at 550nm') call addfld ('ABSDRYOC',(/'lev'/),'A','m-1 ','Dry OC absorption at 550nm') call addfld ('ABSDRYSU',(/'lev'/),'A','m-1 ','Dry sulfate absorption at 550nm') call addfld ('ABSDRYSS',(/'lev'/),'A','m-1 ','Dry sea-salt absorption at 550nm') call addfld ('ABSDRYDU',(/'lev'/),'A','m-1 ','Dry dust absorption at 550nm') - call addfld ('OD550DRY',horiz_only,'A','unitless','Dry aerosol optical depth at 550nm') - call addfld ('AB550DRY',horiz_only, 'A','unitless','Dry aerosol absorptive optical depth at 550nm') + call addfld ('OD550DRY',horiz_only,'A','unitless','Dry aerosol optical depth at 550nm') + call addfld ('AB550DRY',horiz_only, 'A','unitless','Dry aerosol absorptive optical depth at 550nm') call addfld ('DERLT05 ',horiz_only, 'A','um ','Effective aerosol dry radius<0.5um') - call addfld ('DERGT05 ',horiz_only, 'A','um ','Effective aerosol dry radius>0.5um') - call addfld ('DER ',horiz_only, 'A','um ','Effective aerosol dry radius') - call addfld ('DOD440 ',horiz_only, 'A', 'unitless','Aerosol optical depth at 440nm') - call addfld ('ABS440 ',horiz_only, 'A', 'unitless','Aerosol absorptive optical depth at 440nm') - call addfld ('DOD500 ',horiz_only, 'A', 'unitless','Aerosol optical depth at 500nm') - call addfld ('ABS500 ',horiz_only, 'A', 'unitless','Aerosol absorptive optical depth at 500nm') - call addfld ('DOD550 ',horiz_only, 'A','unitless','Aerosol optical depth at 550nm') - call addfld ('ABS550 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 550nm') - call addfld ('ABS550AL',horiz_only, 'A','unitless','Alt. aerosol absorptive optical depth at 550nm') - call addfld ('DOD670 ',horiz_only, 'A','unitless','Aerosol optical depth at 670nm') - call addfld ('ABS670 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 670nm') - call addfld ('DOD870 ',horiz_only, 'A','unitless','Aerosol optical depth at 870nm') - call addfld ('ABS870 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 870nm') - call addfld ('DLOAD_MI',horiz_only, 'A','mg/m2 ','mineral aerosol load') - call addfld ('DLOAD_SS',horiz_only, 'A','mg/m2 ','sea-salt aerosol load') - call addfld ('DLOAD_S4',horiz_only, 'A','mg/m2 ','sulfate aerosol load') - call addfld ('DLOAD_OC',horiz_only, 'A','mg/m2 ','OC aerosol load') - call addfld ('DLOAD_BC',horiz_only, 'A','mg/m2 ','BC aerosol load') - - call addfld ('LOADBCAC',horiz_only, 'A','mg/m2 ','BC aerosol coag load') - call addfld ('LOADBC0 ',horiz_only, 'A','mg/m2 ','BC aerosol mode 0 load') - call addfld ('LOADBC2 ',horiz_only, 'A','mg/m2 ','BC aerosol mode 2 load') - call addfld ('LOADBC4 ',horiz_only, 'A','mg/m2 ','BC aerosol mode 4 load') - call addfld ('LOADBC12',horiz_only, 'A','mg/m2 ','BC aerosol mode 12 load') - call addfld ('LOADBC14',horiz_only, 'A','mg/m2 ','BC aerosol mode 14 load') - call addfld ('LOADOCAC',horiz_only, 'A','mg/m2 ','OC aerosol coag load') - call addfld ('LOADOC3 ',horiz_only, 'A','mg/m2 ','OC aerosol mode 3 load') - call addfld ('LOADOC4 ',horiz_only, 'A','mg/m2 ','OC aerosol mode 4 load') - call addfld ('LOADOC13',horiz_only, 'A','mg/m2 ','OC aerosol mode 13 load') - call addfld ('LOADOC14',horiz_only, 'A','mg/m2 ','OC aerosol mode 14 load') + call addfld ('DERGT05 ',horiz_only, 'A','um ','Effective aerosol dry radius>0.5um') + call addfld ('DER ',horiz_only, 'A','um ','Effective aerosol dry radius') + call addfld ('DOD440 ',horiz_only, 'A', 'unitless','Aerosol optical depth at 440nm') + call addfld ('ABS440 ',horiz_only, 'A', 'unitless','Aerosol absorptive optical depth at 440nm') + call addfld ('DOD500 ',horiz_only, 'A', 'unitless','Aerosol optical depth at 500nm') + call addfld ('ABS500 ',horiz_only, 'A', 'unitless','Aerosol absorptive optical depth at 500nm') + call addfld ('DOD550 ',horiz_only, 'A','unitless','Aerosol optical depth at 550nm') + call addfld ('ABS550 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 550nm') + call addfld ('ABS550AL',horiz_only, 'A','unitless','Alt. aerosol absorptive optical depth at 550nm') + call addfld ('DOD670 ',horiz_only, 'A','unitless','Aerosol optical depth at 670nm') + call addfld ('ABS670 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 670nm') + call addfld ('DOD870 ',horiz_only, 'A','unitless','Aerosol optical depth at 870nm') + call addfld ('ABS870 ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 870nm') + call addfld ('DLOAD_MI',horiz_only, 'A','mg/m2 ','mineral aerosol load') + call addfld ('DLOAD_SS',horiz_only, 'A','mg/m2 ','sea-salt aerosol load') + call addfld ('DLOAD_S4',horiz_only, 'A','mg/m2 ','sulfate aerosol load') + call addfld ('DLOAD_OC',horiz_only, 'A','mg/m2 ','OC aerosol load') + call addfld ('DLOAD_BC',horiz_only, 'A','mg/m2 ','BC aerosol load') + + call addfld ('LOADBCAC',horiz_only, 'A','mg/m2 ','BC aerosol coag load') + call addfld ('LOADBC0 ',horiz_only, 'A','mg/m2 ','BC aerosol mode 0 load') + call addfld ('LOADBC2 ',horiz_only, 'A','mg/m2 ','BC aerosol mode 2 load') + call addfld ('LOADBC4 ',horiz_only, 'A','mg/m2 ','BC aerosol mode 4 load') + call addfld ('LOADBC12',horiz_only, 'A','mg/m2 ','BC aerosol mode 12 load') + call addfld ('LOADBC14',horiz_only, 'A','mg/m2 ','BC aerosol mode 14 load') + call addfld ('LOADOCAC',horiz_only, 'A','mg/m2 ','OC aerosol coag load') + call addfld ('LOADOC3 ',horiz_only, 'A','mg/m2 ','OC aerosol mode 3 load') + call addfld ('LOADOC4 ',horiz_only, 'A','mg/m2 ','OC aerosol mode 4 load') + call addfld ('LOADOC13',horiz_only, 'A','mg/m2 ','OC aerosol mode 13 load') + call addfld ('LOADOC14',horiz_only, 'A','mg/m2 ','OC aerosol mode 14 load') ! - call addfld ('EC550AER',(/'lev'/),'A','m-1 ','aerosol extinction coefficient') - call addfld ('ABS550_A',(/'lev'/),'A','m-1 ','aerosol absorption coefficient') - call addfld ('BS550AER',(/'lev'/),'A','m-1 sr-1','aerosol backscatter coefficient') + call addfld ('EC550AER',(/'lev'/),'A','m-1 ','aerosol extinction coefficient') + call addfld ('ABS550_A',(/'lev'/),'A','m-1 ','aerosol absorption coefficient') + call addfld ('BS550AER',(/'lev'/),'A','m-1 sr-1','aerosol backscatter coefficient') ! - call addfld ('EC550SO4',(/'lev'/),'A','m-1 ','SO4 aerosol extinction coefficient') - call addfld ('EC550BC ',(/'lev'/),'A','m-1 ','BC aerosol extinction coefficient') - call addfld ('EC550POM',(/'lev'/), 'A','m-1 ','POM aerosol extinction coefficient') - call addfld ('EC550SS ',(/'lev'/), 'A','m-1 ','SS aerosol extinction coefficient') - call addfld ('EC550DU ',(/'lev'/), 'A','m-1 ','DU aerosol extinction coefficient') + call addfld ('EC550SO4',(/'lev'/),'A','m-1 ','SO4 aerosol extinction coefficient') + call addfld ('EC550BC ',(/'lev'/),'A','m-1 ','BC aerosol extinction coefficient') + call addfld ('EC550POM',(/'lev'/), 'A','m-1 ','POM aerosol extinction coefficient') + call addfld ('EC550SS ',(/'lev'/), 'A','m-1 ','SS aerosol extinction coefficient') + call addfld ('EC550DU ',(/'lev'/), 'A','m-1 ','DU aerosol extinction coefficient') ! - call addfld ('CDOD440 ',horiz_only, 'A','unitless','Clear air Aerosol optical depth at 440nm') - call addfld ('CDOD550 ',horiz_only, 'A','unitless','Clear air Aerosol optical depth at 550nm') - call addfld ('CABS550 ',horiz_only, 'A','unitless','Clear air Aerosol abs optical depth at 550nm') - call addfld ('CABS550A ',horiz_only, 'A','unitless','Clear air Aerosol abs optical depth at 550nm') - call addfld ('CDOD870 ' ,horiz_only, 'A','unitless','Clear air Aerosol optical depth at 870nm') - call addfld ('A550_DU ' ,horiz_only, 'A','unitless', 'mineral abs. aerosol optical depth 550nm') - call addfld ('A550_SS ' ,horiz_only, 'A','unitless','sea-salt abs aerosol optical depth 550nm') - call addfld ('A550_SO4' ,horiz_only, 'A','unitless','SO4 aerosol abs. optical depth 550nm') - call addfld ('A550_POM' ,horiz_only, 'A','unitless', 'OC abs. aerosol optical depth 550nm') + call addfld ('CDOD440 ',horiz_only, 'A','unitless','Clear air Aerosol optical depth at 440nm') + call addfld ('CDOD550 ',horiz_only, 'A','unitless','Clear air Aerosol optical depth at 550nm') + call addfld ('CABS550 ',horiz_only, 'A','unitless','Clear air Aerosol abs optical depth at 550nm') + call addfld ('CABS550A ',horiz_only, 'A','unitless','Clear air Aerosol abs optical depth at 550nm') + call addfld ('CDOD870 ' ,horiz_only, 'A','unitless','Clear air Aerosol optical depth at 870nm') + call addfld ('A550_DU ' ,horiz_only, 'A','unitless', 'mineral abs. aerosol optical depth 550nm') + call addfld ('A550_SS ' ,horiz_only, 'A','unitless','sea-salt abs aerosol optical depth 550nm') + call addfld ('A550_SO4' ,horiz_only, 'A','unitless','SO4 aerosol abs. optical depth 550nm') + call addfld ('A550_POM' ,horiz_only, 'A','unitless', 'OC abs. aerosol optical depth 550nm') call addfld ('A550_BC ' ,horiz_only, 'A','unitless', 'BC abs. aerosol optical depth 550nm') - call addfld ('D440_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 440nm') - call addfld ('D440_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 440nm') - call addfld ('D440_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 440nm') - call addfld ('D440_POM',horiz_only, 'A','unitless','OC aerosol optical depth 440nm') - call addfld ('D440_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 440nm') - call addfld ('D500_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 500nm') - call addfld ('D500_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 500nm') - call addfld ('D500_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 500nm') - call addfld ('D500_POM',horiz_only, 'A','unitless','OC aerosol optical depth 500nm') - call addfld ('D500_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 500nm') - call addfld ('D550_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 550nm') - call addfld ('D550_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 550nm') - call addfld ('D550_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm') - call addfld ('D550_POM',horiz_only, 'A','unitless','OC aerosol optical depth 550nm') - call addfld ('D550_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm') - call addfld ('D670_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 670nm') - call addfld ('D670_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 670nm') - call addfld ('D670_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 670nm') - call addfld ('D670_POM',horiz_only, 'A','unitless','OC aerosol optical depth 670nm') - call addfld ('D670_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 670nm') - call addfld ('D870_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 870nm') - call addfld ('D870_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 870nm') - call addfld ('D870_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 870nm') - call addfld ('D870_POM',horiz_only, 'A','unitless','OC aerosol optical depth 870nm') - call addfld ('D870_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 870nm') - call addfld ('DLT_DUST',horiz_only, 'A','unitless','mineral aerosol optical depth 550nm lt05') - call addfld ('DLT_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 550nm lt05') - call addfld ('DLT_SO4 ',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm lt05') - call addfld ('DLT_POM ',horiz_only, 'A','unitless','OC aerosol optical depth 550nm lt05') - call addfld ('DLT_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm lt05') - call addfld ('DGT_DUST',horiz_only, 'A','unitless','mineral aerosol optical depth 550nm gt05') - call addfld ('DGT_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 550nm gt05') - call addfld ('DGT_SO4 ',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm gt05') - call addfld ('DGT_POM ',horiz_only, 'A','unitless','OC aerosol optical depth 550nm gt05') - call addfld ('DGT_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm gt05') + call addfld ('D440_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 440nm') + call addfld ('D440_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 440nm') + call addfld ('D440_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 440nm') + call addfld ('D440_POM',horiz_only, 'A','unitless','OC aerosol optical depth 440nm') + call addfld ('D440_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 440nm') + call addfld ('D500_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 500nm') + call addfld ('D500_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 500nm') + call addfld ('D500_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 500nm') + call addfld ('D500_POM',horiz_only, 'A','unitless','OC aerosol optical depth 500nm') + call addfld ('D500_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 500nm') + call addfld ('D550_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 550nm') + call addfld ('D550_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 550nm') + call addfld ('D550_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm') + call addfld ('D550_POM',horiz_only, 'A','unitless','OC aerosol optical depth 550nm') + call addfld ('D550_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm') + call addfld ('D670_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 670nm') + call addfld ('D670_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 670nm') + call addfld ('D670_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 670nm') + call addfld ('D670_POM',horiz_only, 'A','unitless','OC aerosol optical depth 670nm') + call addfld ('D670_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 670nm') + call addfld ('D870_DU ',horiz_only, 'A','unitless','mineral aerosol optical depth 870nm') + call addfld ('D870_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 870nm') + call addfld ('D870_SO4',horiz_only, 'A','unitless','SO4 aerosol optical depth 870nm') + call addfld ('D870_POM',horiz_only, 'A','unitless','OC aerosol optical depth 870nm') + call addfld ('D870_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 870nm') + call addfld ('DLT_DUST',horiz_only, 'A','unitless','mineral aerosol optical depth 550nm lt05') + call addfld ('DLT_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 550nm lt05') + call addfld ('DLT_SO4 ',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm lt05') + call addfld ('DLT_POM ',horiz_only, 'A','unitless','OC aerosol optical depth 550nm lt05') + call addfld ('DLT_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm lt05') + call addfld ('DGT_DUST',horiz_only, 'A','unitless','mineral aerosol optical depth 550nm gt05') + call addfld ('DGT_SS ',horiz_only, 'A','unitless','sea-salt aerosol optical depth 550nm gt05') + call addfld ('DGT_SO4 ',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm gt05') + call addfld ('DGT_POM ',horiz_only, 'A','unitless','OC aerosol optical depth 550nm gt05') + call addfld ('DGT_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm gt05') call addfld ('AIRMASS ',horiz_only, 'A','kg/m2 ','Vertically integrated airmass') !akc6 - call addfld ('NNAT_0 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 0 number concentration') - call addfld ('NNAT_1 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 1 number concentration') - call addfld ('NNAT_2 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 2 number concentration') - call addfld ('NNAT_4 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 4 number concentration') - call addfld ('NNAT_5 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 5 number concentration') - call addfld ('NNAT_6 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 6 number concentration') - call addfld ('NNAT_7 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 7 number concentration') - call addfld ('NNAT_8 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 8 number concentration') - call addfld ('NNAT_9 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 9 number concentration') - call addfld ('NNAT_10 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 10 number concentration') - call addfld ('NNAT_12 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 12 number concentration') - call addfld ('NNAT_14 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 14 number concentration') - call addfld ('AIRMASSL',(/'lev'/),'A','kg/m2 ','Layer airmass') + call addfld ('NNAT_0 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 0 number concentration') + call addfld ('NNAT_1 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 1 number concentration') + call addfld ('NNAT_2 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 2 number concentration') + call addfld ('NNAT_4 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 4 number concentration') + call addfld ('NNAT_5 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 5 number concentration') + call addfld ('NNAT_6 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 6 number concentration') + call addfld ('NNAT_7 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 7 number concentration') + call addfld ('NNAT_8 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 8 number concentration') + call addfld ('NNAT_9 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 9 number concentration') + call addfld ('NNAT_10 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 10 number concentration') + call addfld ('NNAT_12 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 12 number concentration') + call addfld ('NNAT_14 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 14 number concentration') + call addfld ('AIRMASSL',(/'lev'/),'A','kg/m2 ','Layer airmass') call addfld ('BETOTVIS',(/'lev'/),'A','1/km','Aerosol 3d extinction at 0.442-0.625') ! CAM4-Oslo: 0.35-0.64um call addfld ('BATOTVIS',(/'lev'/),'A','1/km','Aerosol 3d absorption at 0.442-0.625') ! CAM4-Oslo: 0.35-0.64um call addfld ('BATSW13 ',(/'lev'/),'A','1/km','Aerosol 3d SW absorption at 3.077-3.846um') @@ -481,17 +481,17 @@ subroutine diag_init_dry(pbuf2d) if(i.lt.10) modeString="0"//adjustl(modeString) varName = "Camrel"//trim(modeString) if(i.ne.3) call addfld(varName, (/'lev'/),'A','unitless', 'relative added mass for mode'//modeString) - enddo + enddo do i=1,nbmodes modeString=" " write(modeString,"(I2)"),i if(i.lt.10) modeString="0"//adjustl(modeString) varName = "Cxsrel"//trim(modeString) if(i.ne.3) call addfld(varName, horiz_only, 'A', 'unitless', 'relative exessive added mass column for mode'//modeString) - enddo + enddo #endif end if - + if (history_amwg) then call add_default ('PHIS ' , 1, ' ') call add_default ('PS ' , 1, ' ') @@ -541,7 +541,7 @@ subroutine diag_init_dry(pbuf2d) ! State after physics (FV) call add_default ('TAP ' , history_budget_histfile_num, ' ') call add_default ('UAP ' , history_budget_histfile_num, ' ') - call add_default ('VAP ' , history_budget_histfile_num, ' ') + call add_default ('VAP ' , history_budget_histfile_num, ' ') call add_default (apcnst(1) , history_budget_histfile_num, ' ') if ( dycore_is('LR') .or. dycore_is('SE') ) then call add_default ('TFIX ' , history_budget_histfile_num, ' ') @@ -788,14 +788,14 @@ subroutine diag_init_dry(pbuf2d) if(i.lt.10) modeString="0"//adjustl(modeString) varName = "Camrel"//trim(modeString) if(i.ne.3) call add_default(varName, 1, ' ') - enddo + enddo do i=1,nbmodes modeString=" " write(modeString,"(I2)"),i if(i.lt.10) modeString="0"//adjustl(modeString) varName = "Cxsrel"//trim(modeString) if(i.ne.3) call add_default(varName, 1, ' ') - enddo + enddo #endif end if @@ -939,7 +939,7 @@ subroutine diag_init_moist(pbuf2d) !AL call addfld (dmetendnam(ixcldnc),(/ 'lev' /), 'A','#/kg/s ', & trim(cnst_name(ixcldnc))//' dme adjustment tendency (FV) ') - call addfld (dmetendnam(ixcldni),(/ 'lev' /), 'A','#/kg/s ', & + call addfld (dmetendnam(ixcldni),(/ 'lev' /), 'A','#/kg/s ', & trim(cnst_name(ixcldni))//' dme adjustment tendency (FV) ') !AL end if @@ -1370,7 +1370,7 @@ subroutine diag_phys_writeout_dry(state, pbuf, p_surf_t) do m = 1, pcnst if (cnst_cam_outfld(m)) then - call outfld(cnst_name(m), state%q(1,1,m), pcols, lchnk) + call outfld(cnst_name(m), state%q(:,:,m), pcols, lchnk) end if end do @@ -1563,9 +1563,9 @@ subroutine diag_phys_writeout_dry(state, pbuf, p_surf_t) ! ! Output U, V, T, P and Z at bottom level ! - call outfld ('UBOT ', state%u(1,pver) , pcols, lchnk) - call outfld ('VBOT ', state%v(1,pver) , pcols, lchnk) - call outfld ('ZBOT ', state%zm(1,pver) , pcols, lchnk) + call outfld ('UBOT ', state%u(:,pver) , pcols, lchnk) + call outfld ('VBOT ', state%v(:,pver) , pcols, lchnk) + call outfld ('ZBOT ', state%zm(:,pver) , pcols, lchnk) !! Boundary layer atmospheric stability, temperature, water vapor diagnostics @@ -1701,13 +1701,13 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) ncol = state%ncol do m=1,pcnst if ( cnst_cam_outfld(m) ) then - call outfld(cnst_name(m),state%q(1,1,m),pcols ,lchnk ) + call outfld(cnst_name(m),state%q(:,:,m),pcols ,lchnk ) end if end do if (co2_transport()) then do m = 1,4 - call outfld(trim(cnst_name(c_i(m)))//'_BOT', state%q(1,pver,c_i(m)), pcols, lchnk) + call outfld(trim(cnst_name(c_i(m)))//'_BOT', state%q(:,pver,c_i(m)), pcols, lchnk) end do end if @@ -1772,7 +1772,7 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 call outfld ('RHW ',ftem ,pcols ,lchnk ) end if - + ! Convert to RHI (ice) do i=1,ncol do k=1,pver @@ -1813,7 +1813,7 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) ! ! Output Q at bottom level ! - call outfld ('QBOT ', state%q(1,pver,1), pcols, lchnk) + call outfld ('QBOT ', state%q(:,pver,1), pcols, lchnk) ! Total energy of the atmospheric column for atmospheric heat storage calculations @@ -1830,7 +1830,7 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) do k=2,pver ftem(:ncol,1) = ftem(:ncol,1) + ftem(:ncol,k) end do - call outfld ('ATMEINT ',ftem(:ncol,1) ,pcols ,lchnk ) + call outfld ('ATMEINT ',ftem(:ncol,1) ,ncol ,lchnk ) !! Boundary layer atmospheric stability, temperature, water vapor diagnostics @@ -2155,7 +2155,7 @@ subroutine diag_surf (cam_in, cam_out, state, pbuf) if (moist_physics) then call outfld('SHFLX', cam_in%shf, pcols, lchnk) call outfld('LHFLX', cam_in%lhf, pcols, lchnk) - call outfld('QFLX', cam_in%cflx(1,1), pcols, lchnk) + call outfld('QFLX', cam_in%cflx(:,:), pcols, lchnk) call outfld('TAUX', cam_in%wsx, pcols, lchnk) call outfld('TAUY', cam_in%wsy, pcols, lchnk) @@ -2530,16 +2530,16 @@ subroutine diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & !AL if ( cnst_cam_outfld( 1) ) then - call outfld (apcnst( 1), state%q(1,1, 1), pcols, lchnk) + call outfld (apcnst( 1), state%q(:,:, 1), pcols, lchnk) end if if (ixcldliq > 0) then if (cnst_cam_outfld(ixcldliq)) then - call outfld (apcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) + call outfld (apcnst(ixcldliq), state%q(:,:,ixcldliq), pcols, lchnk) end if end if if (ixcldice > 0) then if ( cnst_cam_outfld(ixcldice) ) then - call outfld (apcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) + call outfld (apcnst(ixcldice), state%q(:,:,ixcldice), pcols, lchnk) end if end if @@ -2711,16 +2711,16 @@ subroutine diag_state_b4_phys_write_moist (state) call cnst_get_ind('CLDICE', ixcldice, abort=.false.) if ( cnst_cam_outfld( 1) ) then - call outfld (bpcnst( 1), state%q(1,1, 1), pcols, lchnk) + call outfld (bpcnst( 1), state%q(:,:, 1), pcols, lchnk) end if if (ixcldliq > 0) then if (cnst_cam_outfld(ixcldliq)) then - call outfld (bpcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) + call outfld (bpcnst(ixcldliq), state%q(:,:,ixcldliq), pcols, lchnk) end if end if if (ixcldice > 0) then if (cnst_cam_outfld(ixcldice)) then - call outfld (bpcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) + call outfld (bpcnst(ixcldice), state%q(:,:,ixcldice), pcols, lchnk) end if end if diff --git a/src/NorESM/micro_mg2_0.F90 b/src/NorESM/micro_mg2_0.F90 index 823058308e..7e2a64d0e0 100644 --- a/src/NorESM/micro_mg2_0.F90 +++ b/src/NorESM/micro_mg2_0.F90 @@ -12,23 +12,23 @@ module micro_mg2_0 ! ! invoked in CAM by specifying -microphys=mg2.0 ! -! References: +! References: ! -! Gettelman, A. and H. Morrison, Advanced Two-Moment Microphysics for Global Models. +! Gettelman, A. and H. Morrison, Advanced Two-Moment Microphysics for Global Models. ! -! Part I: Off line tests and comparisons with other schemes. +! Part I: Off line tests and comparisons with other schemes. ! -! J. Climate, 28, 1268-1287. doi: 10.1175/JCLI-D-14-00102.1, 2015. +! J. Climate, 28, 1268-1287. doi: 10.1175/JCLI-D-14-00102.1, 2015. ! ! ! -! Gettelman, A., H. Morrison, S. Santos, P. Bogenschutz and P. H. Caldwell +! Gettelman, A., H. Morrison, S. Santos, P. Bogenschutz and P. H. Caldwell ! -! Advanced Two-Moment Microphysics for Global Models. +! Advanced Two-Moment Microphysics for Global Models. ! -! Part II: Global model solutions and Aerosol-Cloud Interactions. +! Part II: Global model solutions and Aerosol-Cloud Interactions. ! -! J. Climate, 28, 1288-1307. doi:10.1175/JCLI-D-14-00103.1 , 2015. +! J. Climate, 28, 1288-1307. doi:10.1175/JCLI-D-14-00103.1 , 2015. ! ! for questions contact Hugh Morrison, Andrew Gettelman ! e-mail: morrison@ucar.edu, andrew@ucar.edu @@ -176,8 +176,8 @@ module micro_mg2_0 ! externally (kg) real(r8), parameter :: mi0l_min = 4._r8/3._r8*pi*rhow*(4.e-6_r8)**3 -! Ice number sublimation parameter. Assume some decrease in ice number with sublimation if non-zero. Else, no decrease in number with sublimation. - real(r8), parameter :: sublim_factor =0.0_r8 !number sublimation factor. +! Ice number sublimation parameter. Assume some decrease in ice number with sublimation if non-zero. Else, no decrease in number with sublimation. + real(r8), parameter :: sublim_factor =0.0_r8 !number sublimation factor. !========================================================= @@ -403,7 +403,7 @@ subroutine micro_mg_tend ( & drout2, dsout2, & freqs, freqr, & nfice, qcrat, & - errstring, & + errstring, & !AL right names? nnuccctot, nnuccttot, npsacwstot, nsubctot, npratot, & nprc1tot, ncsedtentot, nisedtentot, nmelttot, nhomotot, & @@ -435,7 +435,7 @@ subroutine micro_mg_tend ( & use micro_mg_utils, only: & ice_deposition_sublimation, & sb2001v2_liq_autoconversion,& - sb2001v2_accre_cld_water_rain,& + sb2001v2_accre_cld_water_rain,& kk2000_liq_autoconversion, & ice_autoconversion, & immersion_freezing, & @@ -493,7 +493,7 @@ subroutine micro_mg_tend ( & ! (For example, in CAM, the last dimension is always size 4.) real(r8), intent(in) :: rndst(:,:,:) ! radius of each dust bin, for contact freezing (from microp_aero_ts) (m) real(r8), intent(in) :: nacon(:,:,:) ! number in each dust bin, for contact freezing (from microp_aero_ts) (1/m^3) - + ! output arguments real(r8), intent(out) :: qcsinksum_rate1ord(mgncol,nlev) ! 1st order rate for @@ -598,7 +598,7 @@ subroutine micro_mg_tend ( & real(r8), intent(out) :: nnuccctot(mgncol,nlev) ! immersion freezing real(r8), intent(out) :: nnuccttot(mgncol,nlev) ! contact freezing real(r8), intent(out) :: npsacwstot(mgncol,nlev) ! accr. snow - real(r8), intent(out) :: nsubctot(mgncol,nlev) ! evaporation of droplet + real(r8), intent(out) :: nsubctot(mgncol,nlev) ! evaporation of droplet real(r8), intent(out) :: npratot(mgncol,nlev) ! accretion real(r8), intent(out) :: nprc1tot(mgncol,nlev) ! autoconversion real(r8), intent(out) :: ncsedtentot(mgncol,nlev) ! nqc sedimentation tendency @@ -614,7 +614,7 @@ subroutine micro_mg_tend ( & real(r8), intent(out) :: nnudeptot(mgncol,nlev) ! deposition? real(r8), intent(out) :: npccntot(mgncol,nlev) ! droplet activation real(r8), intent(out) :: nnuccdtot(mgncol,nlev) ! ni nucleation - real(r8), intent(out) :: mnudeptot(mgncol,nlev) ! deposition (mass) + real(r8), intent(out) :: mnudeptot(mgncol,nlev) ! deposition (mass) ! real(r8), intent(out) :: nctnszmx(mgncol,nlev) ! nc tuning: maximum slope (reduction of number) real(r8), intent(out) :: nctnszmn(mgncol,nlev) ! nc tuning: minimum slope (increase of numer) @@ -774,7 +774,7 @@ subroutine micro_mg_tend ( & ! bergeron process real(r8) :: berg(mgncol,nlev) ! mass mixing ratio (cloud ice) real(r8) :: bergs(mgncol,nlev) ! mass mixing ratio (snow) - + ! fallspeeds ! number-weighted real(r8) :: uns(mgncol,nlev) ! snow @@ -1037,7 +1037,7 @@ subroutine micro_mg_tend ( & nnudeptot=0._r8 npccntot=0._r8 nnuccdtot=0._r8 - mnudeptot=0._r8 + mnudeptot=0._r8 mnuccritot=0._r8 nnuccritot=0._r8 @@ -1260,7 +1260,7 @@ subroutine micro_mg_tend ( & end if end do - end do + end do do k=1,nlev do i=1,mgncol @@ -1297,7 +1297,7 @@ subroutine micro_mg_tend ( & end if end if end do - end do + end do do k=1,nlev do i=1,mgncol @@ -1417,12 +1417,12 @@ subroutine micro_mg_tend ( & call size_dist_param_basic(mg_ice_props, qiic(:,k), niic(:,k), & lami(:,k), mgncol, n0=n0i(:,k)) - - ! Alternative autoconversion + + ! Alternative autoconversion if (do_sb_physics) then call sb2001v2_liq_autoconversion(pgam(:,k),qcic(1:mgncol,k),ncic(:,k), & - qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k), mgncol) - endif + qric(:,k),rho(:,k),relvar(:,k),prc(:,k),nprc(:,k),nprc1(:,k), mgncol) + endif !....................................................................... ! Autoconversion of cloud ice to snow @@ -1587,7 +1587,7 @@ subroutine micro_mg_tend ( & if (do_sb_physics) then call sb2001v2_accre_cld_water_rain(qcic(1:mgncol,k), ncic(:,k), qric(:,k), & - rho(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) + rho(:,k), relvar(:,k), pra(:,k), npra(:,k), mgncol) else call accrete_cloud_water_rain(microp_uniform, qric(:,k), qcic(1:mgncol,k), & ncic(:,k), relvar(:,k), accre_enhan(:,k), pra(:,k), npra(:,k), mgncol) @@ -2082,12 +2082,19 @@ subroutine micro_mg_tend ( & ! make sure that ni at advanced time step does not exceed ! maximum (existing N + source terms*dt), which is possible if mtime < deltat ! note that currently mtime = deltat + !================================================================ + !shofer--- + if (nnucct(i,k)+nnuccc(i,k)+nnudep(i,k) > 0._r8) then + nimax(i,k) = nimax(i,k)+(nnucct(i,k)+nnuccc(i,k)+nnudep(i,k))*lcldm(i,k)*deltat + end if - if (do_cldice .and. nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.nimax(i,k)) then - nitncons(i,k) = nitncons(i,k) + nitend(i,k)-max(0._r8,(nimax(i,k)-ni(i,k))/deltat) !AL + if (do_cldice .and. (nitend(i,k) > 0._r8) .and. & + (ni(i,k) + (nitend(i,k)*deltat) > nimax(i,k))) then + nitncons(i,k) = nitncons(i,k) + nitend(i,k) - max(0._r8,(nimax(i,k)-ni(i,k))/deltat) nitend(i,k)=max(0._r8,(nimax(i,k)-ni(i,k))/deltat) end if + !shofer--- end do @@ -2248,15 +2255,15 @@ subroutine micro_mg_tend ( & ! particles (blend over 18-20 um) irad = 1.5_r8 / lami(i,k) * 1e6_r8 ifrac = min(1._r8, max(0._r8, (irad - 18._r8) / 2._r8)) - + if (ifrac .lt. 1._r8) then - vtrmi(i,k) = ifrac * vtrmi(i,k) + & + vtrmi(i,k) = ifrac * vtrmi(i,k) + & (1._r8 - ifrac) * & min(ajn(i,k)*gamma_bj_plus4/(6._r8*lami(i,k)**bj), & 1.2_r8*rhof(i,k)) fi(i,k) = g*rho(i,k)*vtrmi(i,k) - fni(i,k) = ifrac * fni(i,k) + & + fni(i,k) = ifrac * fni(i,k) + & (1._r8 - ifrac) * & g*rho(i,k)* & min(ajn(i,k)*gamma_bj_plus1/lami(i,k)**bj,1.2_r8*rhof(i,k)) @@ -2824,8 +2831,8 @@ subroutine micro_mg_tend ( & tlat(i,k)=tlat(i,k)+xlf*dum*dumc(i,k)/deltat end if end if - enddo - enddo + enddo + enddo ! remove any excess over-saturation, which is possible due to non-linearity when adding ! together all microphysical processes !----------------------------------------------------------------- @@ -2867,8 +2874,8 @@ subroutine micro_mg_tend ( & qvres(i,k)=-dum tlat(i,k)=tlat(i,k)+dum*(1._r8-dum1)*xxlv+dum*dum1*xxls end if - enddo - enddo + enddo + enddo end if ! calculate effective radius for pass to radiation code diff --git a/src/NorESM/zm_conv_intr.F90 b/src/NorESM/zm_conv_intr.F90 index f070cf8a7b..8c1530cc04 100644 --- a/src/NorESM/zm_conv_intr.F90 +++ b/src/NorESM/zm_conv_intr.F90 @@ -8,7 +8,7 @@ module zm_conv_intr ! January 2010 modified by J. Kay to add COSP simulator fields to physics buffer !--------------------------------------------------------------------------------- use shr_kind_mod, only: r8=>shr_kind_r8 - use physconst, only: cpair + use physconst, only: cpair use ppgrid, only: pver, pcols, pverp, begchunk, endchunk use zm_conv, only: zm_conv_evap, zm_convr, convtran, momtran use zm_microphysics, only: zm_aero_t, zm_conv_t @@ -21,7 +21,7 @@ module zm_conv_intr use perf_mod use cam_logfile, only: iulog use constituents, only: cnst_add - + implicit none private save @@ -67,19 +67,19 @@ module zm_conv_intr real(r8) :: zmconv_ke_lnd = unset_r8 real(r8) :: zmconv_momcu = unset_r8 real(r8) :: zmconv_momcd = unset_r8 - integer :: zmconv_num_cin ! Number of negative buoyancy regions that are allowed + integer :: zmconv_num_cin ! Number of negative buoyancy regions that are allowed ! before the convection top and CAPE calculations are completed. - logical :: zmconv_org ! Parameterization for sub-grid scale convective organization for the ZM deep + logical :: zmconv_org ! Parameterization for sub-grid scale convective organization for the ZM deep ! convective scheme based on Mapes and Neale (2011) logical :: zmconv_microp = .false. ! switch for microphysics ! indices for fields in the physics buffer - integer :: cld_idx = 0 - integer :: icwmrdp_idx = 0 - integer :: rprddp_idx = 0 - integer :: fracis_idx = 0 - integer :: nevapr_dpcu_idx = 0 + integer :: cld_idx = 0 + integer :: icwmrdp_idx = 0 + integer :: rprddp_idx = 0 + integer :: fracis_idx = 0 + integer :: nevapr_dpcu_idx = 0 integer :: dgnum_idx = 0 integer :: nmodes @@ -103,38 +103,38 @@ subroutine zm_conv_register integer idx - call pbuf_add_field('ZM_MU', 'physpkg', dtype_r8, (/pcols,pver/), zm_mu_idx) - call pbuf_add_field('ZM_EU', 'physpkg', dtype_r8, (/pcols,pver/), zm_eu_idx) - call pbuf_add_field('ZM_DU', 'physpkg', dtype_r8, (/pcols,pver/), zm_du_idx) - call pbuf_add_field('ZM_MD', 'physpkg', dtype_r8, (/pcols,pver/), zm_md_idx) - call pbuf_add_field('ZM_ED', 'physpkg', dtype_r8, (/pcols,pver/), zm_ed_idx) + call pbuf_add_field('ZM_MU', 'physpkg', dtype_r8, (/pcols,pver/), zm_mu_idx) + call pbuf_add_field('ZM_EU', 'physpkg', dtype_r8, (/pcols,pver/), zm_eu_idx) + call pbuf_add_field('ZM_DU', 'physpkg', dtype_r8, (/pcols,pver/), zm_du_idx) + call pbuf_add_field('ZM_MD', 'physpkg', dtype_r8, (/pcols,pver/), zm_md_idx) + call pbuf_add_field('ZM_ED', 'physpkg', dtype_r8, (/pcols,pver/), zm_ed_idx) ! wg layer thickness in mbs (between upper/lower interface). - call pbuf_add_field('ZM_DP', 'physpkg', dtype_r8, (/pcols,pver/), zm_dp_idx) + call pbuf_add_field('ZM_DP', 'physpkg', dtype_r8, (/pcols,pver/), zm_dp_idx) ! wg layer thickness in mbs between lcl and maxi. - call pbuf_add_field('ZM_DSUBCLD', 'physpkg', dtype_r8, (/pcols/), zm_dsubcld_idx) + call pbuf_add_field('ZM_DSUBCLD', 'physpkg', dtype_r8, (/pcols/), zm_dsubcld_idx) ! wg top level index of deep cumulus convection. - call pbuf_add_field('ZM_JT', 'physpkg', dtype_i4, (/pcols/), zm_jt_idx) + call pbuf_add_field('ZM_JT', 'physpkg', dtype_i4, (/pcols/), zm_jt_idx) ! wg gathered values of maxi. - call pbuf_add_field('ZM_MAXG', 'physpkg', dtype_i4, (/pcols/), zm_maxg_idx) + call pbuf_add_field('ZM_MAXG', 'physpkg', dtype_i4, (/pcols/), zm_maxg_idx) ! map gathered points to chunk index - call pbuf_add_field('ZM_IDEEP', 'physpkg', dtype_i4, (/pcols/), zm_ideep_idx) + call pbuf_add_field('ZM_IDEEP', 'physpkg', dtype_i4, (/pcols/), zm_ideep_idx) ! Flux of precipitation from deep convection (kg/m2/s) - call pbuf_add_field('DP_FLXPRC','global',dtype_r8,(/pcols,pverp/),dp_flxprc_idx) + call pbuf_add_field('DP_FLXPRC','global',dtype_r8,(/pcols,pverp/),dp_flxprc_idx) -! Flux of snow from deep convection (kg/m2/s) - call pbuf_add_field('DP_FLXSNW','global',dtype_r8,(/pcols,pverp/),dp_flxsnw_idx) +! Flux of snow from deep convection (kg/m2/s) + call pbuf_add_field('DP_FLXSNW','global',dtype_r8,(/pcols,pverp/),dp_flxsnw_idx) ! deep gbm cloud liquid water (kg/kg) - call pbuf_add_field('DP_CLDLIQ','global',dtype_r8,(/pcols,pver/), dp_cldliq_idx) + call pbuf_add_field('DP_CLDLIQ','global',dtype_r8,(/pcols,pver/), dp_cldliq_idx) -! deep gbm cloud liquid water (kg/kg) - call pbuf_add_field('DP_CLDICE','global',dtype_r8,(/pcols,pver/), dp_cldice_idx) +! deep gbm cloud liquid water (kg/kg) + call pbuf_add_field('DP_CLDICE','global',dtype_r8,(/pcols,pver/), dp_cldice_idx) call pbuf_add_field('ICWMRDP', 'physpkg',dtype_r8,(/pcols,pver/),icwmrdp_idx) call pbuf_add_field('RPRDDP', 'physpkg',dtype_r8,(/pcols,pver/),rprddp_idx) @@ -253,7 +253,7 @@ subroutine zm_conv_init(pref_edge) allocate(aero(begchunk:endchunk)) -! +! ! Register fields with the output buffer ! @@ -270,13 +270,13 @@ subroutine zm_conv_init(pref_edge) call addfld ('FZSNTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Rain to snow conversion from Zhang convection') call addfld ('EVSNTZM', (/ 'lev' /), 'A', 'K/s','T tendency - Snow to rain prod from Zhang convection') call addfld ('EVAPQZM', (/ 'lev' /), 'A', 'kg/kg/s','Q tendency - Evaporation from Zhang-McFarlane moist convection') - + call addfld ('ZMFLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s','Flux of precipitation from ZM convection' ) call addfld ('ZMFLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s','Flux of snow from ZM convection' ) call addfld ('ZMNTPRPD', (/ 'lev' /) , 'A', 'kg/kg/s','Net precipitation production from ZM convection') call addfld ('ZMNTSNPD', (/ 'lev' /) , 'A', 'kg/kg/s','Net snow production from ZM convection' ) call addfld ('ZMEIHEAT', (/ 'lev' /) , 'A', 'W/kg' ,'Heating by ice and evaporation in ZM convection') - + call addfld ('CMFMCDZM', (/ 'ilev' /), 'A', 'kg/m2/s','Convection mass flux from ZM deep ') call addfld ('PRECCDZM', horiz_only, 'A', 'm/s','Convective precipitation rate from ZM deep') @@ -284,7 +284,7 @@ subroutine zm_conv_init(pref_edge) call addfld ('PCONVT', horiz_only , 'A', 'Pa' ,'convection top pressure') call addfld ('CAPE', horiz_only, 'A', 'J/kg', 'Convectively available potential energy') - call addfld ('FREQZM', horiz_only , 'A', 'fraction', 'Fractional occurance of ZM convection') + call addfld ('FREQZM', horiz_only , 'A', 'fraction', 'Fractional occurance of ZM convection') call addfld ('ZMMTT', (/ 'lev' /), 'A', 'K/s', 'T tendency - ZM convective momentum transport') call addfld ('ZMMTU', (/ 'lev' /), 'A', 'm/s2', 'U tendency - ZM convective momentum transport') @@ -348,12 +348,12 @@ subroutine zm_conv_init(pref_edge) end do if ( limcnv == 0 ) limcnv = plevp end if - + if (masterproc) then write(iulog,*)'ZM_CONV_INIT: Deep convection will be capped at intfc ',limcnv, & ' which is ',pref_edge(limcnv),' pascals' end if - + no_deep_pbl = phys_deepconv_pbl() call zm_convi(limcnv,zmconv_c0_lnd, zmconv_c0_ocn, zmconv_ke, zmconv_ke_lnd, & zmconv_momcu, zmconv_momcd, zmconv_num_cin, zmconv_org, & @@ -373,7 +373,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & rliq ,rice ,ztodt , & jctop ,jcbot , & state ,ptend_all ,landfrac, pbuf) - + use cam_history, only: outfld use physics_types, only: physics_state, physics_ptend @@ -398,7 +398,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) real(r8), intent(in) :: pblh(pcols) ! Planetary boundary layer height real(r8), intent(in) :: tpert(pcols) ! Thermal temperature excess - real(r8), intent(in) :: landfrac(pcols) ! RBN - Landfrac + real(r8), intent(in) :: landfrac(pcols) ! RBN - Landfrac real(r8), intent(out) :: mcon(pcols,pverp) ! Convective mass flux--m sub c real(r8), intent(out) :: pflx(pcols,pverp) ! scattered precip flux at each level @@ -435,7 +435,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ! physics buffer fields real(r8), pointer, dimension(:) :: prec ! total precipitation - real(r8), pointer, dimension(:) :: snow ! snow from ZM convection + real(r8), pointer, dimension(:) :: snow ! snow from ZM convection real(r8), pointer, dimension(:,:) :: cld real(r8), pointer, dimension(:,:) :: ql ! wg grid slice of cloud liquid water. real(r8), pointer, dimension(:,:) :: rprd ! rain production rate @@ -452,16 +452,16 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & real(r8), pointer :: lambdadpcu(:,:) ! slope of cloud liquid size distr real(r8), pointer :: mudpcu(:,:) ! width parameter of droplet size distr - real(r8), pointer :: mu(:,:) ! (pcols,pver) - real(r8), pointer :: eu(:,:) ! (pcols,pver) - real(r8), pointer :: du(:,:) ! (pcols,pver) - real(r8), pointer :: md(:,:) ! (pcols,pver) - real(r8), pointer :: ed(:,:) ! (pcols,pver) - real(r8), pointer :: dp(:,:) ! (pcols,pver) - real(r8), pointer :: dsubcld(:) ! (pcols) - integer, pointer :: jt(:) ! (pcols) - integer, pointer :: maxg(:) ! (pcols) - integer, pointer :: ideep(:) ! (pcols) + real(r8), pointer :: mu(:,:) ! (pcols,pver) + real(r8), pointer :: eu(:,:) ! (pcols,pver) + real(r8), pointer :: du(:,:) ! (pcols,pver) + real(r8), pointer :: md(:,:) ! (pcols,pver) + real(r8), pointer :: ed(:,:) ! (pcols,pver) + real(r8), pointer :: dp(:,:) ! (pcols,pver) + real(r8), pointer :: dsubcld(:) ! (pcols) + integer, pointer :: jt(:) ! (pcols) + integer, pointer :: maxg(:) ! (pcols) + integer, pointer :: ideep(:) ! (pcols) integer :: lengath real(r8) :: jctop(pcols) ! o row of top-of-deep-convection indices passed out. @@ -490,7 +490,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & logical :: l_windt(2) real(r8) :: tfinal1, tfinal2 integer :: ii - + real(r8),pointer :: zm_org2d(:,:) real(r8),pointer :: orgt(:,:), org(:,:) @@ -554,7 +554,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & conv%dcape(pcols) ) end if - ftem = 0._r8 + ftem = 0._r8 mu_out(:,:) = 0._r8 md_out(:,:) = 0._r8 wind_tends(:ncol,:pver,:) = 0.0_r8 @@ -637,7 +637,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & if (zmconv_org) then allocate(zm_org2d(pcols,pver)) - org => state%q(:,:,ixorg) + org => state%q(:,:,ixorg) orgt => ptend_loc%q(:,:,ixorg) endif @@ -656,12 +656,9 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & dif, dnlf, dnif, conv, & aero(lchnk), rice) -! lengath = count(ideep > 0) - call outfld('CAPE', cape, pcols, lchnk) ! RBN - CAPE output - !call outfld('EURT', eurt, pcols, lchnk) !+tht: entr.rate 2D - call outfld('EURT', eurt(1,1), pcols, lchnk) !+tht: entr.rate 3D + call outfld('EURT', eurt, pcols, lchnk) !+tht: entr.rate 3D ! ! Output fractional occurance of ZM convection @@ -693,7 +690,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ftem(:ncol,:pver) = ptend_loc%s(:ncol,:pver)/cpair call outfld('ZMDT ',ftem ,pcols ,lchnk ) - call outfld('ZMDQ ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) + call outfld('ZMDQ ',ptend_loc%q(:,:,1) ,pcols ,lchnk ) call t_stopf ('zm_convr') call outfld('DIFZM' ,dif ,pcols, lchnk) @@ -718,7 +715,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ! add tendency from this process to tendencies from other processes call physics_ptend_sum(ptend_loc,ptend_all, ncol) - ! update physics state type state1 with ptend_loc + ! update physics state type state1 with ptend_loc call physics_update(state1, ptend_loc, ztodt) ! initialize ptend for next process @@ -752,13 +749,13 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & prec, snow, ntprprd, ntsnprd , flxprec, flxsnow, conv%sprd) evapcdp(:ncol,:pver) = ptend_loc%q(:ncol,:pver,1) - + if (zmconv_org) then ptend_loc%q(:ncol,:pver,ixorg) = min(1._r8,max(0._r8,(50._r8*1000._r8*1000._r8*abs(evapcdp(:ncol,:pver))) & -(state%q(:ncol,:pver,ixorg)/10800._r8))) - ptend_loc%q(:ncol,:pver,ixorg) = (ptend_loc%q(:ncol,:pver,ixorg) - state%q(:ncol,:pver,ixorg))/ztodt - endif - + ptend_loc%q(:ncol,:pver,ixorg) = (ptend_loc%q(:ncol,:pver,ixorg) - state%q(:ncol,:pver,ixorg))/ztodt + endif + ! ! Write out variables from zm_conv_evap ! @@ -768,7 +765,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call outfld('FZSNTZM ',ftem ,pcols ,lchnk ) ftem(:ncol,:pver) = tend_s_snwevmlt(:ncol,:pver)/cpair call outfld('EVSNTZM ',ftem ,pcols ,lchnk ) - call outfld('EVAPQZM ',ptend_loc%q(1,1,1) ,pcols ,lchnk ) + call outfld('EVAPQZM ',ptend_loc%q(:,:,1) ,pcols ,lchnk ) call outfld('ZMFLXPRC', flxprec, pcols, lchnk) call outfld('ZMFLXSNW', flxsnow, pcols, lchnk) call outfld('ZMNTPRPD', ntprprd, pcols, lchnk) @@ -785,7 +782,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & ! add tendency from this process to tend from other processes here call physics_ptend_sum(ptend_loc,ptend_all, ncol) - ! update physics state type state1 with ptend_loc + ! update physics state type state1 with ptend_loc call physics_update(state1, ptend_loc, ztodt) @@ -797,7 +794,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & winds(:ncol,:pver,1) = state1%u(:ncol,:pver) winds(:ncol,:pver,2) = state1%v(:ncol,:pver) - + l_windt(1) = .true. l_windt(2) = .true. @@ -806,16 +803,16 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & l_windt,winds, 2, mu, md, & du, eu, ed, dp, dsubcld, & jt, maxg, ideep, 1, lengath, & - nstep, wind_tends, pguall, pgdall, icwu, icwd, ztodt, seten ) + nstep, wind_tends, pguall, pgdall, icwu, icwd, ztodt, seten ) call t_stopf ('momtran') ptend_loc%u(:ncol,:pver) = wind_tends(:ncol,:pver,1) ptend_loc%v(:ncol,:pver) = wind_tends(:ncol,:pver,2) - ptend_loc%s(:ncol,:pver) = seten(:ncol,:pver) + ptend_loc%s(:ncol,:pver) = seten(:ncol,:pver) call physics_ptend_sum(ptend_loc,ptend_all, ncol) - ! update physics state type state1 with ptend_loc + ! update physics state type state1 with ptend_loc call physics_update(state1, ptend_loc, ztodt) ftem(:ncol,:pver) = seten(:ncol,:pver)/cpair @@ -824,20 +821,20 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & call outfld('ZM_ORG2D', zm_org2d, pcols, lchnk) endif call outfld('ZMMTT', ftem , pcols, lchnk) - call outfld('ZMMTU', wind_tends(1,1,1), pcols, lchnk) - call outfld('ZMMTV', wind_tends(1,1,2), pcols, lchnk) - + call outfld('ZMMTU', wind_tends(:,:,1), pcols, lchnk) + call outfld('ZMMTV', wind_tends(:,:,2), pcols, lchnk) + ! Output apparent force from pressure gradient - call outfld('ZMUPGU', pguall(1,1,1), pcols, lchnk) - call outfld('ZMUPGD', pgdall(1,1,1), pcols, lchnk) - call outfld('ZMVPGU', pguall(1,1,2), pcols, lchnk) - call outfld('ZMVPGD', pgdall(1,1,2), pcols, lchnk) + call outfld('ZMUPGU', pguall(:,:,1), pcols, lchnk) + call outfld('ZMUPGD', pgdall(:,:,1), pcols, lchnk) + call outfld('ZMVPGU', pguall(:,:,2), pcols, lchnk) + call outfld('ZMVPGD', pgdall(:,:,2), pcols, lchnk) ! Output in-cloud winds - call outfld('ZMICUU', icwu(1,1,1), pcols, lchnk) - call outfld('ZMICUD', icwd(1,1,1), pcols, lchnk) - call outfld('ZMICVU', icwu(1,1,2), pcols, lchnk) - call outfld('ZMICVD', icwd(1,1,2), pcols, lchnk) + call outfld('ZMICUU', icwu(:,:,1), pcols, lchnk) + call outfld('ZMICUD', icwd(:,:,1), pcols, lchnk) + call outfld('ZMICVU', icwu(:,:,2), pcols, lchnk) + call outfld('ZMICVD', icwd(:,:,2), pcols, lchnk) end if @@ -862,8 +859,8 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & nstep, fracis, ptend_loc%q, fake_dpdry, ztodt) call t_stopf ('convtran1') - call outfld('ZMDICE ',ptend_loc%q(1,1,ixcldice) ,pcols ,lchnk ) - call outfld('ZMDLIQ ',ptend_loc%q(1,1,ixcldliq) ,pcols ,lchnk ) + call outfld('ZMDICE ',ptend_loc%q(:,:,ixcldice) ,pcols ,lchnk ) + call outfld('ZMDLIQ ',ptend_loc%q(:,:,ixcldliq) ,pcols ,lchnk ) ! add tendency from this process to tend from other processes here call physics_ptend_sum(ptend_loc,ptend_all, ncol) @@ -941,11 +938,11 @@ subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) use time_manager, only: get_nstep use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc use constituents, only: pcnst, cnst_is_convtran2 - + ! Arguments type(physics_state), intent(in ) :: state ! Physics state variables type(physics_ptend), intent(out) :: ptend ! indivdual parameterization tendencies - + type(physics_buffer_desc), pointer :: pbuf(:) real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) @@ -957,18 +954,18 @@ subroutine zm_conv_tend_2( state, ptend, ztodt, pbuf) real(r8), dimension(pcols,pver) :: dpdry - ! physics buffer fields + ! physics buffer fields real(r8), pointer :: fracis(:,:,:) ! fraction of transported species that are insoluble - real(r8), pointer :: mu(:,:) ! (pcols,pver) - real(r8), pointer :: eu(:,:) ! (pcols,pver) - real(r8), pointer :: du(:,:) ! (pcols,pver) - real(r8), pointer :: md(:,:) ! (pcols,pver) - real(r8), pointer :: ed(:,:) ! (pcols,pver) - real(r8), pointer :: dp(:,:) ! (pcols,pver) - real(r8), pointer :: dsubcld(:) ! (pcols) - integer, pointer :: jt(:) ! (pcols) - integer, pointer :: maxg(:) ! (pcols) - integer, pointer :: ideep(:) ! (pcols) + real(r8), pointer :: mu(:,:) ! (pcols,pver) + real(r8), pointer :: eu(:,:) ! (pcols,pver) + real(r8), pointer :: du(:,:) ! (pcols,pver) + real(r8), pointer :: md(:,:) ! (pcols,pver) + real(r8), pointer :: ed(:,:) ! (pcols,pver) + real(r8), pointer :: dp(:,:) ! (pcols,pver) + real(r8), pointer :: dsubcld(:) ! (pcols) + integer, pointer :: jt(:) ! (pcols) + integer, pointer :: maxg(:) ! (pcols) + integer, pointer :: ideep(:) ! (pcols) !----------------------------------------------------------------------------------- @@ -1025,7 +1022,7 @@ subroutine zm_conv_micro_init() integer :: i - ! + ! ! Register fields with the output buffer ! call addfld ('ICIMRDP', (/ 'lev' /), 'A','kg/kg', 'Deep Convection in-cloud ice mixing ratio ') diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index 0ef3a86f54..9aff68ca04 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -78,17 +78,17 @@ module cam_diagnostics ! Physics buffer indices -integer :: psl_idx = 0 -integer :: relhum_idx = 0 -integer :: qcwat_idx = 0 -integer :: tcwat_idx = 0 -integer :: lcwat_idx = 0 -integer :: cld_idx = 0 -integer :: concld_idx = 0 -integer :: tke_idx = 0 -integer :: kvm_idx = 0 -integer :: kvh_idx = 0 -integer :: cush_idx = 0 +integer :: psl_idx = 0 +integer :: relhum_idx = 0 +integer :: qcwat_idx = 0 +integer :: tcwat_idx = 0 +integer :: lcwat_idx = 0 +integer :: cld_idx = 0 +integer :: concld_idx = 0 +integer :: tke_idx = 0 +integer :: kvm_idx = 0 +integer :: kvh_idx = 0 +integer :: cush_idx = 0 integer :: t_ttend_idx = 0 integer :: prec_dp_idx = 0 @@ -166,7 +166,7 @@ subroutine diag_register() end subroutine diag_register !============================================================================== - + subroutine diag_init_dry(pbuf2d) ! Declare the history fields for which this module contains outfld calls. @@ -341,7 +341,7 @@ subroutine diag_init_dry(pbuf2d) ! State after physics (FV) call add_default ('TAP ' , history_budget_histfile_num, ' ') call add_default ('UAP ' , history_budget_histfile_num, ' ') - call add_default ('VAP ' , history_budget_histfile_num, ' ') + call add_default ('VAP ' , history_budget_histfile_num, ' ') call add_default (apcnst(1) , history_budget_histfile_num, ' ') if ( dycore_is('LR') .or. dycore_is('SE') ) then call add_default ('TFIX ' , history_budget_histfile_num, ' ') @@ -965,7 +965,7 @@ subroutine diag_phys_writeout_dry(state, pbuf, p_surf_t) do m = 1, pcnst if (cnst_cam_outfld(m)) then - call outfld(cnst_name(m), state%q(1,1,m), pcols, lchnk) + call outfld(cnst_name(m), state%q(:,:,m), pcols, lchnk) end if end do @@ -1145,9 +1145,9 @@ subroutine diag_phys_writeout_dry(state, pbuf, p_surf_t) ! ! Output U, V, T, P and Z at bottom level ! - call outfld ('UBOT ', state%u(1,pver) , pcols, lchnk) - call outfld ('VBOT ', state%v(1,pver) , pcols, lchnk) - call outfld ('ZBOT ', state%zm(1,pver) , pcols, lchnk) + call outfld ('UBOT ', state%u(:,pver) , pcols, lchnk) + call outfld ('VBOT ', state%v(:,pver) , pcols, lchnk) + call outfld ('ZBOT ', state%zm(:,pver) , pcols, lchnk) !! Boundary layer atmospheric stability, temperature, water vapor diagnostics @@ -1284,7 +1284,7 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) if (co2_transport()) then do m = 1,4 - call outfld(trim(cnst_name(c_i(m)))//'_BOT', state%q(1,pver,c_i(m)), pcols, lchnk) + call outfld(trim(cnst_name(c_i(m)))//'_BOT', state%q(:,pver,c_i(m)), pcols, lchnk) end do end if @@ -1379,7 +1379,7 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) ! ! Output Q at bottom level ! - call outfld ('QBOT ', state%q(1,pver,1), pcols, lchnk) + call outfld ('QBOT ', state%q(:,pver,1), pcols, lchnk) ! Total energy of the atmospheric column for atmospheric heat storage calculations @@ -1419,11 +1419,11 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) hist_fld_active('THE9251000') .or. & hist_fld_active('THE8501000') .or. & hist_fld_active('THE7001000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%q(1,1,1), p_surf_q1) + call vertinterp(ncol, pcols, pver, state%pmid, 100000._r8, state%q(:,:,1), p_surf_q1) end if if (hist_fld_active('THE9251000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%q(1,1,1), p_surf_q2) + call vertinterp(ncol, pcols, pver, state%pmid, 92500._r8, state%q(:,:,1), p_surf_q2) end if !!! at 1000 mb and 925 mb @@ -1450,7 +1450,7 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) !!! at 1000 mb and 850 mb if (hist_fld_active('THE8501000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%q(1,1,1), p_surf_q2) + call vertinterp(ncol, pcols, pver, state%pmid, 85000._r8, state%q(:,:,1), p_surf_q2) p_surf = ((p_surf_t(:, surf_085000)*(1000.0_r8/850.0_r8)**cappa) * & exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_085000)))) - & (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) @@ -1465,7 +1465,7 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) !!! at 1000 mb and 700 mb if (hist_fld_active('THE7001000')) then - call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%q(1,1,1), p_surf_q2) + call vertinterp(ncol, pcols, pver, state%pmid, 70000._r8, state%q(:,:,1), p_surf_q2) p_surf = ((p_surf_t(:, surf_070000)*(1000.0_r8/700.0_r8)**cappa) * & exp((2500000.0_r8*p_surf_q2)/(1004.0_r8*p_surf_t(:, surf_070000)))) - & (p_surf_t(:,surf_100000)*(1.0_r8)**cappa)*exp((2500000.0_r8*p_surf_q1)/(1004.0_r8*p_surf_t(:,surf_100000))) @@ -1721,7 +1721,7 @@ subroutine diag_surf (cam_in, cam_out, state, pbuf) if (moist_physics) then call outfld('SHFLX', cam_in%shf, pcols, lchnk) call outfld('LHFLX', cam_in%lhf, pcols, lchnk) - call outfld('QFLX', cam_in%cflx(1,1), pcols, lchnk) + call outfld('QFLX', cam_in%cflx(:,:), pcols, lchnk) call outfld('TAUX', cam_in%wsx, pcols, lchnk) call outfld('TAUY', cam_in%wsy, pcols, lchnk) @@ -2083,16 +2083,16 @@ subroutine diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & call cnst_get_ind('CLDICE', ixcldice, abort=.false.) if ( cnst_cam_outfld( 1) ) then - call outfld (apcnst( 1), state%q(1,1, 1), pcols, lchnk) + call outfld (apcnst( 1), state%q(:,:, 1), pcols, lchnk) end if if (ixcldliq > 0) then if (cnst_cam_outfld(ixcldliq)) then - call outfld (apcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) + call outfld (apcnst(ixcldliq), state%q(:,:,ixcldliq), pcols, lchnk) end if end if if (ixcldice > 0) then if ( cnst_cam_outfld(ixcldice) ) then - call outfld (apcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) + call outfld (apcnst(ixcldice), state%q(:,:,ixcldice), pcols, lchnk) end if end if @@ -2174,6 +2174,7 @@ subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics real(r8) , intent(in), optional ::eflx (pcols ) !tht: surface sensible heat flux assoc.with mass adj. real(r8) , intent(in), optional ::dsema(pcols ) !tht: column enthalpy tendency assoc. with mass adj. + real(r8) , intent(inout), optional :: tmp_t(pcols,pver) !tht: holds last physics_updated T (FV) !----------------------------------------------------------------------- @@ -2237,16 +2238,16 @@ subroutine diag_state_b4_phys_write_moist (state) call cnst_get_ind('CLDICE', ixcldice, abort=.false.) if ( cnst_cam_outfld( 1) ) then - call outfld (bpcnst( 1), state%q(1,1, 1), pcols, lchnk) + call outfld (bpcnst( 1), state%q(:,:, 1), pcols, lchnk) end if if (ixcldliq > 0) then if (cnst_cam_outfld(ixcldliq)) then - call outfld (bpcnst(ixcldliq), state%q(1,1,ixcldliq), pcols, lchnk) + call outfld (bpcnst(ixcldliq), state%q(:,:,ixcldliq), pcols, lchnk) end if end if if (ixcldice > 0) then if (cnst_cam_outfld(ixcldice)) then - call outfld (bpcnst(ixcldice), state%q(1,1,ixcldice), pcols, lchnk) + call outfld (bpcnst(ixcldice), state%q(:,:,ixcldice), pcols, lchnk) end if end if diff --git a/src/physics/cam/convect_shallow.F90 b/src/physics/cam/convect_shallow.F90 index f4f40d7d50..f854b4394f 100644 --- a/src/physics/cam/convect_shallow.F90 +++ b/src/physics/cam/convect_shallow.F90 @@ -19,19 +19,19 @@ module convect_shallow use phys_control, only : phys_getopts implicit none - private + private save public :: & convect_shallow_register, & ! Register fields in physics buffer convect_shallow_init, & ! Initialize shallow module convect_shallow_tend, & ! Return tendencies - convect_shallow_use_shfrc ! + convect_shallow_use_shfrc ! ! The following namelist variable controls which shallow convection package is used. ! 'Hack' = Hack shallow convection (default) ! 'UW' = UW shallow convection by Sungsu Park and Christopher S. Bretherton - ! 'UNICON' = General Convection Model by Sungsu Park + ! 'UNICON' = General Convection Model by Sungsu Park ! 'off' = No shallow convection character(len=16) :: shallow_scheme ! Default set in phys_control.F90, use namelist to change @@ -40,16 +40,16 @@ module convect_shallow logical :: history_budget ! Output tendencies and state variables for CAM4 T, qv, ql, qi integer :: history_budget_histfile_num ! output history file number for budget fields - ! Physics buffer indices - integer :: icwmrsh_idx = 0 - integer :: rprdsh_idx = 0 - integer :: rprdtot_idx = 0 - integer :: cldtop_idx = 0 - integer :: cldbot_idx = 0 - integer :: cush_idx = 0 + ! Physics buffer indices + integer :: icwmrsh_idx = 0 + integer :: rprdsh_idx = 0 + integer :: rprdtot_idx = 0 + integer :: cldtop_idx = 0 + integer :: cldbot_idx = 0 + integer :: cush_idx = 0 integer :: nevapr_shcu_idx = 0 - integer :: shfrc_idx = 0 - integer :: cld_idx = 0 + integer :: shfrc_idx = 0 + integer :: cld_idx = 0 integer :: concld_idx = 0 integer :: rprddp_idx = 0 integer :: tke_idx = 0 @@ -84,9 +84,9 @@ subroutine convect_shallow_register use physics_buffer, only : pbuf_add_field, dtype_r8, dyn_time_lvls use phys_control, only: use_gw_convect_sh use unicon_cam, only: unicon_cam_register - + call phys_getopts( shallow_scheme_out = shallow_scheme, microp_scheme_out = microp_scheme) - + ! SPCAM registers its own fields if (shallow_scheme == 'SPCAM') return @@ -95,7 +95,7 @@ subroutine convect_shallow_register call pbuf_add_field('RPRDTOT', 'physpkg' ,dtype_r8,(/pcols,pver/), rprdtot_idx ) call pbuf_add_field('CLDTOP', 'physpkg' ,dtype_r8,(/pcols,1/), cldtop_idx ) call pbuf_add_field('CLDBOT', 'physpkg' ,dtype_r8,(/pcols,1/), cldbot_idx ) - call pbuf_add_field('cush', 'global' ,dtype_r8,(/pcols,dyn_time_lvls/), cush_idx ) + call pbuf_add_field('cush', 'global' ,dtype_r8,(/pcols,dyn_time_lvls/), cush_idx ) call pbuf_add_field('NEVAPR_SHCU','physpkg' ,dtype_r8,(/pcols,pver/), nevapr_shcu_idx ) call pbuf_add_field('PREC_SH', 'physpkg' ,dtype_r8,(/pcols/), prec_sh_idx ) call pbuf_add_field('SNOW_SH', 'physpkg' ,dtype_r8,(/pcols/), snow_sh_idx ) @@ -110,16 +110,16 @@ subroutine convect_shallow_register endif ! shallow interface gbm flux_convective_cloud_rain+snow (kg/m2/s) - call pbuf_add_field('SH_FLXPRC','physpkg',dtype_r8,(/pcols,pverp/),sh_flxprc_idx) + call pbuf_add_field('SH_FLXPRC','physpkg',dtype_r8,(/pcols,pverp/),sh_flxprc_idx) ! shallow interface gbm flux_convective_cloud_snow (kg/m2/s) - call pbuf_add_field('SH_FLXSNW','physpkg',dtype_r8,(/pcols,pverp/),sh_flxsnw_idx) + call pbuf_add_field('SH_FLXSNW','physpkg',dtype_r8,(/pcols,pverp/),sh_flxsnw_idx) ! shallow gbm cloud liquid water (kg/kg) - call pbuf_add_field('SH_CLDLIQ','physpkg',dtype_r8,(/pcols,pver/),sh_cldliq_idx) + call pbuf_add_field('SH_CLDLIQ','physpkg',dtype_r8,(/pcols,pver/),sh_cldliq_idx) ! shallow gbm cloud ice water (kg/kg) - call pbuf_add_field('SH_CLDICE','physpkg',dtype_r8,(/pcols,pver/),sh_cldice_idx) + call pbuf_add_field('SH_CLDICE','physpkg',dtype_r8,(/pcols,pver/),sh_cldice_idx) ! If gravity waves from shallow convection are on, output this field. if (use_gw_convect_sh) then @@ -154,7 +154,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) use spmd_utils, only : masterproc use cam_abortutils, only : endrun use phys_control, only : cam_physpkg_is - + use physics_buffer, only : pbuf_get_index, physics_buffer_desc, pbuf_set_field real(r8), intent(in) :: pref_edge(plevp) ! Reference pressures at interfaces @@ -163,7 +163,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) integer limcnv ! Top interface level limit for convection integer k character(len=16) :: eddy_scheme - + ! SPCAM does its own convection if (shallow_scheme == 'SPCAM') return @@ -222,7 +222,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) call addfld( 'PCLDBOT', horiz_only, 'A', '1', 'Pressure of cloud base' ) call addfld( 'FREQSH', horiz_only, 'A', 'fraction', 'Fractional occurance of shallow convection' ) - + call addfld( 'HKFLXPRC', (/ 'ilev' /), 'A', 'kg/m2/s', 'Flux of precipitation from HK convection' ) call addfld( 'HKFLXSNW', (/ 'ilev' /), 'A', 'kg/m2/s', 'Flux of snow from HK convection' ) call addfld( 'HKNTPRPD', (/ 'lev' /), 'A', 'kg/kg/s', 'Net precipitation production from HK convection' ) @@ -287,7 +287,7 @@ subroutine convect_shallow_init(pref_edge, pbuf2d) if( masterproc ) then write(iulog,*) 'MFINTI: Convection will be capped at intfc ', limcnv, ' which is ', pref_edge(limcnv), ' pascals' end if - + call mfinti( rair, cpair, gravit, latvap, rhoh2o, limcnv) ! Get args from inti.F90 case('UW') ! Park and Bretherton shallow convection scheme @@ -347,7 +347,7 @@ end function convect_shallow_use_shfrc !=============================================================================== ! subroutine convect_shallow_tend( ztodt , cmfmc , & - qc , qc2 , rliq , rliq2 , & + qc , qc2 , rliq , rliq2 , & state , ptend_all, pbuf, cam_in) use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_set_field, pbuf_old_tim_idx @@ -358,7 +358,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & use physics_types, only : physics_ptend_dealloc use physics_types, only : physics_ptend_sum use camsrfexch, only : cam_in_t - + use constituents, only : pcnst, cnst_get_ind, cnst_get_type_byind use hk_conv, only : cmfmca use uwshcu, only : compute_uwshcu_inv @@ -382,7 +382,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8), intent(out) :: rliq2(pcols) ! Vertically-integrated reserved cloud condensate [ m/s ] real(r8), intent(out) :: qc2(pcols,pver) ! Same as qc but only from shallow convection scheme - + real(r8), intent(inout) :: cmfmc(pcols,pverp) ! Moist deep + shallow convection cloud mass flux [ kg/s/m2 ] real(r8), intent(inout) :: qc(pcols,pver) ! dq/dt due to export of cloud water into environment by shallow @@ -393,7 +393,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! --------------- ! - ! Local Variables ! + ! Local Variables ! ! --------------- ! integer :: i, k, m integer :: n, x @@ -433,7 +433,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8) :: pcnb(pcols) ! Bottom pressure level of shallow + deep convective activity real(r8) :: cmfsl(pcols,pverp ) ! Convective flux of liquid water static energy real(r8) :: cmflq(pcols,pverp ) ! Convective flux of total water in energy unit - + real(r8) :: ftem_preCu(pcols,pver) ! Saturation vapor pressure after shallow Cu convection real(r8) :: tem2(pcols,pver) ! Saturation specific humidity and RH real(r8) :: t_preCu(pcols,pver) ! Temperature after shallow Cu convection @@ -443,7 +443,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & real(r8) :: icwmr_UW(pcols,pver) ! In-cloud Cumulus LWC [ kg/m2 ] real(r8) :: icimr_UW(pcols,pver) ! In-cloud Cumulus IWC [ kg/m2 ] real(r8) :: ptend_tracer(pcols,pver,pcnst) ! Tendencies of tracers - real(r8) :: sum1, sum2, sum3, pdelx + real(r8) :: sum1, sum2, sum3, pdelx real(r8) :: landfracdum(pcols) real(r8), dimension(pcols,pver) :: sl, qt, slv @@ -477,14 +477,14 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & type(unicon_out_t) :: unicon_out ! ----------------------- ! - ! Main Computation Begins ! + ! Main Computation Begins ! ! ----------------------- ! zero = 0._r8 nstep = get_nstep() lchnk = state%lchnk ncol = state%ncol - + call physics_state_copy( state, state1 ) ! Copy state to local state1. ! Associate pointers with physics buffer fields @@ -554,7 +554,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & snow = 0._r8 case('Hack') ! Hack scheme - + lq(:) = .TRUE. call physics_ptend_init( ptend_loc, state%psetcols, 'cmfmca', ls=.true., lq=lq ) ! Initialize local ptend type @@ -566,7 +566,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & state%rpdel , state%zm , tpert , qpert , state%phis , & pblh , state%t , state%q , ptend_loc%s , ptend_loc%q , & cmfmc2 , rprdsh , cmfsl , cmflq , precc , & - qc2 , cnt2 , cnb2 , icwmr , rliq2 , & + qc2 , cnt2 , cnb2 , icwmr , rliq2 , & state%pmiddry, state%pdeldry, state%rpdeldry ) case('UW') ! UW shallow convection scheme @@ -577,7 +577,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! Initialize local ptend type lq(:) = .TRUE. - call physics_ptend_init( ptend_loc, state%psetcols, 'UWSHCU', ls=.true., lu=.true., lv=.true., lq=lq ) + call physics_ptend_init( ptend_loc, state%psetcols, 'UWSHCU', ls=.true., lu=.true., lv=.true., lq=lq ) call pbuf_get_field(pbuf, cush_idx, cush ,(/1,itim_old/), (/pcols,1/)) call pbuf_get_field(pbuf, tke_idx, tke) @@ -588,7 +588,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call pbuf_get_field(pbuf, sh_e_ed_ratio_idx, sh_e_ed_ratio) call compute_uwshcu_inv( pcols , pver , ncol , pcnst , ztodt , & - state%pint, state%zi, state%pmid , state%zm , state%pdel , & + state%pint, state%zi, state%pmid , state%zm , state%pdel , & state%u , state%v , state%q(:,:,1) , state%q(:,:,ixcldliq), state%q(:,:,ixcldice), & state%t , state%s , state%q(:,:,:) , & tke , cld , concld , pblh , cush , & @@ -607,14 +607,14 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! In addition, define 'icwmr' which includes both liquid and ice. ! ! --------------------------------------------------------------------- ! - icwmr(:ncol,:) = iccmr_UW(:ncol,:) + icwmr(:ncol,:) = iccmr_UW(:ncol,:) rprdsh(:ncol,:) = rprdsh(:ncol,:) + cmfdqs(:ncol,:) do m = 4, pcnst ptend_loc%q(:ncol,:pver,m) = ptend_tracer(:ncol,:pver,m) enddo ! Conservation check - + ! do i = 1, ncol ! do m = 1, pcnst ! sum1 = 0._r8 @@ -627,8 +627,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! pdelx = state%pdeldry(i,k) ! endif ! sum1 = sum1 + state%q(i,k,m)*pdelx - ! sum2 = sum2 +(state%q(i,k,m)+ptend_loc%q(i,k,m)*ztodt)*pdelx - ! sum3 = sum3 + ptend_loc%q(i,k,m)*pdelx + ! sum2 = sum2 +(state%q(i,k,m)+ptend_loc%q(i,k,m)*ztodt)*pdelx + ! sum3 = sum3 + ptend_loc%q(i,k,m)*pdelx ! enddo ! if( m .gt. 3 .and. abs(sum1) .gt. 1.e-13_r8 .and. abs(sum2-sum1)/sum1 .gt. 1.e-12_r8 ) then !! if( m .gt. 3 .and. abs(sum3) .gt. 1.e-13_r8 ) then @@ -672,7 +672,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & end select - ! --------------------------------------------------------! + ! --------------------------------------------------------! ! Calculate fractional occurance of shallow convection ! ! --------------------------------------------------------! @@ -697,7 +697,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & ! -------------------------------------------------------------- ! ! 'cnt2' & 'cnb2' are from shallow, 'cnt' & 'cnb' are from deep ! - ! 'cnt2' & 'cnb2' are the interface indices of cloud top & base: ! + ! 'cnt2' & 'cnb2' are the interface indices of cloud top & base: ! ! cnt2 = float(kpen) ! ! cnb2 = float(krel - 1) ! ! Note that indices decreases with height. ! @@ -707,28 +707,28 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & if( cnt2(i) < cnt(i)) cnt(i) = cnt2(i) if( cnb2(i) > cnb(i)) cnb(i) = cnb2(i) pcnt(i) = state%pmid(i,int(cnt(i))) - pcnb(i) = state%pmid(i,int(cnb(i))) + pcnb(i) = state%pmid(i,int(cnb(i))) end do - + ! ----------------------------------------------- ! ! This quantity was previously known as CMFDQR. ! ! Now CMFDQR is the shallow rain production only. ! ! ----------------------------------------------- ! - + call pbuf_set_field(pbuf, rprdtot_idx, rprdsh(:ncol,:pver) + rprddp(:ncol,:pver), start=(/1,1/), kount=(/ncol,pver/)) - - ! ----------------------------------------------------------------------- ! + + ! ----------------------------------------------------------------------- ! ! Add shallow reserved cloud condensate to deep reserved cloud condensate ! ! qc [ kg/kg/s] , rliq [ m/s ] ! ! ----------------------------------------------------------------------- ! qc(:ncol,:pver) = qc(:ncol,:pver) + qc2(:ncol,:pver) - rliq(:ncol) = rliq(:ncol) + rliq2(:ncol) + rliq(:ncol) = rliq(:ncol) + rliq2(:ncol) ! ---------------------------------------------------------------------------- ! ! Output new partition of cloud condensate variables, as well as precipitation ! - ! ---------------------------------------------------------------------------- ! + ! ---------------------------------------------------------------------------- ! if( microp_scheme == 'MG' ) then call cnst_get_ind( 'NUMLIQ', ixnumliq ) @@ -740,9 +740,9 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 'ICWMRSH ', icwmr , pcols , lchnk ) call outfld( 'CMFDT ', ftem , pcols , lchnk ) - call outfld( 'CMFDQ ', ptend_loc%q(1,1,1) , pcols , lchnk ) - call outfld( 'CMFDICE', ptend_loc%q(1,1,ixcldice) , pcols , lchnk ) - call outfld( 'CMFDLIQ', ptend_loc%q(1,1,ixcldliq) , pcols , lchnk ) + call outfld( 'CMFDQ ', ptend_loc%q(:,:,1) , pcols , lchnk ) + call outfld( 'CMFDICE', ptend_loc%q(:,:,ixcldice) , pcols , lchnk ) + call outfld( 'CMFDLIQ', ptend_loc%q(:,:,ixcldliq) , pcols , lchnk ) call outfld( 'CMFMC' , cmfmc , pcols , lchnk ) call outfld( 'QC' , qc2 , pcols , lchnk ) call outfld( 'CMFDQR' , rprdsh , pcols , lchnk ) @@ -752,12 +752,12 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 'CLDTOP' , cnt , pcols , lchnk ) call outfld( 'CLDBOT' , cnb , pcols , lchnk ) call outfld( 'PCLDTOP', pcnt , pcols , lchnk ) - call outfld( 'PCLDBOT', pcnb , pcols , lchnk ) + call outfld( 'PCLDBOT', pcnb , pcols , lchnk ) call outfld( 'FREQSH' , freqsh , pcols , lchnk ) if( shallow_scheme .eq. 'UW' ) then call outfld( 'CBMF' , cbmf , pcols , lchnk ) - call outfld( 'UWFLXPRC', flxprec , pcols , lchnk ) + call outfld( 'UWFLXPRC', flxprec , pcols , lchnk ) call outfld( 'UWFLXSNW' , flxsnow , pcols , lchnk ) endif @@ -794,8 +794,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 't_pre_Cu ', state1%t , pcols, lchnk ) call outfld( 'rh_pre_Cu ', ftem_preCu , pcols, lchnk ) - ! ----------------------------------------------- ! - ! Update physics state type state1 with ptend_loc ! + ! ----------------------------------------------- ! + ! Update physics state type state1 with ptend_loc ! ! ----------------------------------------------- ! call physics_update( state1, ptend_loc, ztodt ) @@ -825,8 +825,8 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 't_aft_Cu ', state1%t , pcols, lchnk ) call outfld( 'rh_aft_Cu ', ftem , pcols, lchnk ) - tten(:ncol,:) = ( state1%t(:ncol,:pver) - t_preCu(:ncol,:) ) / ztodt - rhten(:ncol,:) = ( ftem(:ncol,:) - ftem_preCu(:ncol,:) ) / ztodt + tten(:ncol,:) = ( state1%t(:ncol,:pver) - t_preCu(:ncol,:) ) / ztodt + rhten(:ncol,:) = ( ftem(:ncol,:) - ftem_preCu(:ncol,:) ) / ztodt call outfld( 'tten_Cu ', tten , pcols, lchnk ) call outfld( 'rhten_Cu ', rhten , pcols, lchnk ) @@ -867,7 +867,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call zm_conv_evap( state1%ncol, state1%lchnk, & state1%t, state1%pmid, state1%pdel, state1%q(:pcols,:pver,1), & landfracdum, & - ptend_loc%s, tend_s_snwprd, tend_s_snwevmlt, & + ptend_loc%s, tend_s_snwprd, tend_s_snwevmlt, & ptend_loc%q(:pcols,:pver,1), & rprdsh, cld, ztodt, & precc, snow, ntprprd, ntsnprd , flxprec, flxsnow ) @@ -884,7 +884,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 'FZSNTCM ' , ftem , pcols, lchnk ) ftem(:ncol,:pver) = tend_s_snwevmlt(:ncol,:pver) / cpair call outfld( 'EVSNTCM ' , ftem , pcols, lchnk ) - call outfld( 'EVAPQCM ' , ptend_loc%q(1,1,1) , pcols, lchnk ) + call outfld( 'EVAPQCM ' , ptend_loc%q(:,:,1) , pcols, lchnk ) call outfld( 'PRECSH ' , precc , pcols, lchnk ) call outfld( 'HKFLXPRC' , flxprec , pcols, lchnk ) call outfld( 'HKFLXSNW' , flxsnow , pcols, lchnk ) @@ -892,7 +892,7 @@ subroutine convect_shallow_tend( ztodt , cmfmc , & call outfld( 'HKNTSNPD' , ntsnprd , pcols, lchnk ) call outfld( 'HKEIHEAT' , ptend_loc%s , pcols, lchnk ) - ! ---------------------------------------------------------------- ! + ! ---------------------------------------------------------------- ! ! Add tendency from this process to tend from other processes here ! ! ---------------------------------------------------------------- ! diff --git a/src/physics/cam/ndrop_bam.F90 b/src/physics/cam/ndrop_bam.F90 index 6cd8231356..a48c277b00 100644 --- a/src/physics/cam/ndrop_bam.F90 +++ b/src/physics/cam/ndrop_bam.F90 @@ -73,10 +73,10 @@ subroutine ndrop_bam_init use phys_control, only: phys_getopts - !----------------------------------------------------------------------- - ! + !----------------------------------------------------------------------- + ! ! Initialize constants for droplet activation by bulk aerosols - ! + ! !----------------------------------------------------------------------- integer :: l, m, iaer @@ -172,7 +172,7 @@ subroutine ndrop_bam_init ! Skip aerosols that don't have a dispersion defined. if (dispersion_aer(m) == 0._r8) cycle - + alogsig(m) = log(dispersion_aer(m)) exp45logsig(m) = exp(4.5_r8*alogsig(m)*alogsig(m)) argfactor(m) = 2._r8/(3._r8*sqrt(2._r8)*alogsig(m)) @@ -316,7 +316,7 @@ subroutine ndrop_bam_run( & smc(m) = smcrit(m) ! only for prescribed size dist if (hygro_aer(m) > 1.e-10_r8) then ! loop only if variable size dist - smc(m) = 2._r8*aten*sqrt(aten/(27._r8*hygro_aer(m)*amcubeloc(m))) + smc(m) = 2._r8*aten*sqrt(aten/(27._r8*hygro_aer(m)*amcubeloc(m))) else smc(m) = 100._r8 endif @@ -397,7 +397,7 @@ subroutine ndrop_bam_ccn(lchnk, ncol, maerosol, naer2) if (m == idxsul) then ! Lohmann treatment for sulfate has variable size distribution do i = 1, ncol - if (naer2(i,k,m) > 0._r8) then + if (naer2(i,k,m) > 0._r8) then amcubesulfate(i) = amcubefactor(m)*maerosol(i,k,m)/(naer2(i,k,m)) smcritsulfate(i) = smcritfactor(m)/sqrt(amcubesulfate(i)) else @@ -433,7 +433,7 @@ subroutine ndrop_bam_ccn(lchnk, ncol, maerosol, naer2) end do ! level do l = 1, psat - call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) + call outfld(ccn_name(l), ccn(:,:,l), pcols, lchnk) end do do l = 1, naer_all @@ -489,9 +489,9 @@ subroutine maxsat(zeta, eta, nmode, smc, smax) sum=1.e20_r8 endif enddo - + smax=1._r8/sqrt(sum) - + end subroutine maxsat !=============================================================================== diff --git a/src/physics/cam/physpkg.F90 b/src/physics/cam/physpkg.F90 index 35ef4aa6ba..842f57c34b 100644 --- a/src/physics/cam/physpkg.F90 +++ b/src/physics/cam/physpkg.F90 @@ -1316,7 +1316,7 @@ subroutine tphysac (ztodt, cam_in, & real(r8), pointer, dimension(:,:) :: dtcore real(r8), pointer, dimension(:,:) :: ast ! relative humidity cloud fraction - !tht: variables for dme_energy_adjust + !tht: variables for dme_energy_adjust real(r8):: eflx(pcols), dsema(pcols) logical, parameter:: ohf_adjust =.true. ! condensates have surface specific enthalpy @@ -1626,8 +1626,8 @@ subroutine tphysac (ztodt, cam_in, & !+tht !call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_cldliq, tmp_cldice, & ! qini, cldliqini, cldiceini) - call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_t, tmp_cldliq, tmp_cldice, & - qini, cldliqini, cldiceini, eflx, dsema) + call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_cldliq, tmp_cldice, & + qini, cldliqini, cldiceini, eflx=eflx, dsema=dsema, tmp_t=tmp_t) !-tht call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) diff --git a/src/physics/cam/physpkg.F90.beta07 b/src/physics/cam/physpkg.F90.beta07 deleted file mode 100644 index 42828cf8df..0000000000 --- a/src/physics/cam/physpkg.F90.beta07 +++ /dev/null @@ -1,2351 +0,0 @@ -module physpkg - !----------------------------------------------------------------------- - ! Purpose: - ! - ! Provides the interface to CAM physics package - ! - ! Revision history: - ! Aug 2005, E. B. Kluzek, Creation of module from physpkg subroutine - ! 2005-10-17 B. Eaton Add contents of inti.F90 to phys_init(). Add - ! initialization of grid info in phys_state. - ! Nov 2010 A. Gettelman Put micro/macro physics into separate routines - !----------------------------------------------------------------------- - - use shr_kind_mod, only: r8 => shr_kind_r8 - use spmd_utils, only: masterproc - use physconst, only: latvap, latice, rh2o - use physics_types, only: physics_state, physics_tend, physics_state_set_grid, & - physics_ptend, physics_tend_init, physics_update, & - physics_type_alloc, physics_ptend_dealloc,& - physics_state_alloc, physics_state_dealloc, physics_tend_alloc, physics_tend_dealloc - use phys_grid, only: get_ncols_p - use phys_gmean, only: gmean_mass - use ppgrid, only: begchunk, endchunk, pcols, pver, pverp, psubcols - use constituents, only: pcnst, cnst_name, cnst_get_ind - use camsrfexch, only: cam_out_t, cam_in_t - - use cam_control_mod, only: ideal_phys, adiabatic - use phys_control, only: phys_do_flux_avg, phys_getopts, waccmx_is - use scamMod, only: single_column, scm_crm_mode - use flux_avg, only: flux_avg_init - use infnan, only: posinf, assignment(=) - use perf_mod - use cam_logfile, only: iulog - use camsrfexch, only: cam_export - - use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg - use modal_aero_wateruptake, only: modal_aero_wateruptake_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg - - implicit none - private - save - - ! Public methods - public phys_register ! was initindx - register physics methods - public phys_init ! Public initialization method - public phys_run1 ! First phase of the public run method - public phys_run2 ! Second phase of the public run method - public phys_final ! Public finalization method - - ! Private module data - - ! Physics package options - character(len=16) :: shallow_scheme - character(len=16) :: macrop_scheme - character(len=16) :: microp_scheme - integer :: cld_macmic_num_steps ! Number of macro/micro substeps - logical :: do_clubb_sgs - logical :: use_subcol_microp ! if true, use subcolumns in microphysics - logical :: state_debug_checks ! Debug physics_state. - logical :: clim_modal_aero ! climate controled by prognostic or prescribed modal aerosols - logical :: prog_modal_aero ! Prognostic modal aerosols present - - ! Physics buffer index - integer :: teout_idx = 0 - - integer :: landm_idx = 0 - integer :: sgh_idx = 0 - integer :: sgh30_idx = 0 - - integer :: qini_idx = 0 - integer :: cldliqini_idx = 0 - integer :: cldiceini_idx = 0 - - integer :: prec_str_idx = 0 - integer :: snow_str_idx = 0 - integer :: prec_sed_idx = 0 - integer :: snow_sed_idx = 0 - integer :: prec_pcw_idx = 0 - integer :: snow_pcw_idx = 0 - integer :: prec_dp_idx = 0 - integer :: snow_dp_idx = 0 - integer :: prec_sh_idx = 0 - integer :: snow_sh_idx = 0 - integer :: dlfzm_idx = 0 ! detrained convective cloud water mixing ratio. - -!======================================================================= -contains -!======================================================================= - - subroutine phys_register - !----------------------------------------------------------------------- - ! - ! Purpose: Register constituents and physics buffer fields. - ! - ! Author: CSM Contact: M. Vertenstein, Aug. 1997 - ! B.A. Boville, Oct 2001 - ! A. Gettelman, Nov 2010 - put micro/macro physics into separate routines - ! - !----------------------------------------------------------------------- - use cam_abortutils, only: endrun - use physics_buffer, only: pbuf_init_time - use physics_buffer, only: pbuf_add_field, dtype_r8, pbuf_register_subcol - use shr_kind_mod, only: r8 => shr_kind_r8 - use spmd_utils, only: masterproc - use constituents, only: pcnst, cnst_add, cnst_chk_dim, cnst_name - - use cam_control_mod, only: moist_physics - use chemistry, only: chem_register - use cloud_fraction, only: cldfrc_register - use rk_stratiform, only: rk_stratiform_register - use microp_driver, only: microp_driver_register - use microp_aero, only: microp_aero_register - use macrop_driver, only: macrop_driver_register - use clubb_intr, only: clubb_register_cam - use conv_water, only: conv_water_register - use physconst, only: mwdry, cpair, mwh2o, cpwv - use tracers, only: tracers_register - use check_energy, only: check_energy_register - use carma_intr, only: carma_register - use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_register - use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_register - use ghg_data, only: ghg_data_register - use vertical_diffusion, only: vd_register - use convect_deep, only: convect_deep_register - use convect_shallow, only: convect_shallow_register - use radiation, only: radiation_register - use co2_cycle, only: co2_register - use flux_avg, only: flux_avg_register - use iondrag, only: iondrag_register - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_reg - use string_utils, only: to_lower - use prescribed_ozone, only: prescribed_ozone_register - use prescribed_volcaero,only: prescribed_volcaero_register - use prescribed_strataero,only: prescribed_strataero_register - use prescribed_aero, only: prescribed_aero_register - use prescribed_ghg, only: prescribed_ghg_register - use sslt_rebin, only: sslt_rebin_register - use aoa_tracers, only: aoa_tracers_register - use aircraft_emit, only: aircraft_emit_register - use cam_diagnostics, only: diag_register - use cloud_diagnostics, only: cloud_diagnostics_register - use cospsimulator_intr, only: cospsimulator_intr_register - use rad_constituents, only: rad_cnst_get_info ! Added to query if it is a modal aero sim or not - use subcol, only: subcol_register - use subcol_utils, only: is_subcol_on - use dyn_comp, only: dyn_register - use spcam_drivers, only: spcam_register - use offline_driver, only: offline_driver_reg - - !---------------------------Local variables----------------------------- - ! - integer :: m ! loop index - integer :: mm ! constituent index - integer :: nmodes - !----------------------------------------------------------------------- - - ! Get physics options - call phys_getopts(shallow_scheme_out = shallow_scheme, & - macrop_scheme_out = macrop_scheme, & - microp_scheme_out = microp_scheme, & - cld_macmic_num_steps_out = cld_macmic_num_steps, & - do_clubb_sgs_out = do_clubb_sgs, & - use_subcol_microp_out = use_subcol_microp, & - state_debug_checks_out = state_debug_checks) - - ! Initialize dyn_time_lvls - call pbuf_init_time() - - ! Register the subcol scheme - call subcol_register() - - ! Register water vapor. - ! ***** N.B. ***** This must be the first call to cnst_add so that - ! water vapor is constituent 1. - if (moist_physics) then - call cnst_add('Q', mwh2o, cpwv, 1.E-12_r8, mm, & - longname='Specific humidity', readiv=.true., is_convtran1=.true.) - else - call cnst_add('Q', mwh2o, cpwv, 0.0_r8, mm, & - longname='Specific humidity', readiv=.false., is_convtran1=.true.) - end if - - ! Topography file fields. - call pbuf_add_field('LANDM', 'global', dtype_r8, (/pcols/), landm_idx) - call pbuf_add_field('SGH', 'global', dtype_r8, (/pcols/), sgh_idx) - call pbuf_add_field('SGH30', 'global', dtype_r8, (/pcols/), sgh30_idx) - - ! Fields for physics package diagnostics - call pbuf_add_field('QINI', 'physpkg', dtype_r8, (/pcols,pver/), qini_idx) - call pbuf_add_field('CLDLIQINI', 'physpkg', dtype_r8, (/pcols,pver/), cldliqini_idx) - call pbuf_add_field('CLDICEINI', 'physpkg', dtype_r8, (/pcols,pver/), cldiceini_idx) - - ! check energy package - call check_energy_register - - ! If using a simple physics option (e.g., held_suarez, adiabatic), - ! the normal CAM physics parameterizations are not called. - if (moist_physics) then - - ! register fluxes for saving across time - if (phys_do_flux_avg()) call flux_avg_register() - - call cldfrc_register() - - ! cloud water - if( microp_scheme == 'RK' ) then - call rk_stratiform_register() - elseif( microp_scheme == 'MG' ) then - if (.not. do_clubb_sgs) call macrop_driver_register() - call microp_aero_register() - call microp_driver_register() - end if - - ! Register CLUBB_SGS here - if (do_clubb_sgs) call clubb_register_cam() - - - call pbuf_add_field('PREC_STR', 'physpkg',dtype_r8,(/pcols/),prec_str_idx) - call pbuf_add_field('SNOW_STR', 'physpkg',dtype_r8,(/pcols/),snow_str_idx) - call pbuf_add_field('PREC_PCW', 'physpkg',dtype_r8,(/pcols/),prec_pcw_idx) - call pbuf_add_field('SNOW_PCW', 'physpkg',dtype_r8,(/pcols/),snow_pcw_idx) - call pbuf_add_field('PREC_SED', 'physpkg',dtype_r8,(/pcols/),prec_sed_idx) - call pbuf_add_field('SNOW_SED', 'physpkg',dtype_r8,(/pcols/),snow_sed_idx) - if (is_subcol_on()) then - call pbuf_register_subcol('PREC_STR', 'phys_register', prec_str_idx) - call pbuf_register_subcol('SNOW_STR', 'phys_register', snow_str_idx) - call pbuf_register_subcol('PREC_PCW', 'phys_register', prec_pcw_idx) - call pbuf_register_subcol('SNOW_PCW', 'phys_register', snow_pcw_idx) - call pbuf_register_subcol('PREC_SED', 'phys_register', prec_sed_idx) - call pbuf_register_subcol('SNOW_SED', 'phys_register', snow_sed_idx) - end if - - ! Who should add FRACIS? - ! -- It does not seem that aero_intr should add it since FRACIS is used in convection - ! even if there are no prognostic aerosols ... so do it here for now - call pbuf_add_field('FRACIS','physpkg',dtype_r8,(/pcols,pver,pcnst/),m) - - call conv_water_register() - - ! Determine whether its a 'modal' aerosol simulation or not - call rad_cnst_get_info(0, nmodes=nmodes) - clim_modal_aero = (nmodes > 0) - - if (clim_modal_aero) then - call modal_aero_calcsize_reg() - call modal_aero_wateruptake_reg() - endif - - ! register chemical constituents including aerosols ... - call chem_register() - - ! co2 constituents - call co2_register() - - ! register data model ozone with pbuf - if (cam3_ozone_data_on) then - call cam3_ozone_data_register() - end if - call prescribed_volcaero_register() - call prescribed_strataero_register() - call prescribed_ozone_register() - call prescribed_aero_register() - call prescribed_ghg_register() - call sslt_rebin_register - - ! CAM3 prescribed aerosols - if (cam3_aero_data_on) then - call cam3_aero_data_register() - end if - - ! register various data model gasses with pbuf - call ghg_data_register() - - ! carma microphysics - ! - call carma_register() - - ! Register iondrag variables with pbuf - call iondrag_register() - - ! Register ionosphere variables with pbuf if mode set to ionosphere - if( waccmx_is('ionosphere') ) then - call waccmx_phys_ion_elec_temp_reg() - endif - - call aircraft_emit_register() - - ! deep convection - call convect_deep_register - - ! shallow convection - call convect_shallow_register - - - call spcam_register - - ! radiation - call radiation_register - call cloud_diagnostics_register - - ! COSP - call cospsimulator_intr_register - - ! vertical diffusion - call vd_register() - else - ! held_suarez/adiabatic physics option should be in simple_physics - call endrun('phys_register: moist_physics configuration error') - end if - - ! Register diagnostics PBUF - call diag_register() - - ! Register age of air tracers - call aoa_tracers_register() - - ! Register test tracers - call tracers_register() - - call dyn_register() - - ! All tracers registered, check that the dimensions are correct - call cnst_chk_dim() - - ! ***NOTE*** No registering constituents after the call to cnst_chk_dim. - - call offline_driver_reg() - - end subroutine phys_register - - - - !======================================================================= - - subroutine phys_inidat( cam_out, pbuf2d ) - use cam_abortutils, only: endrun - - use physics_buffer, only: pbuf_get_index, pbuf_get_field, physics_buffer_desc, pbuf_set_field, dyn_time_lvls - - - use cam_initfiles, only: initial_file_get_id, topo_file_get_id - use cam_grid_support, only: cam_grid_check, cam_grid_id - use cam_grid_support, only: cam_grid_get_dim_names - use pio, only: file_desc_t - use ncdio_atm, only: infld - use dycore, only: dycore_is - use polar_avg, only: polar_average - use short_lived_species, only: initialize_short_lived_species - use cam_control_mod, only: aqua_planet - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_inidat - - type(cam_out_t), intent(inout) :: cam_out(begchunk:endchunk) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - integer :: lchnk, m, n, i, k, ncol - type(file_desc_t), pointer :: fh_ini, fh_topo - character(len=8) :: fieldname - real(r8), pointer :: tptr(:,:), tptr_2(:,:), tptr3d(:,:,:), tptr3d_2(:,:,:) - real(r8), pointer :: qpert(:,:) - - character(len=11) :: subname='phys_inidat' ! subroutine name - integer :: tpert_idx, qpert_idx, pblh_idx - - logical :: found=.false., found2=.false. - integer :: ierr - character(len=8) :: dim1name, dim2name - integer :: ixcldice, ixcldliq - integer :: grid_id ! grid ID for data mapping - nullify(tptr,tptr_2,tptr3d,tptr3d_2) - - fh_ini => initial_file_get_id() - fh_topo => topo_file_get_id() - - ! dynamics variables are handled in dyn_init - here we read variables needed for physics - ! but not dynamics - - grid_id = cam_grid_id('physgrid') - if (.not. cam_grid_check(grid_id)) then - call endrun(trim(subname)//': Internal error, no "physgrid" grid') - end if - call cam_grid_get_dim_names(grid_id, dim1name, dim2name) - - allocate(tptr(1:pcols,begchunk:endchunk)) - - if (associated(fh_topo) .and. .not. aqua_planet) then - call infld('SGH', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr, found, gridname='physgrid') - if(.not. found) call endrun('ERROR: SGH not found on topo file') - - call pbuf_set_field(pbuf2d, sgh_idx, tptr) - - allocate(tptr_2(1:pcols,begchunk:endchunk)) - call infld('SGH30', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr_2, found, gridname='physgrid') - if(found) then - call pbuf_set_field(pbuf2d, sgh30_idx, tptr_2) - else - if (masterproc) write(iulog,*) 'Warning: Error reading SGH30 from topo file.' - if (masterproc) write(iulog,*) 'The field SGH30 will be filled using data from SGH.' - call pbuf_set_field(pbuf2d, sgh30_idx, tptr) - end if - - deallocate(tptr_2) - - call infld('LANDM_COSLAT', fh_topo, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr, found, gridname='physgrid') - - if(.not.found) call endrun(' ERROR: LANDM_COSLAT not found on topo dataset.') - - call pbuf_set_field(pbuf2d, landm_idx, tptr) - - else - call pbuf_set_field(pbuf2d, sgh_idx, 0._r8) - call pbuf_set_field(pbuf2d, sgh30_idx, 0._r8) - call pbuf_set_field(pbuf2d, landm_idx, 0._r8) - end if - - call infld('PBLH', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr(:,:), found, gridname='physgrid') - if(.not. found) then - tptr(:,:) = 0._r8 - if (masterproc) write(iulog,*) 'PBLH initialized to 0.' - end if - pblh_idx = pbuf_get_index('pblh') - - call pbuf_set_field(pbuf2d, pblh_idx, tptr) - - call infld('TPERT', fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr(:,:), found, gridname='physgrid') - if(.not. found) then - tptr(:,:) = 0._r8 - if (masterproc) write(iulog,*) 'TPERT initialized to 0.' - end if - tpert_idx = pbuf_get_index( 'tpert') - call pbuf_set_field(pbuf2d, tpert_idx, tptr) - - fieldname='QPERT' - qpert_idx = pbuf_get_index( 'qpert',ierr) - if (qpert_idx > 0) then - call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr, found, gridname='physgrid') - if(.not. found) then - tptr=0_r8 - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - allocate(tptr3d_2(pcols,pcnst,begchunk:endchunk)) - tptr3d_2 = 0_r8 - tptr3d_2(:,1,:) = tptr(:,:) - - call pbuf_set_field(pbuf2d, qpert_idx, tptr3d_2) - deallocate(tptr3d_2) - end if - - fieldname='CUSH' - m = pbuf_get_index('cush', ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, dim2name, 1, pcols, begchunk, endchunk, & - tptr, found, gridname='physgrid') - if(.not.found) then - if(masterproc) write(iulog,*) trim(fieldname), ' initialized to 1000.' - tptr=1000._r8 - end if - do n=1,dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr, start=(/1,n/), kount=(/pcols,1/)) - end do - deallocate(tptr) - end if - - do lchnk=begchunk,endchunk - cam_out(lchnk)%tbot(:) = posinf - end do - - ! - ! 3-D fields - ! - - allocate(tptr3d(pcols,pver,begchunk:endchunk)) - - fieldname='CLOUD' - m = pbuf_get_index('CLD') - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - fieldname='QCWAT' - m = pbuf_get_index(fieldname,ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(.not. found) then - call infld('Q',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if (found) then - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with Q' - if(dycore_is('LR')) call polar_average(pver, tptr3d) - else - call endrun(' '//trim(subname)//' Error: Q must be on Initial File') - end if - end if - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - end if - - fieldname = 'ICCWAT' - m = pbuf_get_index(fieldname, ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call cnst_get_ind('CLDICE', ixcldice) - call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call pbuf_set_field(pbuf2d, m, 0._r8) - end if - if (masterproc) then - if (found) then - write(iulog,*) trim(fieldname), ' initialized with CLDICE' - else - write(iulog,*) trim(fieldname), ' initialized to 0.0' - end if - end if - end if - end if - - fieldname = 'LCWAT' - m = pbuf_get_index(fieldname,ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - allocate(tptr3d_2(pcols,pver,begchunk:endchunk)) - call cnst_get_ind('CLDICE', ixcldice) - call cnst_get_ind('CLDLIQ', ixcldliq) - call infld('CLDICE',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - call infld('CLDLIQ',fh_ini,dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d_2, found2, gridname='physgrid') - if(found .and. found2) then - do lchnk = begchunk, endchunk - ncol = get_ncols_p(lchnk) - tptr3d(:ncol,:,lchnk)=tptr3d(:ncol,:,lchnk)+tptr3d_2(:ncol,:,lchnk) - end do - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE + CLDLIQ' - else if (found) then ! Data already loaded in tptr3d - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDICE only' - else if (found2) then - tptr3d(:,:,:)=tptr3d_2(:,:,:) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with CLDLIQ only' - end if - - if (found .or. found2) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - if(dycore_is('LR')) call polar_average(pver, tptr3d) - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.0' - end if - deallocate(tptr3d_2) - end if - end if - - deallocate(tptr3d) - allocate(tptr3d(pcols,pver,begchunk:endchunk)) - - fieldname = 'TCWAT' - m = pbuf_get_index(fieldname,ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(.not.found) then - call infld('T', fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(dycore_is('LR')) call polar_average(pver, tptr3d) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized with T' - end if - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - end if - - deallocate(tptr3d) - allocate(tptr3d(pcols,pverp,begchunk:endchunk)) - - fieldname = 'TKE' - m = pbuf_get_index( 'tke') - call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if (found) then - call pbuf_set_field(pbuf2d, m, tptr3d) - else - call pbuf_set_field(pbuf2d, m, 0.01_r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.01' - end if - - - fieldname = 'KVM' - m = pbuf_get_index('kvm') - call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if (found) then - call pbuf_set_field(pbuf2d, m, tptr3d) - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - - fieldname = 'KVH' - m = pbuf_get_index('kvh') - call infld(fieldname, fh_ini, dim1name, 'ilev', dim2name, 1, pcols, 1, pverp, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if (found) then - call pbuf_set_field(pbuf2d, m, tptr3d) - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - deallocate(tptr3d) - allocate(tptr3d(pcols,pver,begchunk:endchunk)) - - fieldname = 'CONCLD' - m = pbuf_get_index('CONCLD',ierr) - if (m > 0) then - call infld(fieldname, fh_ini, dim1name, 'lev', dim2name, 1, pcols, 1, pver, begchunk, endchunk, & - tptr3d, found, gridname='physgrid') - if(found) then - do n = 1, dyn_time_lvls - call pbuf_set_field(pbuf2d, m, tptr3d, (/1,1,n/),(/pcols,pver,1/)) - end do - else - call pbuf_set_field(pbuf2d, m, 0._r8) - if (masterproc) write(iulog,*) trim(fieldname), ' initialized to 0.' - end if - - deallocate (tptr3d) - end if - - call initialize_short_lived_species(fh_ini, pbuf2d) - - !--------------------------------------------------------------------------------- - ! If needed, get ion and electron temperature fields from initial condition file - !--------------------------------------------------------------------------------- - - call waccmx_phys_ion_elec_temp_inidat(fh_ini,pbuf2d) - - end subroutine phys_inidat - - - subroutine phys_init( phys_state, phys_tend, pbuf2d, cam_out ) - - !----------------------------------------------------------------------- - ! - ! Initialization of physics package. - ! - !----------------------------------------------------------------------- - - use physics_buffer, only: physics_buffer_desc, pbuf_initialize, pbuf_get_index - use physconst, only: rair, cpair, gravit, stebol, tmelt, & - latvap, latice, rh2o, rhoh2o, pstd, zvir, & - karman, rhodair, physconst_init - use ref_pres, only: pref_edge, pref_mid - - use carma_intr, only: carma_init - use cam_control_mod, only: initial_run - use check_energy, only: check_energy_init - use chemistry, only: chem_init - use prescribed_ozone, only: prescribed_ozone_init - use prescribed_ghg, only: prescribed_ghg_init - use prescribed_aero, only: prescribed_aero_init - use aerodep_flx, only: aerodep_flx_init - use aircraft_emit, only: aircraft_emit_init - use prescribed_volcaero,only: prescribed_volcaero_init - use prescribed_strataero,only: prescribed_strataero_init - use cloud_fraction, only: cldfrc_init - use cldfrc2m, only: cldfrc2m_init - use co2_cycle, only: co2_init, co2_transport - use convect_deep, only: convect_deep_init - use convect_shallow, only: convect_shallow_init - use cam_diagnostics, only: diag_init - use gw_drag, only: gw_init - use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_init - use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_init - use radheat, only: radheat_init - use radiation, only: radiation_init - use cloud_diagnostics, only: cloud_diagnostics_init - use rk_stratiform, only: rk_stratiform_init - use wv_saturation, only: wv_sat_init - use microp_driver, only: microp_driver_init - use microp_aero, only: microp_aero_init - use macrop_driver, only: macrop_driver_init - use conv_water, only: conv_water_init - use spcam_drivers, only: spcam_init - use tracers, only: tracers_init - use aoa_tracers, only: aoa_tracers_init - use rayleigh_friction, only: rayleigh_friction_init - use pbl_utils, only: pbl_utils_init - use vertical_diffusion, only: vertical_diffusion_init - use phys_debug_util, only: phys_debug_init - use phys_debug, only: phys_debug_state_init - use rad_constituents, only: rad_cnst_init - use aer_rad_props, only: aer_rad_props_init - use subcol, only: subcol_init - use qbo, only: qbo_init - use iondrag, only: iondrag_init, do_waccm_ions -#if ( defined OFFLINE_DYN ) - use metdata, only: metdata_phys_init -#endif - use epp_ionization, only: epp_ionization_init, epp_ionization_active - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_init ! Initialization of ionosphere module (WACCM-X) - use waccmx_phys_intr, only: waccmx_phys_mspd_init ! Initialization of major species diffusion module (WACCM-X) - use clubb_intr, only: clubb_ini_cam - use sslt_rebin, only: sslt_rebin_init - use tropopause, only: tropopause_init - use solar_data, only: solar_data_init - use dadadj_cam, only: dadadj_init - use cam_abortutils, only: endrun - - ! Input/output arguments - type(physics_state), pointer :: phys_state(:) - type(physics_tend ), pointer :: phys_tend(:) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - type(cam_out_t),intent(inout) :: cam_out(begchunk:endchunk) - - ! local variables - integer :: lchnk - integer :: ierr - - !----------------------------------------------------------------------- - - call physics_type_alloc(phys_state, phys_tend, begchunk, endchunk, pcols) - - do lchnk = begchunk, endchunk - call physics_state_set_grid(lchnk, phys_state(lchnk)) - end do - - !------------------------------------------------------------------------------------------- - ! Initialize any variables in physconst which are not temporally and/or spatially constant - !------------------------------------------------------------------------------------------- - call physconst_init() - - ! Initialize debugging a physics column - call phys_debug_init() - - call pbuf_initialize(pbuf2d) - - ! Initialize subcol scheme - call subcol_init(pbuf2d) - - ! diag_init makes addfld calls for dynamics fields that are output from - ! the physics decomposition - call diag_init(pbuf2d) - - call check_energy_init() - - call tracers_init() - - ! age of air tracers - call aoa_tracers_init() - - teout_idx = pbuf_get_index( 'TEOUT') - - ! adiabatic or ideal physics should be only used if in simple_physics - if (adiabatic .or. ideal_phys) then - if (adiabatic) then - call endrun('phys_init: adiabatic configuration error') - else - call endrun('phys_init: ideal_phys configuration error') - end if - end if - - if (initial_run) then - call phys_inidat(cam_out, pbuf2d) - end if - - ! wv_saturation is relatively independent of everything else and - ! low level, so init it early. Must at least do this before radiation. - call wv_sat_init - - ! CAM3 prescribed aerosols - if (cam3_aero_data_on) call cam3_aero_data_init(phys_state) - - ! Initialize rad constituents and their properties - call rad_cnst_init() - call aer_rad_props_init() - - ! initialize carma - call carma_init() - - ! solar irradiance data modules - call solar_data_init() - - ! Prognostic chemistry. - call chem_init(phys_state,pbuf2d) - - ! Prescribed tracers - call prescribed_ozone_init() - call prescribed_ghg_init() - call prescribed_aero_init() - call aerodep_flx_init() - call aircraft_emit_init() - call prescribed_volcaero_init() - call prescribed_strataero_init() - - ! co2 cycle - if (co2_transport()) then - call co2_init() - end if - - ! CAM3 prescribed ozone - if (cam3_ozone_data_on) call cam3_ozone_data_init(phys_state) - - call gw_init() - - call rayleigh_friction_init() - - call pbl_utils_init(gravit, karman, cpair, rair, zvir) - call vertical_diffusion_init(pbuf2d) - - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - call waccmx_phys_mspd_init () - ! Initialization of ionosphere module if mode set to ionosphere - if( waccmx_is('ionosphere') ) then - call waccmx_phys_ion_elec_temp_init(pbuf2d) - endif - endif - - call radiation_init(pbuf2d) - - call cloud_diagnostics_init() - - call radheat_init(pref_mid) - - call convect_shallow_init(pref_edge, pbuf2d) - - call cldfrc_init() - call cldfrc2m_init() - - call convect_deep_init(pref_edge) - - if( microp_scheme == 'RK' ) then - call rk_stratiform_init() - elseif( microp_scheme == 'MG' ) then - if (.not. do_clubb_sgs) call macrop_driver_init(pbuf2d) - call microp_aero_init() - call microp_driver_init(pbuf2d) - call conv_water_init - elseif( microp_scheme == 'SPCAM_m2005') then - call conv_water_init - end if - - - ! initiate CLUBB within CAM - if (do_clubb_sgs) call clubb_ini_cam(pbuf2d) - - call spcam_init(pbuf2d) - - call qbo_init - - call iondrag_init(pref_mid) - ! Geomagnetic module -- after iondrag_init - if (epp_ionization_active) then - call epp_ionization_init() - endif - -#if ( defined OFFLINE_DYN ) - call metdata_phys_init() -#endif - call sslt_rebin_init() - call tropopause_init() - call dadadj_init() - - prec_dp_idx = pbuf_get_index('PREC_DP') - snow_dp_idx = pbuf_get_index('SNOW_DP') - prec_sh_idx = pbuf_get_index('PREC_SH') - snow_sh_idx = pbuf_get_index('SNOW_SH') - - dlfzm_idx = pbuf_get_index('DLFZM', ierr) - - call phys_getopts(prog_modal_aero_out=prog_modal_aero) - - if (clim_modal_aero) then - - ! If climate calculations are affected by prescribed modal aerosols, the - ! the initialization routine for the dry mode radius calculation is called - ! here. For prognostic MAM the initialization is called from - ! modal_aero_initialize - if (.not. prog_modal_aero) then - call modal_aero_calcsize_init(pbuf2d) - endif - - call modal_aero_wateruptake_init(pbuf2d) - - end if - - end subroutine phys_init - - ! - !----------------------------------------------------------------------- - ! - - subroutine phys_run1(phys_state, ztodt, phys_tend, pbuf2d, cam_in, cam_out) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! First part of atmospheric physics package before updating of surface models - ! - !----------------------------------------------------------------------- - use time_manager, only: get_nstep - use cam_diagnostics,only: diag_allocate, diag_physvar_ic - use check_energy, only: check_energy_gmean - use phys_control, only: phys_getopts - use spcam_drivers, only: tphysbc_spcam - use spmd_utils, only: mpicom - use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_allocate -#if (defined BFB_CAM_SCAM_IOP ) - use cam_history, only: outfld -#endif - use cam_abortutils, only: endrun -#if ( defined OFFLINE_DYN ) - use metdata, only: get_met_srf1 -#endif - ! - ! Input arguments - ! - real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 - ! - ! Input/Output arguments - ! - type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state - type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend - - type(physics_buffer_desc), pointer, dimension(:,:) :: pbuf2d - type(cam_in_t), dimension(begchunk:endchunk) :: cam_in - type(cam_out_t), dimension(begchunk:endchunk) :: cam_out - !----------------------------------------------------------------------- - ! - !---------------------------Local workspace----------------------------- - ! - integer :: c ! indices - integer :: ncol ! number of columns - integer :: nstep ! current timestep number - logical :: use_spcam - type(physics_buffer_desc), pointer :: phys_buffer_chunk(:) - - call t_startf ('physpkg_st1') - nstep = get_nstep() - -#if ( defined OFFLINE_DYN ) - ! - ! if offline mode set SNOWH and TS for micro-phys - ! - call get_met_srf1( cam_in ) -#endif - - ! The following initialization depends on the import state (cam_in) - ! being initialized. This isn't true when cam_init is called, so need - ! to postpone this initialization to here. - if (nstep == 0 .and. phys_do_flux_avg()) call flux_avg_init(cam_in, pbuf2d) - - ! Compute total energy of input state and previous output state - call t_startf ('chk_en_gmean') - call check_energy_gmean(phys_state, pbuf2d, ztodt, nstep) - call t_stopf ('chk_en_gmean') - - call t_stopf ('physpkg_st1') - - call t_startf ('physpkg_st1') - - call pbuf_allocate(pbuf2d, 'physpkg') - call diag_allocate() - - !----------------------------------------------------------------------- - ! Advance time information - !----------------------------------------------------------------------- - - call phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) - - call t_stopf ('physpkg_st1') - -#ifdef TRACER_CHECK - call gmean_mass ('before tphysbc DRY', phys_state) -#endif - - - !----------------------------------------------------------------------- - ! Tendency physics before flux coupler invocation - !----------------------------------------------------------------------- - ! - -#if (defined BFB_CAM_SCAM_IOP ) - do c=begchunk, endchunk - call outfld('Tg',cam_in(c)%ts,pcols ,c ) - end do -#endif - - call t_barrierf('sync_bc_physics', mpicom) - call t_startf ('bc_physics') - call t_adj_detailf(+1) - - call phys_getopts( use_spcam_out = use_spcam) - -!$OMP PARALLEL DO PRIVATE (C, phys_buffer_chunk) - do c=begchunk, endchunk - ! - ! Output physics terms to IC file - ! - phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) - - call t_startf ('diag_physvar_ic') - call diag_physvar_ic ( c, phys_buffer_chunk, cam_out(c), cam_in(c) ) - call t_stopf ('diag_physvar_ic') - - if (use_spcam) then - call tphysbc_spcam (ztodt, phys_state(c), & - phys_tend(c), phys_buffer_chunk, & - cam_out(c), cam_in(c) ) - else - call tphysbc (ztodt, phys_state(c), & - phys_tend(c), phys_buffer_chunk, & - cam_out(c), cam_in(c) ) - end if - - end do - - call t_adj_detailf(-1) - call t_stopf ('bc_physics') - - ! Don't call the rest in CRM mode - if(single_column.and.scm_crm_mode) return - -#ifdef TRACER_CHECK - call gmean_mass ('between DRY', phys_state) -#endif - - end subroutine phys_run1 - - ! - !----------------------------------------------------------------------- - ! - - subroutine phys_run2(phys_state, ztodt, phys_tend, pbuf2d, cam_out, & - cam_in ) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Second part of atmospheric physics package after updating of surface models - ! - !----------------------------------------------------------------------- - use physics_buffer, only: physics_buffer_desc, pbuf_get_chunk, pbuf_deallocate, pbuf_update_tim_idx - use mo_lightning, only: lightning_no_prod - use cam_diagnostics, only: diag_deallocate, diag_surf - use physconst, only: stebol, latvap - use carma_intr, only: carma_accumulate_stats - use spmd_utils, only: mpicom -#if ( defined OFFLINE_DYN ) - use metdata, only: get_met_srf2 -#endif - ! - ! Input arguments - ! - real(r8), intent(in) :: ztodt ! physics time step unless nstep=0 - ! - ! Input/Output arguments - ! - type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state - type(physics_tend ), intent(inout), dimension(begchunk:endchunk) :: phys_tend - type(physics_buffer_desc),pointer, dimension(:,:) :: pbuf2d - - type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out - type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in - ! - !----------------------------------------------------------------------- - !---------------------------Local workspace----------------------------- - ! - integer :: c ! chunk index - integer :: ncol ! number of columns - type(physics_buffer_desc),pointer, dimension(:) :: phys_buffer_chunk - ! - ! If exit condition just return - ! - - if(single_column.and.scm_crm_mode) return - - !----------------------------------------------------------------------- - ! Tendency physics after coupler - ! Not necessary at terminal timestep. - !----------------------------------------------------------------------- - ! -#if ( defined OFFLINE_DYN ) - ! - ! if offline mode set SHFLX QFLX TAUX TAUY for vert diffusion - ! - call get_met_srf2( cam_in ) -#endif - ! Set lightning production of NO - call t_startf ('lightning_no_prod') - call lightning_no_prod( phys_state, pbuf2d, cam_in ) - call t_stopf ('lightning_no_prod') - - call t_barrierf('sync_ac_physics', mpicom) - call t_startf ('ac_physics') - call t_adj_detailf(+1) - -!$OMP PARALLEL DO PRIVATE (C, NCOL, phys_buffer_chunk) - - do c=begchunk,endchunk - ncol = get_ncols_p(c) - phys_buffer_chunk => pbuf_get_chunk(pbuf2d, c) - ! - ! surface diagnostics for history files - ! - call t_startf('diag_surf') - call diag_surf(cam_in(c), cam_out(c), phys_state(c), phys_buffer_chunk) - call t_stopf('diag_surf') - - call tphysac(ztodt, cam_in(c), & - cam_out(c), & - phys_state(c), phys_tend(c), phys_buffer_chunk) - end do ! Chunk loop - - call t_adj_detailf(-1) - call t_stopf('ac_physics') - -#ifdef TRACER_CHECK - call gmean_mass ('after tphysac FV:WET)', phys_state) -#endif - - call t_startf ('carma_accumulate_stats') - call carma_accumulate_stats() - call t_stopf ('carma_accumulate_stats') - - call t_startf ('physpkg_st2') - call pbuf_deallocate(pbuf2d, 'physpkg') - - call pbuf_update_tim_idx() - call diag_deallocate() - call t_stopf ('physpkg_st2') - - end subroutine phys_run2 - - ! - !----------------------------------------------------------------------- - ! - - subroutine phys_final( phys_state, phys_tend, pbuf2d ) - use physics_buffer, only : physics_buffer_desc, pbuf_deallocate - use chemistry, only : chem_final - use carma_intr, only : carma_final - use wv_saturation, only : wv_sat_final - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Finalization of physics package - ! - !----------------------------------------------------------------------- - ! Input/output arguments - type(physics_state), pointer :: phys_state(:) - type(physics_tend ), pointer :: phys_tend(:) - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - if(associated(pbuf2d)) then - call pbuf_deallocate(pbuf2d,'global') - deallocate(pbuf2d) - end if - deallocate(phys_state) - deallocate(phys_tend) - call chem_final - call carma_final - call wv_sat_final - - end subroutine phys_final - - - subroutine tphysac (ztodt, cam_in, & - cam_out, state, tend, pbuf) - !----------------------------------------------------------------------- - ! - ! Tendency physics after coupling to land, sea, and ice models. - ! - ! Computes the following: - ! - ! o Aerosol Emission at Surface - ! o Source-Sink for Advected Tracers - ! o Symmetric Turbulence Scheme - Vertical Diffusion - ! o Rayleigh Friction - ! o Dry Deposition of Aerosol - ! o Enforce Charge Neutrality ( Only for WACCM ) - ! o Gravity Wave Drag - ! o QBO Relaxation ( Only for WACCM ) - ! o Ion Drag ( Only for WACCM ) - ! o Scale Dry Mass Energy - !----------------------------------------------------------------------- - use physics_buffer, only: physics_buffer_desc, pbuf_set_field, pbuf_get_index, pbuf_get_field, pbuf_old_tim_idx - use shr_kind_mod, only: r8 => shr_kind_r8 - use chemistry, only: chem_is_active, chem_timestep_tend, chem_emissions - use cam_diagnostics, only: diag_phys_tend_writeout - use gw_drag, only: gw_tend - use vertical_diffusion, only: vertical_diffusion_tend - use rayleigh_friction, only: rayleigh_friction_tend - use constituents, only: cnst_get_ind - use physics_types, only: physics_state, physics_tend, physics_ptend, physics_update, & - physics_dme_adjust, set_dry_to_wet, physics_state_check - use waccmx_phys_intr, only: waccmx_phys_mspd_tend ! WACCM-X major diffusion - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_tend ! WACCM-X - use aoa_tracers, only: aoa_tracers_timestep_tend - use physconst, only: rhoh2o, latvap,latice - use aero_model, only: aero_model_drydep - use carma_intr, only: carma_emission_tend, carma_timestep_tend - use carma_flags_mod, only: carma_do_aerosol, carma_do_emission - use check_energy, only: check_energy_chng - use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng - use time_manager, only: get_nstep - use cam_abortutils, only: endrun - use dycore, only: dycore_is - use cam_control_mod, only: aqua_planet - use mo_gas_phase_chemdr,only: map2chm - use clybry_fam, only: clybry_fam_set - use charge_neutrality, only: charge_balance - use qbo, only: qbo_relax - use iondrag, only: iondrag_calc, do_waccm_ions - use perf_mod - use flux_avg, only: flux_avg_run - use unicon_cam, only: unicon_cam_org_diags - - ! - ! Arguments - ! - real(r8), intent(in) :: ztodt ! Two times model timestep (2 delta-t) - - type(cam_in_t), intent(inout) :: cam_in - type(cam_out_t), intent(inout) :: cam_out - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - type(physics_buffer_desc), pointer :: pbuf(:) - - - type(check_tracers_data):: tracerint ! tracer mass integrals and cummulative boundary fluxes - - ! - !---------------------------Local workspace----------------------------- - ! - type(physics_ptend) :: ptend ! indivdual parameterization tendencies - - integer :: nstep ! current timestep number - real(r8) :: zero(pcols) ! array of zeros - - integer :: lchnk ! chunk identifier - integer :: ncol ! number of atmospheric columns - integer i,k,m ! Longitude, level indices - integer :: yr, mon, day, tod ! components of a date - integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. - - logical :: labort ! abort flag - - real(r8) tvm(pcols,pver) ! virtual temperature - real(r8) prect(pcols) ! total precipitation - real(r8) surfric(pcols) ! surface friction velocity - real(r8) obklen(pcols) ! Obukhov length - real(r8) :: fh2o(pcols) ! h2o flux to balance source from methane chemistry - real(r8) :: flx_heat(pcols) ! Heat flux for check_energy_chng. - real(r8) :: tmp_q (pcols,pver) ! tmp space - real(r8) :: tmp_cldliq(pcols,pver) ! tmp space - real(r8) :: tmp_cldice(pcols,pver) ! tmp space - real(r8) :: tmp_t (pcols,pver) !tht: tmp space - - ! physics buffer fields for total energy and mass adjustment - integer itim_old, ifld - - real(r8), pointer, dimension(:,:) :: cld - real(r8), pointer, dimension(:,:) :: qini - real(r8), pointer, dimension(:,:) :: cldliqini - real(r8), pointer, dimension(:,:) :: cldiceini - real(r8), pointer, dimension(:,:) :: dtcore - real(r8), pointer, dimension(:,:) :: ast ! relative humidity cloud fraction - - !tht: variables for dme_energy_adjust - real(r8):: eflx(pcols), dsema(pcols) - logical, parameter:: ohf_adjust =.true. ! condensates have surface specific enthalpy - - !----------------------------------------------------------------------- - lchnk = state%lchnk - ncol = state%ncol - - nstep = get_nstep() - - ! Adjust the surface fluxes to reduce instabilities in near sfc layer - if (phys_do_flux_avg()) then - call flux_avg_run(state, cam_in, pbuf, nstep, ztodt) - endif - - ! Validate the physics state. - if (state_debug_checks) & - call physics_state_check(state, name="before tphysac") - - call t_startf('tphysac_init') - ! Associate pointers with physics buffer fields - itim_old = pbuf_old_tim_idx() - - - ifld = pbuf_get_index('DTCORE') - call pbuf_get_field(pbuf, ifld, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - call pbuf_get_field(pbuf, qini_idx, qini) - call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) - call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) - - ifld = pbuf_get_index('CLD') - call pbuf_get_field(pbuf, ifld, cld, start=(/1,1,itim_old/),kount=(/pcols,pver,1/)) - - ifld = pbuf_get_index('AST') - call pbuf_get_field(pbuf, ifld, ast, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - ! - ! accumulate fluxes into net flux array for spectral dycores - ! jrm Include latent heat of fusion for snow - ! - do i=1,ncol - tend%flx_net(i) = tend%flx_net(i) + cam_in%shf(i) + (cam_out%precc(i) & - + cam_out%precl(i))*latvap*rhoh2o & - + (cam_out%precsc(i) + cam_out%precsl(i))*latice*rhoh2o - end do - - ! emissions of aerosols and gas-phase chemistry constituents at surface - call chem_emissions( state, cam_in ) - - if (carma_do_emission) then - ! carma emissions - call carma_emission_tend (state, ptend, cam_in, ztodt) - call physics_update(state, ptend, ztodt, tend) - end if - - ! get nstep and zero array for energy checker - zero = 0._r8 - nstep = get_nstep() - call check_tracers_init(state, tracerint) - - ! Check if latent heat flux exceeds the total moisture content of the - ! lowest model layer, thereby creating negative moisture. - - call qneg4('TPHYSAC ' ,lchnk ,ncol ,ztodt , & - state%q(1,pver,1),state%rpdel(1,pver) ,cam_in%shf , & - cam_in%lhf , cam_in%cflx ) - - call t_stopf('tphysac_init') - !=================================================== - ! Source/sink terms for advected tracers. - !=================================================== - call t_startf('adv_tracer_src_snk') - ! Test tracers - - call aoa_tracers_timestep_tend(state, ptend, cam_in%cflx, cam_in%landfrac, ztodt) - call physics_update(state, ptend, ztodt, tend) - call check_tracers_chng(state, tracerint, "aoa_tracers_timestep_tend", nstep, ztodt, & - cam_in%cflx) - - !=================================================== - ! Chemistry and MAM calculation - ! MAM core aerosol conversion process is performed in the below 'chem_timestep_tend'. - ! In addition, surface flux of aerosol species other than 'dust' and 'sea salt', and - ! elevated emission of aerosol species are treated in 'chem_timestep_tend' before - ! Gas chemistry and MAM core aerosol conversion. - ! Note that surface flux is not added into the atmosphere, but elevated emission is - ! added into the atmosphere as tendency. - !=================================================== - if (chem_is_active()) then - call chem_timestep_tend(state, ptend, cam_in, cam_out, ztodt, & - pbuf, fh2o=fh2o) - - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "chem", nstep, ztodt, fh2o, zero, zero, zero) - call check_tracers_chng(state, tracerint, "chem_timestep_tend", nstep, ztodt, & - cam_in%cflx) - end if - call t_stopf('adv_tracer_src_snk') - - !=================================================== - ! Vertical diffusion/pbl calculation - ! Call vertical diffusion code (pbl, free atmosphere and molecular) - !=================================================== - - call t_startf('vertical_diffusion_tend') - call vertical_diffusion_tend (ztodt ,state , cam_in, & - surfric ,obklen ,ptend ,ast ,pbuf ) - - !------------------------------------------ - ! Call major diffusion for extended model - !------------------------------------------ - if ( waccmx_is('ionosphere') .or. waccmx_is('neutral') ) then - call waccmx_phys_mspd_tend (ztodt ,state ,ptend) - endif - - call physics_update(state, ptend, ztodt, tend) - - call t_stopf ('vertical_diffusion_tend') - - !=================================================== - ! Rayleigh friction calculation - !=================================================== - call t_startf('rayleigh_friction') - call rayleigh_friction_tend( ztodt, state, ptend) - call physics_update(state, ptend, ztodt, tend) - call t_stopf('rayleigh_friction') - - if (do_clubb_sgs) then - call check_energy_chng(state, tend, "vdiff", nstep, ztodt, zero, zero, zero, zero) - else - call check_energy_chng(state, tend, "vdiff", nstep, ztodt, cam_in%cflx(:,1), zero, & - zero, cam_in%shf) - endif - - call check_tracers_chng(state, tracerint, "vdiff", nstep, ztodt, cam_in%cflx) - - ! aerosol dry deposition processes - call t_startf('aero_drydep') - call aero_model_drydep( state, pbuf, obklen, surfric, cam_in, ztodt, cam_out, ptend ) - call physics_update(state, ptend, ztodt, tend) - call t_stopf('aero_drydep') - - ! CARMA microphysics - ! - ! NOTE: This does both the timestep_tend for CARMA aerosols as well as doing the dry - ! deposition for CARMA aerosols. It needs to follow vertical_diffusion_tend, so that - ! obklen and surfric have been calculated. It needs to follow aero_model_drydep, so - ! that cam_out%xxxdryxxx fields have already been set for CAM aerosols and cam_out - ! can be added to for CARMA aerosols. - if (carma_do_aerosol) then - call t_startf('carma_timestep_tend') - call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, obklen=obklen, ustar=surfric) - call physics_update(state, ptend, ztodt, tend) - - call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, zero, zero, zero) - call t_stopf('carma_timestep_tend') - end if - - - !--------------------------------------------------------------------------------- - ! ... enforce charge neutrality - !--------------------------------------------------------------------------------- - call charge_balance(state, pbuf) - - !=================================================== - ! Gravity wave drag - !=================================================== - call t_startf('gw_tend') - - call gw_tend(state, pbuf, ztodt, ptend, cam_in, flx_heat) - - call physics_update(state, ptend, ztodt, tend) - ! Check energy integrals - call check_energy_chng(state, tend, "gwdrag", nstep, ztodt, zero, & - zero, zero, flx_heat) - call t_stopf('gw_tend') - - ! QBO relaxation - call qbo_relax(state, pbuf, ptend) - call physics_update(state, ptend, ztodt, tend) - ! Check energy integrals - call check_energy_chng(state, tend, "qborelax", nstep, ztodt, zero, zero, zero, zero) - - ! Ion drag calculation - call t_startf ( 'iondrag' ) - - if ( do_waccm_ions ) then - call iondrag_calc( lchnk, ncol, state, ptend, pbuf, ztodt ) - else - call iondrag_calc( lchnk, ncol, state, ptend) - endif - !---------------------------------------------------------------------------- - ! Call ionosphere routines for extended model if mode is set to ionosphere - !---------------------------------------------------------------------------- - if( waccmx_is('ionosphere') ) then - call waccmx_phys_ion_elec_temp_tend(state, ptend, pbuf, ztodt) - endif - - call physics_update(state, ptend, ztodt, tend) - - !--------------------------------------------------------------------------------- - ! Enforce charge neutrality after O+ change from ionos_tend - !--------------------------------------------------------------------------------- - if( waccmx_is('ionosphere') ) then - call charge_balance(state, pbuf) - endif - - ! Check energy integrals - call check_energy_chng(state, tend, "iondrag", nstep, ztodt, zero, zero, zero, zero) - - call t_stopf ( 'iondrag' ) - - !-------------- Energy budget checks vvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvvv - - ! Save total energy for global fixer in next timestep (FV and SE dycores) - call pbuf_set_field(pbuf, teout_idx, state%te_cur, (/1,itim_old/),(/pcols,1/)) - - if (shallow_scheme .eq. 'UNICON') then - - ! ------------------------------------------------------------------------ - ! Insert the organization-related heterogeneities computed inside the - ! UNICON into the tracer arrays here before performing advection. - ! This is necessary to prevent any modifications of organization-related - ! heterogeneities by non convection-advection process, such as - ! dry and wet deposition of aerosols, MAM, etc. - ! Again, note that only UNICON and advection schemes are allowed to - ! changes to organization at this stage, although we can include the - ! effects of other physical processes in future. - ! ------------------------------------------------------------------------ - - call unicon_cam_org_diags(state, pbuf) - - end if - ! - ! FV: convert dry-type mixing ratios to moist here because physics_dme_adjust - ! assumes moist. This is done in p_d_coupling for other dynamics. Bundy, Feb 2004. - if ( dycore_is('LR') .or. dycore_is('SE')) call set_dry_to_wet(state) ! Physics had dry, dynamics wants moist - - ! Scale dry mass and energy (does nothing if dycore is EUL or SLD) - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - - tmp_t (:ncol,:pver) = state%t(:ncol,:pver) - tmp_q (:ncol,:pver) = state%q(:ncol,:pver,1) - tmp_cldliq(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) - tmp_cldice(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) - - !call physics_dme_adjust(state, tend, qini, ztodt) - call physics_dme_adjust(state, tend, qini, ztodt, eflx, dsema, & - ohf_adjust, cam_in%ocnfrac, cam_in%sst, cam_in%ts) !tht - -!!! REMOVE THIS CALL, SINCE ONLY Q IS BEING ADJUSTED. WON'T BALANCE ENERGY. TE IS SAVED BEFORE THIS -!!! call check_energy_chng(state, tend, "drymass", nstep, ztodt, zero, zero, zero, zero) - - ! store T in buffer for use in computing dynamics T-tendency in next timestep - do k = 1,pver - dtcore(:ncol,k) = state%t(:ncol,k) - end do - - !-------------- Energy budget checks ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^ - - if (aqua_planet) then - labort = .false. - do i=1,ncol - if (cam_in%ocnfrac(i) /= 1._r8) labort = .true. - end do - if (labort) then - call endrun ('TPHYSAC error: grid contains non-ocean point') - endif - endif - - !call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_cldliq, tmp_cldice, & - ! qini, cldliqini, cldiceini) - call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_t, tmp_cldliq, tmp_cldice, & - qini, cldliqini, cldiceini, eflx, dsema) !tht - - call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) - - end subroutine tphysac - - subroutine tphysbc (ztodt, state, & - tend, pbuf, & - cam_out, cam_in ) - !----------------------------------------------------------------------- - ! - ! Purpose: - ! Evaluate and apply physical processes that are calculated BEFORE - ! coupling to land, sea, and ice models. - ! - ! Processes currently included are: - ! - ! o Resetting Negative Tracers to Positive - ! o Global Mean Total Energy Fixer - ! o Dry Adjustment - ! o Asymmetric Turbulence Scheme : Deep Convection & Shallow Convection - ! o Stratiform Macro-Microphysics - ! o Wet Scavenging of Aerosol - ! o Radiation - ! - ! Method: - ! - ! Each parameterization should be implemented with this sequence of calls: - ! 1) Call physics interface - ! 2) Check energy - ! 3) Call physics_update - ! See Interface to Column Physics and Chemistry Packages - ! http://www.ccsm.ucar.edu/models/atm-cam/docs/phys-interface/index.html - ! - !----------------------------------------------------------------------- - - use physics_buffer, only: physics_buffer_desc, pbuf_get_field - use physics_buffer, only: pbuf_get_index, pbuf_old_tim_idx - use physics_buffer, only: col_type_subcol, dyn_time_lvls - use shr_kind_mod, only: r8 => shr_kind_r8 - - use dadadj_cam, only: dadadj_tend - use rk_stratiform, only: rk_stratiform_tend - use microp_driver, only: microp_driver_tend - use microp_aero, only: microp_aero_run - use macrop_driver, only: macrop_driver_tend - use physics_types, only: physics_state, physics_tend, physics_ptend, & - physics_update, physics_ptend_init, physics_ptend_sum, & - physics_state_check, physics_ptend_scale - use cam_diagnostics, only: diag_conv_tend_ini, diag_phys_writeout, diag_conv, diag_export, diag_state_b4_phys_write - use cam_history, only: outfld - use physconst, only: cpair, latvap - use constituents, only: pcnst, qmin, cnst_get_ind - use convect_deep, only: convect_deep_tend, convect_deep_tend_2, deep_scheme_does_scav_trans - use time_manager, only: is_first_step, get_nstep - use convect_shallow, only: convect_shallow_tend - use check_energy, only: check_energy_chng, check_energy_fix, check_energy_timestep_init - use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng - use dycore, only: dycore_is - use aero_model, only: aero_model_wetdep - use carma_intr, only: carma_wetdep_tend, carma_timestep_tend - use carma_flags_mod, only: carma_do_detrain, carma_do_cldice, carma_do_cldliq, carma_do_wetdep - use radiation, only: radiation_tend - use cloud_diagnostics, only: cloud_diagnostics_calc - use perf_mod - use mo_gas_phase_chemdr,only: map2chm - use clybry_fam, only: clybry_fam_adj - use clubb_intr, only: clubb_tend_cam - use sslt_rebin, only: sslt_rebin_adv - use tropopause, only: tropopause_output - use cam_abortutils, only: endrun - use subcol, only: subcol_gen, subcol_ptend_avg - use subcol_utils, only: subcol_ptend_copy, is_subcol_on - - ! Arguments - - real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) - - type(physics_state), intent(inout) :: state - type(physics_tend ), intent(inout) :: tend - type(physics_buffer_desc), pointer :: pbuf(:) - - type(cam_out_t), intent(inout) :: cam_out - type(cam_in_t), intent(in) :: cam_in - - - ! - !---------------------------Local workspace----------------------------- - ! - - type(physics_ptend) :: ptend ! indivdual parameterization tendencies - type(physics_state) :: state_sc ! state for sub-columns - type(physics_ptend) :: ptend_sc ! ptend for sub-columns - type(physics_ptend) :: ptend_aero ! ptend for microp_aero - type(physics_ptend) :: ptend_aero_sc ! ptend for microp_aero on sub-columns - type(physics_tend) :: tend_sc ! tend for sub-columns - - integer :: nstep ! current timestep number - - real(r8) :: net_flx(pcols) - - real(r8) :: zdu(pcols,pver) ! detraining mass flux from deep convection - real(r8) :: cmfmc(pcols,pverp) ! Convective mass flux--m sub c - - real(r8) cmfcme(pcols,pver) ! cmf condensation - evaporation - - real(r8) dlf(pcols,pver) ! Detraining cld H20 from shallow + deep convections - real(r8) dlf2(pcols,pver) ! Detraining cld H20 from shallow convections - real(r8) pflx(pcols,pverp) ! Conv rain flux thru out btm of lev - - integer lchnk ! chunk identifier - integer ncol ! number of atmospheric columns - - integer :: i ! column indicex - integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. - ! for macro/micro co-substepping - integer :: macmic_it ! iteration variables - real(r8) :: cld_macmic_ztodt ! modified timestep - ! physics buffer fields to compute tendencies for stratiform package - integer itim_old, ifld - real(r8), pointer, dimension(:,:) :: cld ! cloud fraction - - - ! physics buffer fields for total energy and mass adjustment - real(r8), pointer, dimension(: ) :: teout - real(r8), pointer, dimension(:,:) :: qini - real(r8), pointer, dimension(:,:) :: cldliqini - real(r8), pointer, dimension(:,:) :: cldiceini - real(r8), pointer, dimension(:,:) :: dtcore - - real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble - - real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. - - ! convective precipitation variables - real(r8),pointer :: prec_dp(:) ! total precipitation from ZM convection - real(r8),pointer :: snow_dp(:) ! snow from ZM convection - real(r8),pointer :: prec_sh(:) ! total precipitation from Hack convection - real(r8),pointer :: snow_sh(:) ! snow from Hack convection - - ! carma precipitation variables - real(r8) :: prec_sed_carma(pcols) ! total precip from cloud sedimentation (CARMA) - real(r8) :: snow_sed_carma(pcols) ! snow from cloud ice sedimentation (CARMA) - - ! stratiform precipitation variables - real(r8),pointer :: prec_str(:) ! sfc flux of precip from stratiform (m/s) - real(r8),pointer :: snow_str(:) ! sfc flux of snow from stratiform (m/s) - real(r8),pointer :: prec_str_sc(:) ! sfc flux of precip from stratiform (m/s) -- for subcolumns - real(r8),pointer :: snow_str_sc(:) ! sfc flux of snow from stratiform (m/s) -- for subcolumns - real(r8),pointer :: prec_pcw(:) ! total precip from prognostic cloud scheme - real(r8),pointer :: snow_pcw(:) ! snow from prognostic cloud scheme - real(r8),pointer :: prec_sed(:) ! total precip from cloud sedimentation - real(r8),pointer :: snow_sed(:) ! snow from cloud ice sedimentation - - ! Local copies for substepping - real(r8) :: prec_pcw_macmic(pcols) - real(r8) :: snow_pcw_macmic(pcols) - real(r8) :: prec_sed_macmic(pcols) - real(r8) :: snow_sed_macmic(pcols) - - ! energy checking variables - real(r8) :: zero(pcols) ! array of zeros - real(r8) :: zero_sc(pcols*psubcols) ! array of zeros - real(r8) :: rliq(pcols) ! vertical integral of liquid not yet in q(ixcldliq) - real(r8) :: rice(pcols) ! vertical integral of ice not yet in q(ixcldice) - real(r8) :: rliq2(pcols) ! vertical integral of liquid from shallow scheme - real(r8) :: det_s (pcols) ! vertical integral of detrained static energy from ice - real(r8) :: det_ice(pcols) ! vertical integral of detrained ice - real(r8) :: flx_cnd(pcols) - real(r8) :: flx_heat(pcols) - type(check_tracers_data):: tracerint ! energy integrals and cummulative boundary fluxes - real(r8) :: zero_tracers(pcols,pcnst) - - logical :: lq(pcnst) - !----------------------------------------------------------------------- - - call t_startf('bc_init') - - zero = 0._r8 - zero_tracers(:,:) = 0._r8 - zero_sc(:) = 0._r8 - - lchnk = state%lchnk - ncol = state%ncol - - nstep = get_nstep() - - ! Associate pointers with physics buffer fields - itim_old = pbuf_old_tim_idx() - ifld = pbuf_get_index('CLD') - call pbuf_get_field(pbuf, ifld, cld, (/1,1,itim_old/),(/pcols,pver,1/)) - - call pbuf_get_field(pbuf, teout_idx, teout, (/1,itim_old/), (/pcols,1/)) - - call pbuf_get_field(pbuf, qini_idx, qini) - call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) - call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) - - ifld = pbuf_get_index('DTCORE') - call pbuf_get_field(pbuf, ifld, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - ifld = pbuf_get_index('FRACIS') - call pbuf_get_field(pbuf, ifld, fracis, start=(/1,1,1/), kount=(/pcols, pver, pcnst/) ) - fracis (:ncol,:,1:pcnst) = 1._r8 - - ! Set physics tendencies to 0 - tend %dTdt(:ncol,:pver) = 0._r8 - tend %dudt(:ncol,:pver) = 0._r8 - tend %dvdt(:ncol,:pver) = 0._r8 - - ! Verify state coming from the dynamics - if (state_debug_checks) & - call physics_state_check(state, name="before tphysbc (dycore?)") - - call clybry_fam_adj( ncol, lchnk, map2chm, state%q, pbuf ) - - ! Since clybry_fam_adj operates directly on the tracers, and has no - ! physics_update call, re-run qneg3. - - call qneg3('TPHYSBCc',lchnk ,ncol ,pcols ,pver , & - 1, pcnst, qmin ,state%q ) - - ! Validate output of clybry_fam_adj. - if (state_debug_checks) & - call physics_state_check(state, name="clybry_fam_adj") - - ! - ! Dump out "before physics" state - ! - call diag_state_b4_phys_write (state) - - ! compute mass integrals of input tracers state - call check_tracers_init(state, tracerint) - - call t_stopf('bc_init') - - !=================================================== - ! Global mean total energy fixer - !=================================================== - call t_startf('energy_fixer') - - if (dycore_is('LR') .or. dycore_is('SE')) then - call check_energy_fix(state, ptend, nstep, flx_heat) - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "chkengyfix", nstep, ztodt, zero, zero, zero, flx_heat) - call outfld( 'EFIX', flx_heat , pcols, lchnk ) - end if - ! Save state for convective tendency calculations. - call diag_conv_tend_ini(state, pbuf) - - call cnst_get_ind('CLDLIQ', ixcldliq) - call cnst_get_ind('CLDICE', ixcldice) - qini (:ncol,:pver) = state%q(:ncol,:pver, 1) - cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) - cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) - - call outfld('TEOUT', teout , pcols, lchnk ) - call outfld('TEINP', state%te_ini, pcols, lchnk ) - call outfld('TEFIX', state%te_cur, pcols, lchnk ) - - ! T tendency due to dynamics - if( nstep > dyn_time_lvls-1 ) then - dtcore(:ncol,:pver) = (state%t(:ncol,:pver) - dtcore(:ncol,:pver))/ztodt - call outfld( 'DTCORE', dtcore, pcols, lchnk ) - end if - - call t_stopf('energy_fixer') - ! - !=================================================== - ! Dry adjustment - ! This code block is not a good example of interfacing a parameterization - !=================================================== - call t_startf('dry_adjustment') - - call dadadj_tend(ztodt, state, ptend) - - call physics_update(state, ptend, ztodt, tend) - - call t_stopf('dry_adjustment') - - !=================================================== - ! Moist convection - !=================================================== - call t_startf('moist_convection') - - call t_startf ('convect_deep_tend') - - call convect_deep_tend( & - cmfmc, cmfcme, & - pflx, zdu, & - rliq, rice, & - ztodt, & - state, ptend, cam_in%landfrac, pbuf) - - call physics_update(state, ptend, ztodt, tend) - - call t_stopf('convect_deep_tend') - - call pbuf_get_field(pbuf, prec_dp_idx, prec_dp ) - call pbuf_get_field(pbuf, snow_dp_idx, snow_dp ) - call pbuf_get_field(pbuf, prec_sh_idx, prec_sh ) - call pbuf_get_field(pbuf, snow_sh_idx, snow_sh ) - call pbuf_get_field(pbuf, prec_str_idx, prec_str ) - call pbuf_get_field(pbuf, snow_str_idx, snow_str ) - call pbuf_get_field(pbuf, prec_sed_idx, prec_sed ) - call pbuf_get_field(pbuf, snow_sed_idx, snow_sed ) - call pbuf_get_field(pbuf, prec_pcw_idx, prec_pcw ) - call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) - - if (use_subcol_microp) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) - end if - - ! Check energy integrals, including "reserved liquid" - flx_cnd(:ncol) = prec_dp(:ncol) + rliq(:ncol) - snow_dp(:ncol) = snow_dp(:ncol) + rice(:ncol) - call check_energy_chng(state, tend, "convect_deep", nstep, ztodt, zero, flx_cnd, snow_dp, zero) - snow_dp(:ncol) = snow_dp(:ncol) - rice(:ncol) - - ! - ! Call Hack (1994) convection scheme to deal with shallow/mid-level convection - ! - call t_startf ('convect_shallow_tend') - - if (dlfzm_idx > 0) then - call pbuf_get_field(pbuf, dlfzm_idx, dlfzm) - dlf(:ncol,:) = dlfzm(:ncol,:) - else - dlf(:,:) = 0._r8 - end if - - call convect_shallow_tend (ztodt , cmfmc, & - dlf , dlf2 , rliq , rliq2, & - state , ptend , pbuf, cam_in) - call t_stopf ('convect_shallow_tend') - - call physics_update(state, ptend, ztodt, tend) - - flx_cnd(:ncol) = prec_sh(:ncol) + rliq2(:ncol) - call check_energy_chng(state, tend, "convect_shallow", nstep, ztodt, zero, flx_cnd, snow_sh, zero) - - call check_tracers_chng(state, tracerint, "convect_shallow", nstep, ztodt, zero_tracers) - - call t_stopf('moist_convection') - - ! Rebin the 4-bin version of sea salt into bins for coarse and accumulation - ! modes that correspond to the available optics data. This is only necessary - ! for CAM-RT. But it's done here so that the microphysics code which is called - ! from the stratiform interface has access to the same aerosols as the radiation - ! code. - call sslt_rebin_adv(pbuf, state) - - !=================================================== - ! Calculate tendencies from CARMA bin microphysics. - !=================================================== - ! - ! If CARMA is doing detrainment, then on output, rliq no longer represents water reserved - ! for detrainment, but instead represents potential snow fall. The mass and number of the - ! snow are stored in the physics buffer and will be incorporated by the MG microphysics. - ! - ! Currently CARMA cloud microphysics is only supported with the MG microphysics. - call t_startf('carma_timestep_tend') - - if (carma_do_cldice .or. carma_do_cldliq) then - call carma_timestep_tend(state, cam_in, cam_out, ptend, ztodt, pbuf, dlf=dlf, rliq=rliq, & - prec_str=prec_str, snow_str=snow_str, prec_sed=prec_sed_carma, snow_sed=snow_sed_carma) - call physics_update(state, ptend, ztodt, tend) - - ! Before the detrainment, the reserved condensate is all liquid, but if CARMA is doing - ! detrainment, then the reserved condensate is snow. - if (carma_do_detrain) then - call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str+rliq, snow_str+rliq, zero) - else - call check_energy_chng(state, tend, "carma_tend", nstep, ztodt, zero, prec_str, snow_str, zero) - end if - end if - - call t_stopf('carma_timestep_tend') - - if( microp_scheme == 'RK' ) then - - !=================================================== - ! Calculate stratiform tendency (sedimentation, detrain, cloud fraction and microphysics ) - !=================================================== - call t_startf('rk_stratiform_tend') - - call rk_stratiform_tend(state, ptend, pbuf, ztodt, & - cam_in%icefrac, cam_in%landfrac, cam_in%ocnfrac, & - cam_in%snowhland, & ! sediment - dlf, dlf2, & ! detrain - rliq , & ! check energy after detrain - cmfmc, & - cam_in%ts, cam_in%sst, zdu) - - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "cldwat_tend", nstep, ztodt, zero, prec_str, snow_str, zero) - - call t_stopf('rk_stratiform_tend') - - elseif( microp_scheme == 'MG' ) then - ! Start co-substepping of macrophysics and microphysics - cld_macmic_ztodt = ztodt/cld_macmic_num_steps - - ! Clear precip fields that should accumulate. - prec_sed_macmic = 0._r8 - snow_sed_macmic = 0._r8 - prec_pcw_macmic = 0._r8 - snow_pcw_macmic = 0._r8 - - do macmic_it = 1, cld_macmic_num_steps - - !=================================================== - ! Calculate macrophysical tendency (sedimentation, detrain, cloud fraction) - !=================================================== - - call t_startf('macrop_tend') - - ! don't call Park macrophysics if CLUBB is called - if (macrop_scheme .ne. 'CLUBB_SGS') then - - call macrop_driver_tend( & - state, ptend, cld_macmic_ztodt, & - cam_in%landfrac, cam_in%ocnfrac, cam_in%snowhland, & ! sediment - dlf, dlf2, & ! detrain - cmfmc, & - cam_in%ts, cam_in%sst, zdu, & - pbuf, det_s, det_ice) - - ! Since we "added" the reserved liquid back in this routine, we need - ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) - flx_heat(:ncol) = det_s(:ncol) - - ! Unfortunately, physics_update does not know what time period - ! "tend" is supposed to cover, and therefore can't update it - ! with substeps correctly. For now, work around this by scaling - ! ptend down by the number of substeps, then applying it for - ! the full time (ztodt). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "macrop_tend", nstep, ztodt, & - zero, flx_cnd(:ncol)/cld_macmic_num_steps, & - det_ice(:ncol)/cld_macmic_num_steps, & - flx_heat(:ncol)/cld_macmic_num_steps) - - else ! Calculate CLUBB macrophysics - - ! ===================================================== - ! CLUBB call (PBL, shallow convection, macrophysics) - ! ===================================================== - - call clubb_tend_cam(state,ptend,pbuf,cld_macmic_ztodt,& - cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & - dlf, det_s, det_ice) - - ! Since we "added" the reserved liquid back in this routine, we need - ! to account for it in the energy checker - flx_cnd(:ncol) = -1._r8*rliq(:ncol) - flx_heat(:ncol) = cam_in%shf(:ncol) + det_s(:ncol) - - ! Unfortunately, physics_update does not know what time period - ! "tend" is supposed to cover, and therefore can't update it - ! with substeps correctly. For now, work around this by scaling - ! ptend down by the number of substeps, then applying it for - ! the full time (ztodt). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - ! Update physics tendencies and copy state to state_eq, because that is - ! input for microphysics - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & - cam_in%lhf(:ncol)/latvap/cld_macmic_num_steps, & - flx_cnd(:ncol)/cld_macmic_num_steps, & - det_ice(:ncol)/cld_macmic_num_steps, & - flx_heat(:ncol)/cld_macmic_num_steps) - - endif - - call t_stopf('macrop_tend') - - !=================================================== - ! Calculate cloud microphysics - !=================================================== - - if (is_subcol_on()) then - ! Allocate sub-column structures. - call physics_state_alloc(state_sc, lchnk, psubcols*pcols) - call physics_tend_alloc(tend_sc, psubcols*pcols) - - ! Generate sub-columns using the requested scheme - call subcol_gen(state, tend, state_sc, tend_sc, pbuf) - - !Initialize check energy for subcolumns - call check_energy_timestep_init(state_sc, tend_sc, pbuf, col_type_subcol) - end if - - call t_startf('microp_aero_run') - call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) - call t_stopf('microp_aero_run') - - call t_startf('microp_tend') - - if (use_subcol_microp) then - call microp_driver_tend(state_sc, ptend_sc, cld_macmic_ztodt, pbuf) - - ! Average the sub-column ptend for use in gridded update - will not contain ptend_aero - call subcol_ptend_avg(ptend_sc, state_sc%ngrdcol, lchnk, ptend) - - ! Copy ptend_aero field to one dimensioned by sub-columns before summing with ptend - call subcol_ptend_copy(ptend_aero, state_sc, ptend_aero_sc) - call physics_ptend_sum(ptend_aero_sc, ptend_sc, state_sc%ncol) - call physics_ptend_dealloc(ptend_aero_sc) - - ! Have to scale and apply for full timestep to get tend right - ! (see above note for macrophysics). - call physics_ptend_scale(ptend_sc, 1._r8/cld_macmic_num_steps, ncol) - - call physics_update (state_sc, ptend_sc, ztodt, tend_sc) - call check_energy_chng(state_sc, tend_sc, "microp_tend_subcol", & - nstep, ztodt, zero_sc, & - prec_str_sc(:state_sc%ncol)/cld_macmic_num_steps, & - snow_str_sc(:state_sc%ncol)/cld_macmic_num_steps, zero_sc) - - call physics_state_dealloc(state_sc) - call physics_tend_dealloc(tend_sc) - call physics_ptend_dealloc(ptend_sc) - else - call microp_driver_tend(state, ptend, cld_macmic_ztodt, pbuf) - end if - ! combine aero and micro tendencies for the grid - call physics_ptend_sum(ptend_aero, ptend, ncol) - call physics_ptend_dealloc(ptend_aero) - - ! Have to scale and apply for full timestep to get tend right - ! (see above note for macrophysics). - call physics_ptend_scale(ptend, 1._r8/cld_macmic_num_steps, ncol) - - call physics_update (state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "microp_tend", nstep, ztodt, & - zero, prec_str(:ncol)/cld_macmic_num_steps, & - snow_str(:ncol)/cld_macmic_num_steps, zero) - - call t_stopf('microp_tend') - prec_sed_macmic(:ncol) = prec_sed_macmic(:ncol) + prec_sed(:ncol) - snow_sed_macmic(:ncol) = snow_sed_macmic(:ncol) + snow_sed(:ncol) - prec_pcw_macmic(:ncol) = prec_pcw_macmic(:ncol) + prec_pcw(:ncol) - snow_pcw_macmic(:ncol) = snow_pcw_macmic(:ncol) + snow_pcw(:ncol) - - end do ! end substepping over macrophysics/microphysics - - prec_sed(:ncol) = prec_sed_macmic(:ncol)/cld_macmic_num_steps - snow_sed(:ncol) = snow_sed_macmic(:ncol)/cld_macmic_num_steps - prec_pcw(:ncol) = prec_pcw_macmic(:ncol)/cld_macmic_num_steps - snow_pcw(:ncol) = snow_pcw_macmic(:ncol)/cld_macmic_num_steps - prec_str(:ncol) = prec_pcw(:ncol) + prec_sed(:ncol) - snow_str(:ncol) = snow_pcw(:ncol) + snow_sed(:ncol) - - endif - - ! Add the precipitation from CARMA to the precipitation from stratiform. - if (carma_do_cldice .or. carma_do_cldliq) then - prec_sed(:ncol) = prec_sed(:ncol) + prec_sed_carma(:ncol) - snow_sed(:ncol) = snow_sed(:ncol) + snow_sed_carma(:ncol) - end if - - if ( .not. deep_scheme_does_scav_trans() ) then - - ! ------------------------------------------------------------------------------- - ! 1. Wet Scavenging of Aerosols by Convective and Stratiform Precipitation. - ! 2. Convective Transport of Non-Water Aerosol Species. - ! - ! . Aerosol wet chemistry determines scavenging fractions, and transformations - ! . Then do convective transport of all trace species except qv,ql,qi. - ! . We needed to do the scavenging first to determine the interstitial fraction. - ! . When UNICON is used as unified convection, we should still perform - ! wet scavenging but not 'convect_deep_tend2'. - ! ------------------------------------------------------------------------------- - - call t_startf('bc_aerosols') - if (clim_modal_aero .and. .not. prog_modal_aero) then - call modal_aero_calcsize_diag(state, pbuf) - call modal_aero_wateruptake_dr(state, pbuf) - endif - call aero_model_wetdep( state, ztodt, dlf, cam_out, ptend, pbuf) - call physics_update(state, ptend, ztodt, tend) - - - if (carma_do_wetdep) then - ! CARMA wet deposition - ! - ! NOTE: It needs to follow aero_model_wetdep, so that cam_out%xxxwetxxx - ! fields have already been set for CAM aerosols and cam_out can be added - ! to for CARMA aerosols. - call t_startf ('carma_wetdep_tend') - call carma_wetdep_tend(state, ptend, ztodt, pbuf, dlf, cam_out) - call physics_update(state, ptend, ztodt, tend) - call t_stopf ('carma_wetdep_tend') - end if - - call t_startf ('convect_deep_tend2') - call convect_deep_tend_2( state, ptend, ztodt, pbuf ) - call physics_update(state, ptend, ztodt, tend) - call t_stopf ('convect_deep_tend2') - - ! check tracer integrals - call check_tracers_chng(state, tracerint, "cmfmca", nstep, ztodt, zero_tracers) - - call t_stopf('bc_aerosols') - - endif - - !=================================================== - ! Moist physical parameteriztions complete: - ! send dynamical variables, and derived variables to history file - !=================================================== - - call t_startf('bc_history_write') - call diag_phys_writeout(state, cam_out%psl) - call diag_conv(state, ztodt, pbuf) - - call t_stopf('bc_history_write') - - !=================================================== - ! Write cloud diagnostics on history file - !=================================================== - - call t_startf('bc_cld_diag_history_write') - - call cloud_diagnostics_calc(state, pbuf) - - call t_stopf('bc_cld_diag_history_write') - - !=================================================== - ! Radiation computations - !=================================================== - call t_startf('radiation') - - - call radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx) - - ! Set net flux used by spectral dycores - do i=1,ncol - tend%flx_net(i) = net_flx(i) - end do - call physics_update(state, ptend, ztodt, tend) - call check_energy_chng(state, tend, "radheat", nstep, ztodt, zero, zero, zero, net_flx) - - call t_stopf('radiation') - - ! Diagnose the location of the tropopause and its location to the history file(s). - call t_startf('tropopause') - call tropopause_output(state) - call t_stopf('tropopause') - - ! Save atmospheric fields to force surface models - call t_startf('cam_export') - call cam_export (state,cam_out,pbuf) - call t_stopf('cam_export') - - ! Write export state to history file - call t_startf('diag_export') - call diag_export(cam_out) - call t_stopf('diag_export') - - end subroutine tphysbc - -subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) -!----------------------------------------------------------------------------------- -! -! Purpose: The place for parameterizations to call per timestep initializations. -! Generally this is used to update time interpolated fields from boundary -! datasets. -! -!----------------------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 - use chemistry, only: chem_timestep_init - use chem_surfvals, only: chem_surfvals_set - use physics_types, only: physics_state - use physics_buffer, only: physics_buffer_desc - use carma_intr, only: carma_timestep_init - use ghg_data, only: ghg_data_timestep_init - use cam3_aero_data, only: cam3_aero_data_on, cam3_aero_data_timestep_init - use cam3_ozone_data, only: cam3_ozone_data_on, cam3_ozone_data_timestep_init - use aoa_tracers, only: aoa_tracers_timestep_init - use vertical_diffusion, only: vertical_diffusion_ts_init - use radheat, only: radheat_timestep_init - use solar_data, only: solar_data_advance - use qbo, only: qbo_timestep_init - use iondrag, only: do_waccm_ions, iondrag_timestep_init - use perf_mod - - use prescribed_ozone, only: prescribed_ozone_adv - use prescribed_ghg, only: prescribed_ghg_adv - use prescribed_aero, only: prescribed_aero_adv - use aerodep_flx, only: aerodep_flx_adv - use aircraft_emit, only: aircraft_emit_adv - use prescribed_volcaero, only: prescribed_volcaero_adv - use prescribed_strataero,only: prescribed_strataero_adv - use mo_apex, only: mo_apex_init - use epp_ionization, only: epp_ionization_active - use iop_forcing, only: scam_use_iop_srf - use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_stepinit - - implicit none - - type(physics_state), intent(inout), dimension(begchunk:endchunk) :: phys_state - type(cam_in_t), intent(inout), dimension(begchunk:endchunk) :: cam_in - type(cam_out_t), intent(inout), dimension(begchunk:endchunk) :: cam_out - - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - !----------------------------------------------------------------------------- - - if (single_column) call scam_use_iop_srf(cam_in) - - ! update geomagnetic coordinates - if (epp_ionization_active .or. do_waccm_ions) then - call mo_apex_init(phys_state) - endif - - ! Chemistry surface values - call chem_surfvals_set() - - ! Solar irradiance - call solar_data_advance() - - ! Time interpolate for chemistry. - call chem_timestep_init(phys_state, pbuf2d) - - ! Prescribed tracers - call prescribed_ozone_adv(phys_state, pbuf2d) - call prescribed_ghg_adv(phys_state, pbuf2d) - call prescribed_aero_adv(phys_state, pbuf2d) - call aircraft_emit_adv(phys_state, pbuf2d) - call prescribed_volcaero_adv(phys_state, pbuf2d) - call prescribed_strataero_adv(phys_state, pbuf2d) - - ! prescribed aerosol deposition fluxes - call aerodep_flx_adv(phys_state, pbuf2d, cam_out) - - ! CAM3 prescribed aerosol masses - if (cam3_aero_data_on) call cam3_aero_data_timestep_init(pbuf2d, phys_state) - - ! CAM3 prescribed ozone data - if (cam3_ozone_data_on) call cam3_ozone_data_timestep_init(pbuf2d, phys_state) - - ! Time interpolate data models of gasses in pbuf2d - call ghg_data_timestep_init(pbuf2d, phys_state) - - ! Upper atmosphere radiative processes - call radheat_timestep_init(phys_state, pbuf2d) - - ! Time interpolate for vertical diffusion upper boundary condition - call vertical_diffusion_ts_init(pbuf2d, phys_state) - - !---------------------------------------------------------------------- - ! update QBO data for this time step - !---------------------------------------------------------------------- - call qbo_timestep_init - - call iondrag_timestep_init() - - !---------------------------------------------------------------------- - ! update waccmx Te / Ti module - !---------------------------------------------------------------------- - call waccmx_phys_ion_elec_temp_stepinit() - - call carma_timestep_init() - - ! age of air tracers - call aoa_tracers_timestep_init(phys_state) - -end subroutine phys_timestep_init - -end module physpkg diff --git a/src/physics/cam/vertical_diffusion.F90 b/src/physics/cam/vertical_diffusion.F90 index 3fa31560d1..ee9b2f1ce1 100644 --- a/src/physics/cam/vertical_diffusion.F90 +++ b/src/physics/cam/vertical_diffusion.F90 @@ -1067,9 +1067,9 @@ subroutine vertical_diffusion_tend( & call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) - call outfld( 'qv_pre_PBL ', state%q(:ncol,:,1), pcols, lchnk ) - call outfld( 'ql_pre_PBL ', state%q(:ncol,:,ixcldliq), pcols, lchnk ) - call outfld( 'qi_pre_PBL ', state%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 'qv_pre_PBL ', state%q(:,:,1), pcols, lchnk ) + call outfld( 'ql_pre_PBL ', state%q(:,:,ixcldliq), pcols, lchnk ) + call outfld( 'qi_pre_PBL ', state%q(:,:,ixcldice), pcols, lchnk ) call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) @@ -1158,7 +1158,7 @@ subroutine vertical_diffusion_tend( & p_dry , state%t , rhoi_dry, ztodt , taux , & tauy , shflux , cflux , & kvh , kvm , kvq , cgs , cgh , & - state%zi , ksrftms , dragblj , & + state%zi , ksrftms , dragblj , & qmincg , fieldlist_dry , fieldlist_molec,& u_tmp , v_tmp , q_tmp , s_tmp , & tautmsx_temp , tautmsy_temp , dtk_temp , topflx_temp , errstring , & @@ -1417,12 +1417,11 @@ subroutine vertical_diffusion_tend( & call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) call outfld( 'slten_PBL' , slten, pcols, lchnk ) - call outfld( 'qtten_PBL' , qtten, pcols, lchnk ) - call outfld( 'uten_PBL' , ptend%u(:ncol,:), pcols, lchnk ) - call outfld( 'vten_PBL' , ptend%v(:ncol,:), pcols, lchnk ) - call outfld( 'qvten_PBL' , ptend%q(:ncol,:,1), pcols, lchnk ) - call outfld( 'qlten_PBL' , ptend%q(:ncol,:,ixcldliq), pcols, lchnk ) - call outfld( 'qiten_PBL' , ptend%q(:ncol,:,ixcldice), pcols, lchnk ) + call outfld( 'uten_PBL' , ptend%u(:,:), pcols, lchnk ) + call outfld( 'vten_PBL' , ptend%v(:,:), pcols, lchnk ) + call outfld( 'qvten_PBL' , ptend%q(:,:,1), pcols, lchnk ) + call outfld( 'qlten_PBL' , ptend%q(:,:,ixcldliq), pcols, lchnk ) + call outfld( 'qiten_PBL' , ptend%q(:,:,ixcldice), pcols, lchnk ) call outfld( 'tten_PBL' , tten, pcols, lchnk ) call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) @@ -1458,7 +1457,7 @@ subroutine vertical_diffusion_tend( & call outfld( 'DUV' , ptend%u, pcols, lchnk ) call outfld( 'DVV' , ptend%v, pcols, lchnk ) do m = 1, pcnst - call outfld( vdiffnam(m) , ptend%q(1,1,m), pcols, lchnk ) + call outfld( vdiffnam(m) , ptend%q(:,:,m), pcols, lchnk ) end do if( do_molec_diff ) then call outfld( 'TTPXMLC' , topflx, pcols, lchnk ) diff --git a/src/physics/spcam/spcam_drivers.F90 b/src/physics/spcam/spcam_drivers.F90 index 2c850286df..aad6cd79ac 100644 --- a/src/physics/spcam/spcam_drivers.F90 +++ b/src/physics/spcam/spcam_drivers.F90 @@ -1189,7 +1189,7 @@ subroutine spcam_radiation_finalize_m2005(cam_in, state, pbuf, rad_avgdata, cam_ call outfld('SOLLD'//' ',rad_avgdata%solld_m(:) ,pcols,lchnk) call outfld('FSN200'//' ',rad_avgdata%fsn200_m(:),pcols,lchnk) call outfld('FSN200C'//' ',rad_avgdata%fsn200c_m(:),pcols,lchnk) - call outfld('SWCF'//' ',rad_avgdata%fsntoa_m(:)-rad_avgdata%fsntoac_m(:) ,pcols,lchnk) + call outfld('SWCF'//' ',rad_avgdata%fsntoa_m(:)-rad_avgdata%fsntoac_m(:) ,ncol,lchnk) call outfld('FSNR'//' ',rad_avgdata%fsnr_m(:) ,pcols,lchnk) do i = 1, nnite diff --git a/src/physics/waccm/mo_aurora.F90 b/src/physics/waccm/mo_aurora.F90 index ac754294d1..68b7fd9aa7 100644 --- a/src/physics/waccm/mo_aurora.F90 +++ b/src/physics/waccm/mo_aurora.F90 @@ -5,7 +5,7 @@ module mo_aurora ! Auroral oval parameterization. See reference: ! R.G. Roble, E.C. Ridley ! An auroral model for the NCAR thermospheric general circulation model (TGCM) -! Annales Geophysicae,5A, (6), 369-382, 1987. +! Annales Geophysicae,5A, (6), 369-382, 1987. ! ! The aurora oval is a circle in auroral circle coordinates. Auroral circle ! coordinates are offset from magnetic coordinates by offa degrees (radians) @@ -46,7 +46,7 @@ module mo_aurora ! 1) sub aurora_cons called once per time step from advance. ! 2) sub aurora called from dynamics, inside parallel latitude scan. ! 3) subs aurora_cusp and aurora_heat called from sub aurora. -! 4) sub aurora_ions called from sub aurora. +! 4) sub aurora_ions called from sub aurora. ! !----------------------------------------------------------------------- @@ -71,7 +71,7 @@ module mo_aurora private public :: aurora_inti, aurora_timestep_init, aurora public :: aurora_register - + integer, parameter :: isouth = 1 integer, parameter :: inorth = 2 @@ -143,7 +143,7 @@ module mo_aurora contains - + !---------------------------------------------------------------------- !---------------------------------------------------------------------- subroutine aurora_register @@ -342,9 +342,9 @@ subroutine aurora_timestep_init( ) !----------------------------------------------------------------------- rh = (h2 - h1) / (h1 + h2) - h0 = 0.5_r8 * (h1 + h2) * d2r - - + h0 = 0.5_r8 * (h1 + h2) * d2r + + ! roth = MLT of max width of aurora in hours ! rote = MLT of max energy flux of aurora in hours @@ -471,14 +471,14 @@ subroutine aurora_prod( tn, o2, o1, mbar, rlats, & !----------------------------------------------------------------------- ! ... output mag lons, lats !----------------------------------------------------------------------- - call outfld( 'ALONM', r2d*alonm(:ncol,lchnk), pcols, lchnk ) - call outfld( 'ALATM', r2d*alatm(:ncol,lchnk), pcols, lchnk ) + call outfld( 'ALONM', r2d*alonm(:,lchnk), pcols, lchnk ) + call outfld( 'ALATM', r2d*alatm(:,lchnk), pcols, lchnk ) if (indxQTe>0) then call pbuf_get_field(pbuf, indxQTe, qteaur) qteaur(:) = 0._r8 endif - + !----------------------------------------------------------------------- ! aurora is active for columns poleward of 30 deg !----------------------------------------------------------------------- @@ -496,7 +496,7 @@ subroutine aurora_prod( tn, o2, o1, mbar, rlats, & do i = 1,ncol if( do_aurora(i) ) then dlat_aur(i) = alatm(i,lchnk) - dlon_aur(i) = alonm(i,lchnk) + rotation ! rotate it + dlon_aur(i) = alonm(i,lchnk) + rotation ! rotate it if( dlon_aur(i) > pi ) then dlon_aur(i) = dlon_aur(i) - twopi else if( dlon_aur(i) < -pi ) then @@ -654,7 +654,7 @@ subroutine aurora_hrate( tn, mbar, rlats, & do i = 1,ncol if( do_aurora(i) ) then dlat_aur(i) = alatm(i,lchnk) - dlon_aur(i) = alonm(i,lchnk) + rotation ! rotate it + dlon_aur(i) = alonm(i,lchnk) + rotation ! rotate it if( dlon_aur(i) > pi ) then dlon_aur(i) = dlon_aur(i) - twopi else if( dlon_aur(i) < -pi ) then @@ -709,7 +709,7 @@ subroutine aurora_hrate( tn, mbar, rlats, & call aurora_heat( flux, flux2, alfa, alfa2, & drizl, do_aurora, hemis, & alon, colat, ncol, pbuf ) - + !----------------------------------------------------------------------- ! ... auroral additions to ionization rates !----------------------------------------------------------------------- @@ -758,7 +758,7 @@ subroutine aurora_cusp( cusp, do_aurora, hemis, colat, alon, ncol ) cusp(:) = 0._r8 endwhere - end subroutine aurora_cusp + end subroutine aurora_cusp subroutine aurora_heat( flux, flux2, alfa, alfa2, & drizl, do_aurora, hemis, & @@ -767,7 +767,7 @@ subroutine aurora_heat( flux, flux2, alfa, alfa2, & ! ... calculate alfa, flux, and drizzle !----------------------------------------------------------------------- use physics_buffer,only: physics_buffer_desc,pbuf_get_field - + implicit none !----------------------------------------------------------------------- @@ -793,12 +793,12 @@ subroutine aurora_heat( flux, flux2, alfa, alfa2, & halfwidth, & ! oval half-width wrk, & ! temp wrk array dtheta ! latitudinal variation (Gaussian) - real(r8) :: ekev + real(r8) :: ekev real(r8), pointer :: amie_efxg(:) ! Pointer to pbuf AMIE energy flux (mW m-2) real(r8), pointer :: amie_kevg(:) ! Pointer to pbuf AMIE mean energy (keV) real(r8), pointer :: qteaur(:) ! for electron temperature integer :: n - + !----------------------------------------------------------------------- ! Low-energy protons: ! @@ -845,7 +845,7 @@ subroutine aurora_heat( flux, flux2, alfa, alfa2, & endwhere !----------------------------------------------------------------------- -! ... for electron temperature (used in settei): +! ... for electron temperature (used in settei): !----------------------------------------------------------------------- if (indxQTe>0) then call pbuf_get_field(pbuf, indxQTe, qteaur) @@ -949,14 +949,14 @@ subroutine aurora_ions( drizl, cusp, alfa1, alfa2, & real(r8) :: wrk(ncol,pver) real(r8), pointer :: aurIPRateSum(:,:) ! Pointer to pbuf auroral ion production sum for O2+,O+,N2+ (s-1 cm-3) - + qia(:) = 0._r8 wrk(:,:) = 0._r8 !----------------------------------------------------------- - ! Point to production rates array in physics buffer where - ! rates will be stored for ionosphere module access. Also, - ! initialize rates to zero before column loop since only + ! Point to production rates array in physics buffer where + ! rates will be stored for ionosphere module access. Also, + ! initialize rates to zero before column loop since only ! daylight values are filled !----------------------------------------------------------- if (indxAIPRS>0) then @@ -1036,15 +1036,15 @@ subroutine aurora_ions( drizl, cusp, alfa1, alfa2, & end do level_loop !---------------------------------------------------------------- - ! Store the sum of the ion production rates in pbuf to be used - ! in the ionosx module + ! Store the sum of the ion production rates in pbuf to be used + ! in the ionosx module !---------------------------------------------------------------- if (indxAIPRS>0) then - - aurIPRateSum(1:ncol,1:pver) = wrk(1:ncol,1:pver) - + + aurIPRateSum(1:ncol,1:pver) = wrk(1:ncol,1:pver) + endif - + call outfld( 'QSUM', wrk, ncol, lchnk ) end subroutine aurora_ions @@ -1160,9 +1160,9 @@ subroutine aion( si, so, do_aurora, ncol ) !----------------------------------------------------------------------- ! Calculates integrated f(x) needed for total auroral ionization. ! See equations (10-12) in Roble,1987. -! Coefficients for equation (12) of Roble,1987 are in variable cc +! Coefficients for equation (12) of Roble,1987 are in variable cc ! (revised since 1987): -! Uses the identity x**y = exp(y*ln(x)) for performance +! Uses the identity x**y = exp(y*ln(x)) for performance ! (fewer (1/2) trancendental functions are required). !------------------------------------------------------------------------ From 9cfc20e1636faf518a4237a1520f1b1ed81532b9 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 28 Jan 2024 10:33:27 +0100 Subject: [PATCH 69/71] updtes to have non oslo-aero code look identical to noresm2.1 --- src/physics/cam/micro_mg_data.F90 | 553 ++++++++++++++++++++++++++++++ 1 file changed, 553 insertions(+) create mode 100644 src/physics/cam/micro_mg_data.F90 diff --git a/src/physics/cam/micro_mg_data.F90 b/src/physics/cam/micro_mg_data.F90 new file mode 100644 index 0000000000..b37fd214f4 --- /dev/null +++ b/src/physics/cam/micro_mg_data.F90 @@ -0,0 +1,553 @@ +module micro_mg_data + +! +! Packing and time averaging for the MG interface. +! +! Use is as follows: +! +! 1) Figure out which columns will do averaging (mgncol) and the number of +! levels where the microphysics will run (nlev). +! +! 2) Create an MGPacker object and assign it as follows: +! +! packer = MGPacker(pcols, pver, mgcols, top_lev) +! +! Where [pcols, pver] is the shape of the ultimate input/output arrays +! that are defined at level midpoints. +! +! 3) Create a post-processing array of type MGPostProc: +! +! post_proc = MGPostProc(packer) +! +! 4) Add pairs of pointers for packed and unpacked representations, already +! associated with buffers of the correct dimensions: +! +! call post_proc%add_field(unpacked_pointer, packed_pointer, & +! fillvalue, accum_mean) +! +! The third value is the default value used to "unpack" for points with +! no "packed" part, and the fourth value is the method used to +! accumulate values over time steps. These two arguments can be omitted, +! in which case the default value will be 0 and the accumulation method +! will take the mean. +! +! 5) Use the packed fields in MG, and for each MG iteration, do: +! +! call post_proc%accumulate() +! +! 6) Perform final accumulation and scatter values into the unpacked arrays: +! +! call post_proc%process_and_unpack() +! +! 7) Destroy the object when complete: +! +! call post_proc%finalize() +! +! Caveat: MGFieldPostProc will hit a divide-by-zero error if you try to +! take the mean over 0 steps. +! + +! This include header defines CPP macros that only have an effect for debug +! builds. +#include "shr_assert.h" + +use shr_kind_mod, only: r8 => shr_kind_r8 +use shr_log_mod, only: & + errMsg => shr_log_errMsg, & + OOBMsg => shr_log_OOBMsg +use shr_sys_mod, only: shr_sys_abort + +implicit none +private + +public :: MGPacker +public :: MGFieldPostProc +public :: accum_null +public :: accum_mean +public :: MGPostProc + +type :: MGPacker + ! Unpacked array dimensions. + integer :: pcols + integer :: pver + ! Calculated packed dimensions, stored for convenience. + integer :: mgncol + integer :: nlev + ! Which columns are packed. + integer, allocatable :: mgcols(:) + ! Topmost level to copy into the packed array. + integer :: top_lev + contains + procedure, private :: pack_1D + procedure, private :: pack_2D + procedure, private :: pack_3D + generic :: pack => pack_1D, pack_2D, pack_3D + procedure :: pack_interface + procedure, private :: unpack_1D + procedure, private :: unpack_1D_array_fill + procedure, private :: unpack_2D + procedure, private :: unpack_2D_array_fill + procedure, private :: unpack_3D + procedure, private :: unpack_3D_array_fill + generic :: unpack => unpack_1D, unpack_1D_array_fill, & + unpack_2D, unpack_2D_array_fill, unpack_3D, unpack_3D_array_fill + procedure :: finalize => MGPacker_finalize +end type MGPacker + +interface MGPacker + module procedure new_MGPacker +end interface + +! Enum for time accumulation/averaging methods. +integer, parameter :: accum_null = 0 +integer, parameter :: accum_mean = 1 + +type :: MGFieldPostProc + integer :: accum_method = -1 + integer :: rank = -1 + integer :: num_steps = 0 + real(r8) :: fillvalue = 0._r8 + real(r8), pointer :: unpacked_1D(:) => null() + real(r8), pointer :: packed_1D(:) => null() + real(r8), allocatable :: buffer_1D(:) + real(r8), pointer :: unpacked_2D(:,:) => null() + real(r8), pointer :: packed_2D(:,:) => null() + real(r8), allocatable :: buffer_2D(:,:) + contains + procedure :: accumulate => MGFieldPostProc_accumulate + procedure :: process_and_unpack => MGFieldPostProc_process_and_unpack + procedure :: unpack_only => MGFieldPostProc_unpack_only + procedure :: finalize => MGFieldPostProc_finalize +end type MGFieldPostProc + +interface MGFieldPostProc + module procedure MGFieldPostProc_1D + module procedure MGFieldPostProc_2D +end interface MGFieldPostProc + +#define VECTOR_NAME MGFieldPostProcVec +#define TYPE_NAME type(MGFieldPostProc) +#define THROW(string) call shr_sys_abort(string) + +public :: VECTOR_NAME + +#include "dynamic_vector_typedef.inc" + +type MGPostProc + type(MGPacker) :: packer + type(MGFieldPostProcVec) :: field_procs + contains + procedure, private :: add_field_1D + procedure, private :: add_field_2D + generic :: add_field => add_field_1D, add_field_2D + procedure :: accumulate => MGPostProc_accumulate + procedure :: process_and_unpack => MGPostProc_process_and_unpack + procedure :: unpack_only => MGPostProc_unpack_only + procedure :: finalize => MGPostProc_finalize + procedure, private :: MGPostProc_copy + generic :: assignment(=) => MGPostProc_copy +end type MGPostProc + +interface MGPostProc + module procedure new_MGPostProc +end interface MGPostProc + +contains + +function new_MGPacker(pcols, pver, mgcols, top_lev) + integer, intent(in) :: pcols, pver + integer, intent(in) :: mgcols(:) + integer, intent(in) :: top_lev + + type(MGPacker) :: new_MGPacker + + new_MGPacker%pcols = pcols + new_MGPacker%pver = pver + new_MGPacker%mgncol = size(mgcols) + new_MGPacker%nlev = pver - top_lev + 1 + + allocate(new_MGPacker%mgcols(new_MGPacker%mgncol)) + new_MGPacker%mgcols = mgcols + new_MGPacker%top_lev = top_lev + +end function new_MGPacker + +! Rely on the fact that intent(out) forces the compiler to deallocate all +! allocatable components and restart the type from scratch. Although +! compiler support for finalization varies, this seems to be one of the few +! cases where all major compilers are reliable, and humans are not. +subroutine MGPacker_finalize(self) + class(MGPacker), intent(out) :: self +end subroutine MGPacker_finalize + +function pack_1D(self, unpacked) result(packed) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: unpacked(:) + + real(r8) :: packed(self%mgncol) + + SHR_ASSERT(size(unpacked) == self%pcols, errMsg(__FILE__, __LINE__)) + + packed = unpacked(self%mgcols) + +end function pack_1D + +! Separation of pack and pack_interface is to workaround a PGI bug. +function pack_2D(self, unpacked) result(packed) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: unpacked(:,:) + + real(r8) :: packed(self%mgncol,self%nlev) + + SHR_ASSERT(size(unpacked, 1) == self%pcols, errMsg(__FILE__, __LINE__)) + + packed = unpacked(self%mgcols,self%top_lev:) + +end function pack_2D + +function pack_interface(self, unpacked) result(packed) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: unpacked(:,:) + + real(r8) :: packed(self%mgncol,self%nlev+1) + + packed = unpacked(self%mgcols,self%top_lev:) + +end function pack_interface + +function pack_3D(self, unpacked) result(packed) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: unpacked(:,:,:) + + real(r8) :: packed(self%mgncol,self%nlev,size(unpacked, 3)) + + SHR_ASSERT(size(unpacked,1) == self%pcols, errMsg(__FILE__, __LINE__)) + + packed = unpacked(self%mgcols,self%top_lev:,:) + +end function pack_3D + +function unpack_1D(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:) + real(r8), intent(in) :: fill + + real(r8) :: unpacked(self%pcols) + + SHR_ASSERT(size(packed) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols) = packed + +end function unpack_1D + +function unpack_1D_array_fill(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:) + real(r8), intent(in) :: fill(:) + + real(r8) :: unpacked(self%pcols) + + SHR_ASSERT(size(packed) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols) = packed + +end function unpack_1D_array_fill + +function unpack_2D(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:,:) + real(r8), intent(in) :: fill + + real(r8) :: unpacked(self%pcols,self%pver+size(packed, 2)-self%nlev) + + SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols,self%top_lev:) = packed + +end function unpack_2D + +function unpack_2D_array_fill(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:,:) + real(r8), intent(in) :: fill(:,:) + + real(r8) :: unpacked(self%pcols,self%pver+size(packed, 2)-self%nlev) + + SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols,self%top_lev:) = packed + +end function unpack_2D_array_fill + +function unpack_3D(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:,:,:) + real(r8), intent(in) :: fill + + real(r8) :: unpacked(self%pcols,self%pver,size(packed, 3)) + + SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols,self%top_lev:,:) = packed + +end function unpack_3D + +function unpack_3D_array_fill(self, packed, fill) result(unpacked) + class(MGPacker), intent(in) :: self + real(r8), intent(in) :: packed(:,:,:) + real(r8), intent(in) :: fill(:,:,:) + + real(r8) :: unpacked(self%pcols,self%pver,size(packed, 3)) + + SHR_ASSERT(size(packed, 1) == self%mgncol, errMsg(__FILE__, __LINE__)) + + unpacked = fill + unpacked(self%mgcols,self%top_lev:,:) = packed + +end function unpack_3D_array_fill + +function MGFieldPostProc_1D(unpacked_ptr, packed_ptr, fillvalue, & + accum_method) result(field_proc) + real(r8), pointer, intent(in) :: unpacked_ptr(:) + real(r8), pointer, intent(in) :: packed_ptr(:) + real(r8), intent(in), optional :: fillvalue + integer, intent(in), optional :: accum_method + type(MGFieldPostProc) :: field_proc + + field_proc%rank = 1 + field_proc%unpacked_1D => unpacked_ptr + field_proc%packed_1D => packed_ptr + if (present(fillvalue)) then + field_proc%fillvalue = fillvalue + else + field_proc%fillvalue = 0._r8 + end if + if (present(accum_method)) then + field_proc%accum_method = accum_method + else + field_proc%accum_method = accum_mean + end if + +end function MGFieldPostProc_1D + +function MGFieldPostProc_2D(unpacked_ptr, packed_ptr, fillvalue, & + accum_method) result(field_proc) + real(r8), pointer, intent(in) :: unpacked_ptr(:,:) + real(r8), pointer, intent(in) :: packed_ptr(:,:) + real(r8), intent(in), optional :: fillvalue + integer, intent(in), optional :: accum_method + type(MGFieldPostProc) :: field_proc + + field_proc%rank = 2 + field_proc%unpacked_2D => unpacked_ptr + field_proc%packed_2D => packed_ptr + if (present(fillvalue)) then + field_proc%fillvalue = fillvalue + else + field_proc%fillvalue = 0._r8 + end if + if (present(accum_method)) then + field_proc%accum_method = accum_method + else + field_proc%accum_method = accum_mean + end if + +end function MGFieldPostProc_2D + +! Use the same intent(out) trick as for MGPacker, which is actually more +! useful here. +subroutine MGFieldPostProc_finalize(self) + class(MGFieldPostProc), intent(out) :: self +end subroutine MGFieldPostProc_finalize + +subroutine MGFieldPostProc_accumulate(self) + class(MGFieldPostProc), intent(inout) :: self + + select case (self%accum_method) + case (accum_null) + ! "Null" method does nothing. + case (accum_mean) + ! Allocation is done on the first accumulation step to allow the + ! MGFieldPostProc to be copied after construction without copying the + ! allocated array (until this function is first called). + self%num_steps = self%num_steps + 1 + select case (self%rank) + case (1) + SHR_ASSERT(associated(self%packed_1D), errMsg(__FILE__, __LINE__)) + if (.not. allocated(self%buffer_1D)) then + allocate(self%buffer_1D(size(self%packed_1D))) + self%buffer_1D = 0._r8 + end if + self%buffer_1D = self%buffer_1D + self%packed_1D + case (2) + SHR_ASSERT(associated(self%packed_2D), errMsg(__FILE__, __LINE__)) + if (.not. allocated(self%buffer_2D)) then + ! Awkward; in F2008 can be replaced by source/mold. + allocate(self%buffer_2D(& + size(self%packed_2D, 1),size(self%packed_2D, 2))) + self%buffer_2D = 0._r8 + end if + self%buffer_2D = self%buffer_2D + self%packed_2D + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unsupported rank for MGFieldPostProc accumulation.") + end select + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unrecognized MGFieldPostProc accumulation method.") + end select + +end subroutine MGFieldPostProc_accumulate + +subroutine MGFieldPostProc_process_and_unpack(self, packer) + class(MGFieldPostProc), intent(inout) :: self + class(MGPacker), intent(in) :: packer + + select case (self%accum_method) + case (accum_null) + ! "Null" method just leaves the value as the last time step, so don't + ! actually need to do anything. + case (accum_mean) + select case (self%rank) + case (1) + SHR_ASSERT(associated(self%packed_1D), errMsg(__FILE__, __LINE__)) + self%packed_1D = self%buffer_1D/self%num_steps + case (2) + SHR_ASSERT(associated(self%packed_2D), errMsg(__FILE__, __LINE__)) + self%packed_2D = self%buffer_2D/self%num_steps + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unsupported rank for MGFieldPostProc accumulation.") + end select + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unrecognized MGFieldPostProc accumulation method.") + end select + + call self%unpack_only(packer) + +end subroutine MGFieldPostProc_process_and_unpack + +subroutine MGFieldPostProc_unpack_only(self, packer) + class(MGFieldPostProc), intent(inout) :: self + class(MGPacker), intent(in) :: packer + + select case (self%rank) + case (1) + SHR_ASSERT(associated(self%unpacked_1D), errMsg(__FILE__, __LINE__)) + self%unpacked_1D = packer%unpack(self%packed_1D, self%fillvalue) + case (2) + SHR_ASSERT(associated(self%unpacked_2D), errMsg(__FILE__, __LINE__)) + self%unpacked_2D = packer%unpack(self%packed_2D, self%fillvalue) + case default + call shr_sys_abort(errMsg(__FILE__, __LINE__) // & + " Unsupported rank for MGFieldPostProc unpacking.") + end select + +end subroutine MGFieldPostProc_unpack_only + +#include "dynamic_vector_procdef.inc" + +function new_MGPostProc(packer) result(post_proc) + type(MGPacker), intent(in) :: packer + + type(MGPostProc) :: post_proc + + post_proc%packer = packer + call post_proc%field_procs%clear() + +end function new_MGPostProc + +! Can't use the same intent(out) trick, because PGI doesn't get the +! recursive deallocation right. +subroutine MGPostProc_finalize(self) + class(MGPostProc), intent(inout) :: self + + integer :: i + + call self%packer%finalize() + do i = 1, self%field_procs%vsize() + call self%field_procs%data(i)%finalize() + end do + call self%field_procs%clear() + call self%field_procs%shrink_to_fit() + +end subroutine MGPostProc_finalize + +subroutine add_field_1D(self, unpacked_ptr, packed_ptr, fillvalue, & + accum_method) + class(MGPostProc), intent(inout) :: self + real(r8), pointer, intent(in) :: unpacked_ptr(:) + real(r8), pointer, intent(in) :: packed_ptr(:) + real(r8), intent(in), optional :: fillvalue + integer, intent(in), optional :: accum_method + + call self%field_procs%push_back(MGFieldPostProc(unpacked_ptr, & + packed_ptr, fillvalue, accum_method)) + +end subroutine add_field_1D + +subroutine add_field_2D(self, unpacked_ptr, packed_ptr, fillvalue, & + accum_method) + class(MGPostProc), intent(inout) :: self + real(r8), pointer, intent(in) :: unpacked_ptr(:,:) + real(r8), pointer, intent(in) :: packed_ptr(:,:) + real(r8), intent(in), optional :: fillvalue + integer, intent(in), optional :: accum_method + + unpacked_ptr(:,:) = 0._r8 + packed_ptr(:,:) = 0._r8 + + call self%field_procs%push_back(MGFieldPostProc(unpacked_ptr, & + packed_ptr, fillvalue, accum_method)) + +end subroutine add_field_2D + +subroutine MGPostProc_accumulate(self) + class(MGPostProc), intent(inout) :: self + + integer :: i + + do i = 1, self%field_procs%vsize() + call self%field_procs%data(i)%accumulate() + end do + +end subroutine MGPostProc_accumulate + +subroutine MGPostProc_process_and_unpack(self) + class(MGPostProc), intent(inout) :: self + + integer :: i + + do i = 1, self%field_procs%vsize() + call self%field_procs%data(i)%process_and_unpack(self%packer) + end do + +end subroutine MGPostProc_process_and_unpack + +subroutine MGPostProc_unpack_only(self) + class(MGPostProc), intent(inout) :: self + + integer :: i + + do i = 1, self%field_procs%vsize() + call self%field_procs%data(i)%unpack_only(self%packer) + end do + +end subroutine MGPostProc_unpack_only + +! This is necessary only to work around Intel/PGI bugs. +subroutine MGPostProc_copy(lhs, rhs) + class(MGPostProc), intent(out) :: lhs + type(MGPostProc), intent(in) :: rhs + + lhs%packer = rhs%packer + lhs%field_procs = rhs%field_procs +end subroutine MGPostProc_copy + +end module micro_mg_data From f2f17af1613238e2b75dcce2255ae2126be268d3 Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Sun, 28 Jan 2024 10:41:58 +0100 Subject: [PATCH 70/71] udpates for noresm2_1_develop compatibility --- .../shell_commands | 2 + .../cmip6_noresm_fsst_xaer/shell_commands | 2 + src/NorESM/micro_mg2_0.F90 | 17 +- src/NorESM/physpkg.F90 | 14 +- src/chemistry/aerosol/mo_setsox.F90 | 85 +- src/chemistry/mozart/chemistry.F90 | 12 +- src/chemistry/mozart/mo_chm_diags.F90 | 198 +- src/chemistry/mozart/mo_drydep.F90 | 3 - src/chemistry/mozart/mo_gas_phase_chemdr.F90 | 75 +- src/chemistry/mozart/mo_neu_wetdep.F90 | 158 +- src/chemistry/mozart/mo_photo.F90 | 8 - src/chemistry/mozart/mo_setaer.F90 | 5 - src/chemistry/mozart/mo_srf_emissions.F90 | 20 - src/chemistry/mozart/mo_usrrxt.F90 | 10 +- src/control/runtime_opts.F90 | 14 - src/physics/cam/cam_diagnostics.F90 | 40 +- src/physics/cam/diffusion_solver.F90 | 989 ------ src/physics/cam/vertical_diffusion.F90 | 95 +- src/physics/cam/zm_microphysics.F90 | 3 +- src/physics/rrtmg/radiation.F90 | 2933 ++++++++--------- src/physics/rrtmg/radlw.F90 | 6 - src/physics/rrtmg/radsw.F90 | 32 +- 22 files changed, 1540 insertions(+), 3181 deletions(-) create mode 100755 cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/shell_commands create mode 100755 cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/shell_commands delete mode 100644 src/physics/cam/diffusion_solver.F90 diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/shell_commands b/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/shell_commands new file mode 100755 index 0000000000..0188a07e3c --- /dev/null +++ b/cime_config/usermods_dirs/cmip6_noresm_fsst_hifreq_xaer/shell_commands @@ -0,0 +1,2 @@ +# Turn on AEROCOM diagnostic output +./xmlchange AEROCOM=TRUE diff --git a/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/shell_commands b/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/shell_commands new file mode 100755 index 0000000000..0188a07e3c --- /dev/null +++ b/cime_config/usermods_dirs/cmip6_noresm_fsst_xaer/shell_commands @@ -0,0 +1,2 @@ +# Turn on AEROCOM diagnostic output +./xmlchange AEROCOM=TRUE diff --git a/src/NorESM/micro_mg2_0.F90 b/src/NorESM/micro_mg2_0.F90 index 7e2a64d0e0..f9276b699d 100644 --- a/src/NorESM/micro_mg2_0.F90 +++ b/src/NorESM/micro_mg2_0.F90 @@ -2079,9 +2079,16 @@ subroutine micro_mg_tend ( & nprc(i,k)*lcldm(i,k)+(nsubr(i,k)-npracs(i,k)-nnuccr(i,k) & -nnuccri(i,k)+nragg(i,k))*precip_frac(i,k) +!! In NorESM, there was an artificial limit on the number of ice particles. +!! By default, NorESM2.1 is using a 'corrected' ice delimiter +!! Uncomment the line below to recover the NorESM2 ice delimiter behavior +!! See the NorESM2.1 release notes for more information. +!#define NORESM2_ICE_DELIMITER +#ifndef NORESM2_ICE_DELIMITER ! make sure that ni at advanced time step does not exceed - ! maximum (existing N + source terms*dt), which is possible if mtime < deltat - ! note that currently mtime = deltat + ! maximum (existing N + source terms*dt), which is possible + ! if mtime < deltat + ! Note that currently mtime = deltat !================================================================ !shofer--- @@ -2095,6 +2102,12 @@ subroutine micro_mg_tend ( & nitend(i,k)=max(0._r8,(nimax(i,k)-ni(i,k))/deltat) end if !shofer--- +#else + if (do_cldice .and. nitend(i,k).gt.0._r8.and.ni(i,k)+nitend(i,k)*deltat.gt.nimax(i,k)) then + nitncons(i,k) = nitncons(i,k) + nitend(i,k)-max(0._r8,(nimax(i,k)-ni(i,k))/deltat) !AL + nitend(i,k)=max(0._r8,(nimax(i,k)-ni(i,k))/deltat) + end if +#endif end do diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index 52362a9782..8c65907950 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -68,8 +68,8 @@ module physpkg integer :: cldliqini_idx = 0 integer :: cldiceini_idx = 0 !AL - integer :: cldncini_idx = 0 - integer :: cldniini_idx = 0 + integer :: cldncini_idx = 0 + integer :: cldniini_idx = 0 !AK integer :: prec_str_idx = 0 integer :: snow_str_idx = 0 @@ -1348,7 +1348,7 @@ subroutine tphysac (ztodt, cam_in, & real(r8) :: tmp_cldni(pcols,pver) ! tmp space !AL - !tht: variables for dme_energy_adjust + !tht: variables for dme_energy_adjust real(r8):: eflx(pcols), dsema(pcols) logical, parameter:: ohf_adjust =.true. ! condensates have surface specific enthalpy @@ -1666,7 +1666,7 @@ subroutine tphysac (ztodt, cam_in, & !call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_cldliq, tmp_cldice, & ! qini, cldliqini, cldiceini) call diag_phys_tend_writeout (state, pbuf, tend, ztodt, tmp_q, tmp_t, tmp_cldliq, tmp_cldice, & - tmp_cldnc,tmp_cldni,qini, cldliqini, cldiceini, cldncini, cldniini, eflx, dsema ) + tmp_cldnc,tmp_cldni,qini, cldliqini, cldiceini, cldncini, cldniini, eflx, dsema ) !AL-tht call clybry_fam_set( ncol, lchnk, map2chm, state%q, pbuf ) @@ -2309,7 +2309,7 @@ subroutine tphysbc (ztodt, state, & call t_stopf('bc_aerosols') - end if + end if !=================================================== ! Moist physical parameteriztions complete: @@ -2440,8 +2440,10 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) call aircraft_emit_adv(phys_state, pbuf2d) call prescribed_volcaero_adv(phys_state, pbuf2d) call prescribed_strataero_adv(phys_state, pbuf2d) + #ifdef OSLO_AERO - call oslo_aero_ocean_time(phys_state, pbuf2d) + ! Ocean_species + call oslo_aero_ocean_adv(phys_state, pbuf2d) #endif ! prescribed aerosol deposition fluxes diff --git a/src/chemistry/aerosol/mo_setsox.F90 b/src/chemistry/aerosol/mo_setsox.F90 index eb53483dce..b994e32dd2 100644 --- a/src/chemistry/aerosol/mo_setsox.F90 +++ b/src/chemistry/aerosol/mo_setsox.F90 @@ -23,38 +23,30 @@ module MO_SETSOX contains -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- subroutine sox_inti - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... initialize the hetero sox routine - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- use mo_chem_utls, only : get_spc_ndx, get_inv_ndx use spmd_utils, only : masterproc use phys_control, only : phys_getopts -#ifdef OSLO_AERO - use oslo_aero_sox_cldaero, only : sox_cldaero_init -#else use sox_cldaero_mod, only : sox_cldaero_init -#endif + implicit none call phys_getopts( & prog_modal_aero_out=modal_aerosols ) -#ifdef OSLO_AERO - cloud_borne = .true. - modal_aerosols = .true. -#else - cloud_borne = modal_aerosols -#endif + cloud_borne = modal_aerosols !----------------------------------------------------------------- ! ... get species indicies !----------------------------------------------------------------- - + if (cloud_borne) then id_h2so4 = get_spc_ndx( 'H2SO4' ) else @@ -127,16 +119,16 @@ subroutine sox_inti write(iulog,*) 'mozart will do sox aerosols' write(iulog,*) '-----------------------------------------' endif - else + else return end if call sox_cldaero_init() end subroutine sox_inti - -!----------------------------------------------------------------------- -!----------------------------------------------------------------------- + +!----------------------------------------------------------------------- +!----------------------------------------------------------------------- subroutine SETSOX( & ncol, & lchnk, & @@ -163,7 +155,7 @@ subroutine SETSOX( & aqso4_o3_3d & ) - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... Compute heterogeneous reactions of SOX ! ! (0) using initial PH to calculate PH @@ -176,27 +168,22 @@ subroutine SETSOX( & ! (b) PARTIONING ! (c) REACTION rates ! (d) PREDICTION - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! use ppgrid, only : pcols, pver use chem_mods, only : gas_pcnst, nfs use chem_mods, only : adv_mass use physconst, only : mwdry, gravit use mo_constants, only : pi -#ifdef OSLO_AERO - use oslo_aero_sox_cldaero, only : sox_cldaero_update, sox_cldaero_create_obj, sox_cldaero_destroy_obj - use oslo_aero_sox_cldaero, only : cldaero_conc_t -#else use sox_cldaero_mod, only : sox_cldaero_update, sox_cldaero_create_obj, sox_cldaero_destroy_obj use cldaero_mod, only : cldaero_conc_t -#endif ! implicit none ! - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... Dummy arguments - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- integer, intent(in) :: ncol ! num of columns in chunk integer, intent(in) :: lchnk ! chunk id integer, intent(in) :: loffset ! offset of chem tracers in the advected tracers array @@ -223,11 +210,11 @@ subroutine SETSOX( & real(r8), intent(out), optional :: aqso4_o3_3d(:, :) ! 3D SO4 aqueous phase chemistry due to O3 (kg/m2) - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... Local variables ! ! xhno3 ... in mixing ratio - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- integer, parameter :: itermax = 20 real(r8), parameter :: ph0 = 5.0_r8 ! INITIAL PH VALUES real(r8), parameter :: const0 = 1.e3_r8/6.023e23_r8 @@ -262,10 +249,10 @@ subroutine SETSOX( & real(r8) :: hno3g(ncol,pver), nh3g(ncol,pver) ! - !----------------------------------------------------------------------- - ! for Ho2(g) -> H2o2(a) formation + !----------------------------------------------------------------------- + ! for Ho2(g) -> H2o2(a) formation ! schwartz JGR, 1984, 11589 - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- real(r8) :: kh4 ! kh2+kh3 real(r8) :: xam ! air density /cm3 real(r8) :: ho2s ! ho2s = ho2(a)+o2- @@ -316,7 +303,7 @@ subroutine SETSOX( & xph0 = 10._r8**(-ph0) ! initial PH value do k = 1,pver - cfact(:,k) = xhnm(:,k) & ! /cm3(a) + cfact(:,k) = xhnm(:,k) & ! /cm3(a) * 1.e6_r8 & ! /m3(a) * 1.38e-23_r8/287._r8 & ! Kg(a)/m3(a) * 1.e-3_r8 ! Kg(a)/L(a) @@ -377,13 +364,13 @@ subroutine SETSOX( & if (id_msa > 0) xmsa (:,k) = qin(:,k,id_msa) end do - + !----------------------------------------------------------------- ! ... Temperature dependent Henry constants !----------------------------------------------------------------- ver_loop0: do k = 1,pver !! pver loop for STEP 0 col_loop0: do i = 1,ncol - + if (cloud_borne .and. cldfrc(i,k)>0._r8) then xso4(i,k) = xso4c(i,k) / cldfrc(i,k) xnh4(i,k) = xnh4c(i,k) / cldfrc(i,k) @@ -599,7 +586,7 @@ subroutine SETSOX( & xph(i,k) = 10.0_r8**(-yph) converged = .true. exit - else + else ! do another iteration converged = .false. end if @@ -650,9 +637,9 @@ subroutine SETSOX( & patm = press(i,k)/101300._r8 ! press is in pascal xam = press(i,k)/(1.38e-23_r8*tz) ! air density /M3 - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- ! ... hno3 - !----------------------------------------------------------------------- + !----------------------------------------------------------------------- xk = 2.1e5_r8 *EXP( 8700._r8*work1(i) ) xe = 15.4_r8 hehno3(i,k) = xk*(1._r8 + xe/xph(i,k)) @@ -688,7 +675,7 @@ subroutine SETSOX( & heo3(i,k) = xk !------------------------------------------------------------------------ - ! ... for Ho2(g) -> H2o2(a) formation + ! ... for Ho2(g) -> H2o2(a) formation ! schwartz JGR, 1984, 11589 !------------------------------------------------------------------------ kh4 = (kh2 + kh3*kh1/xph(i,k)) / ((1._r8 + kh1/xph(i,k))**2) @@ -710,7 +697,7 @@ subroutine SETSOX( & endif !----------------------------------------------- - ! ... Partioning + ! ... Partioning !----------------------------------------------- !----------------------------------------------------------------- @@ -768,8 +755,8 @@ subroutine SETSOX( & !----------------------------------------------------------------- ! ... Prediction after aqueous phase ! so4 - ! When Cloud is present - ! + ! When Cloud is present + ! ! S(IV) + H2O2 = S(VI) ! S(IV) + O3 = S(VI) ! @@ -777,12 +764,12 @@ subroutine SETSOX( & ! (1) Seinfeld ! (2) Benkovitz !----------------------------------------------------------------- - + !............................ ! S(IV) + H2O2 = S(VI) !............................ - - IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED + + IF (XL .ge. 1.e-8_r8) THEN !! WHEN CLOUD IS PRESENTED if (cloud_borne) then patm_x = patm @@ -838,7 +825,7 @@ subroutine SETSOX( & xso2(i,k) = xso2(i,k) - ccc end if END IF - + if (modal_aerosols) then xdelso4hp(i,k) = xso4(i,k) - xso4_init(i,k) endif @@ -852,7 +839,7 @@ subroutine SETSOX( & * xl & ! [mole/L(a)/s] / const0 & ! [/L(a)/s] / xhnm(i,k) ! [mixing ratio/s] - + ccc = pso4*dtime ccc = max(ccc, 1.e-30_r8) @@ -875,7 +862,7 @@ subroutine SETSOX( & ncol, lchnk, loffset, dtime, mbar, pdel, press, tfld, cldnum, cldfrc, cfact, cldconc%xlwc, & xdelso4hp, xh2so4, xso4, xso4_init, nh3g, hno3g, xnh3, xhno3, xnh4c, xno3c, xmsa, xso2, xh2o2, qcw, qin, & aqso4, aqh2so4, aqso4_h2o2, aqso4_o3, aqso4_h2o2_3d=aqso4_h2o2_3d, aqso4_o3_3d=aqso4_o3_3d ) - + xphlwc(:,:) = 0._r8 do k = 1, pver do i = 1, ncol diff --git a/src/chemistry/mozart/chemistry.F90 b/src/chemistry/mozart/chemistry.F90 index 69eff7af52..653698fd1a 100644 --- a/src/chemistry/mozart/chemistry.F90 +++ b/src/chemistry/mozart/chemistry.F90 @@ -347,11 +347,7 @@ subroutine chem_readnl(nlfile) use tracer_cnst, only: tracer_cnst_defaultopts, tracer_cnst_setopts use tracer_srcs, only: tracer_srcs_defaultopts, tracer_srcs_setopts use aero_model, only: aero_model_readnl -#ifdef OSLO_AERO - use oslo_aero_dust, only: oslo_aero_dust_readnl -#else use dust_model, only: dust_readnl -#endif use gas_wetdep_opts, only: gas_wetdep_readnl use upper_bc, only: ubc_defaultopts, ubc_setopts use mo_drydep, only: drydep_srf_file @@ -670,11 +666,7 @@ subroutine chem_readnl(nlfile) tgcm_ubc_fixed_tod_in = tgcm_ubc_fixed_tod ) call aero_model_readnl(nlfile) -#ifdef OSLO_AERO - call oslo_aero_dust_readnl(nlfile) -#else call dust_readnl(nlfile) -#endif ! call gas_wetdep_readnl(nlfile) call gcr_ionization_readnl(nlfile) @@ -771,12 +763,12 @@ subroutine chem_init(phys_state, pbuf2d) use infnan, only : nan, assignment(=) use mo_chem_utls, only : get_spc_ndx use cam_abortutils, only : endrun + use aero_model, only : aero_model_init use mo_setsox, only : sox_inti use constituents, only : sflxnam use noy_ubc, only : noy_ubc_init use fire_emissions, only : fire_emissions_init use short_lived_species, only : short_lived_species_initic - use aero_model, only : aero_model_init type(physics_buffer_desc), pointer :: pbuf2d(:,:) type(physics_state), intent(in):: phys_state(begchunk:endchunk) @@ -982,13 +974,13 @@ end subroutine chem_init !================================================================================ !================================================================================ subroutine chem_emissions( state, cam_in ) + use aero_model, only: aero_model_emissions use camsrfexch, only: cam_in_t use constituents, only: sflxnam use cam_history, only: outfld use mo_srf_emissions, only: set_srf_emissions use cam_cpl_indices, only: index_x2a_Fall_flxvoc use fire_emissions, only: fire_emissions_srf - use aero_model, only: aero_model_emissions ! Arguments: diff --git a/src/chemistry/mozart/mo_chm_diags.F90 b/src/chemistry/mozart/mo_chm_diags.F90 index c695d91c99..daba95dfd1 100644 --- a/src/chemistry/mozart/mo_chm_diags.F90 +++ b/src/chemistry/mozart/mo_chm_diags.F90 @@ -49,9 +49,6 @@ module mo_chm_diags character(len=fieldname_len) :: depflx_name(gas_pcnst) character(len=fieldname_len) :: wetdep_name(gas_pcnst) character(len=fieldname_len) :: wtrate_name(gas_pcnst) -#ifdef OSLO_AERO - character(len=fieldname_len) :: wetdep_name_area(gas_pcnst) -#endif real(r8), parameter :: N_molwgt = 14.00674_r8 real(r8), parameter :: S_molwgt = 32.066_r8 @@ -68,10 +65,6 @@ subroutine chm_diags_inti use phys_control, only : phys_getopts use mo_drydep, only : has_drydep use species_sums_diags, only : species_sums_init -#ifdef OSLO_AERO - use oslo_aero_share, only: getCloudTracerIndexDirect, getCloudTracerName, isAerosol - use oslo_aero_params -#endif integer :: j, k, m, n character(len=16) :: jname, spc_name, attr @@ -102,12 +95,8 @@ subroutine chm_diags_inti logical :: history_cesm_forcing logical :: history_scwaccm_forcing logical :: history_chemspecies_srf ! output the chemistry constituents species in the surface layer - integer :: bulkaero_species(20) logical :: history_dust -#ifdef OSLO_AERO - integer :: cloudTracerIndex - character(len=20) :: cloudTracerName -#endif + integer :: bulkaero_species(20) !----------------------------------------------------------------------- @@ -388,40 +377,12 @@ subroutine chm_diags_inti call addfld( wtrate_name(m), (/ 'lev' /), 'A', '/s', spc_name//' wet deposition rate' ) endif -#ifdef OSLO_AERO - wetdep_name_area(m)='WD_A_'//trim(spc_name) - call addfld( wetdep_name_area(m), horiz_only, 'A', 'kg/m2/s ', spc_name//' wet deposition' ) - - !Needed for budget term of gases! Aerosols have their own budget terms - if (n.gt.0) then - if(.NOT. isAerosol(n))then - if(history_chemistry)then - call add_default( wetdep_name_area(m), 1, ' ') - end if - endif - end if -#endif - if (spc_name(1:3) == 'num') then unit_basename = ' 1' else unit_basename = 'kg' endif -#ifdef OSLO_AERO - if (n.gt.0) then - if ( any( aer_species == m ) .or. isAerosol(n) ) then - call addfld( spc_name, (/ 'lev' /), 'A', unit_basename//'/kg ', trim(attr)//' concentration') - call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', unit_basename//'/kg', trim(attr)//" in bottom layer") - else - call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') - call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") - endif - else - call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') - call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") - endif -#else if ( any( aer_species == m ) ) then call addfld( spc_name, (/ 'lev' /), 'A', unit_basename//'/kg ', trim(attr)//' concentration') call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', unit_basename//'/kg', trim(attr)//" in bottom layer") @@ -429,7 +390,6 @@ subroutine chm_diags_inti call addfld( spc_name, (/ 'lev' /), 'A', 'mol/mol', trim(attr)//' concentration') call addfld( trim(spc_name)//'_SRF', horiz_only, 'A', 'mol/mol', trim(attr)//" in bottom layer") endif -#endif if ((m /= id_cly) .and. (m /= id_bry)) then if (history_aerosol.or.history_chemistry) then @@ -471,61 +431,12 @@ subroutine chm_diags_inti if (m==id_cfc12 ) call add_default( spc_name, 1, ' ') endif -#ifdef OSLO_AERO - call add_default( spc_name, 1, ' ' ) - - !output 3d-field of aersol tracer in cloud water - if(n > 0) then - cloudTracerIndex = getCloudTracerIndexDirect(n) - if(cloudTracerIndex > 0)then - cloudTracerName(1:len(CloudTracerName))=" " - cloudTracerName = getCloudTracerName(n) - call addfld( trim(cloudTracerName), (/'lev'/), 'A','kg/kg', & - trim(cloudTracerName)//' in cloud water') - call add_default( trim(cloudTracerName), 1, ' ' ) - - !Add column burden of cloud tracers - call addfld('cb_'//trim(cloudTracerName),horiz_only, 'A', 'kg/m2', & - 'cb_'//trim(cloudTracerName)//' column in cloud water') - call add_default('cb_'//trim(cloudTracerName),1,' ') - endif - !..and column burden in clean air - call addfld('cb_'//trim(spc_name),horiz_only, 'A', 'kg/m2', & - 'cb_'//trim(spc_name)//' in column') - call add_default('cb_'//trim(spc_name),1,' ' ) - - if (history_aerosol)then - if (cloudTracerIndex > 0)then - !Output budget-terms for cloud borne aerosols - call add_default (trim(cloudTracerName)//'GVF', 1, ' ') - call add_default (trim(cloudTracerName)//'SFWET', 1, ' ') - call add_default (trim(cloudTracerName)//'TBF', 1, ' ') - call add_default (trim(cloudTracerName)//'DDF', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSBS', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSIC', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSBC', 1, ' ') - call add_default (trim(cloudTracerName)//'SFSIS', 1, ' ') - endif - endif - end if -#else if (history_dust .and. (index(spc_name,'dst_') > 0)) call add_default( spc_name, 1, ' ') -#endif enddo call addfld( 'MASS', (/ 'lev' /), 'A', 'kg', 'mass of grid box' ) call addfld( 'AREA', horiz_only, 'A', 'm2', 'area of grid box' ) -#ifdef OSLO_AERO - do n=1,N_AEROSOL_TYPES - call addfld('cb_'//trim(aerosol_type_name(n)),horiz_only, 'A', 'kg/m2',& - 'cb_'//trim(aerosol_type_name(n))//' column of aerosol type') - call add_default('cb_'//trim(aerosol_type_name(n)), 1, ' ') - call addfld('mmr_'//trim(aerosol_type_name(n)),(/'lev'/),'A','kg/kg' ,& - 'mmr_'//trim(aerosol_type_name(n))//' mmr of aerosol type') - call add_default('mmr_'//trim(aerosol_type_name(n)), 1, ' ') - end do -#endif call addfld( 'dry_deposition_NOy_as_N', horiz_only, 'I', 'kg/m2/s', 'NOy dry deposition flux ' ) call addfld( 'DF_SOX', horiz_only, 'I', 'kg/m2/s', 'SOx dry deposition flux ' ) @@ -549,14 +460,8 @@ subroutine chm_diags_inti end subroutine chm_diags_inti -#ifdef OSLO_AERO - subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depflx, mmr_tend, pdel, pmid, ltrop, & - wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx, pbuf) -#else subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depflx, mmr_tend, pdel, pmid, ltrop, & - wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx) -#endif - + wetdepflx, nhx_nitrogen_flx, noy_nitrogen_flx ) !-------------------------------------------------------------------- ! ... utility routine to output chemistry diagnostic variables !-------------------------------------------------------------------- @@ -564,15 +469,6 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf use cam_history, only : outfld use phys_grid, only : get_area_all_p use species_sums_diags, only : species_sums_output -#ifdef OSLO_AERO - use constituents, only : cnst_get_ind - use phys_grid, only : pcols - use physics_buffer, only : pbuf_get_field, pbuf_get_index - use physics_buffer, only : physics_buffer_desc - ! - use oslo_aero_share,only : getCloudTracerIndexDirect, getCloudTracerName, aerosolType, isAerosol - use oslo_aero_params -#endif ! ! CCMI ! @@ -596,23 +492,11 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf real(r8), intent(in) :: wetdepflx(ncol, gas_pcnst) real(r8), intent(out) :: nhx_nitrogen_flx(ncol) ! kgN/m2/sec real(r8), intent(out) :: noy_nitrogen_flx(ncol) ! kgN/m2/sec -#ifdef OSLO_AERO - type(physics_buffer_desc), pointer :: pbuf(:) -#endif !-------------------------------------------------------------------- ! ... local variables !-------------------------------------------------------------------- -#ifdef OSLO_AERO - real(r8), dimension(:,:), pointer :: cloudTracerField - integer :: cloudTracerIndex - character(len=20) :: cloudTracerName - real(r8) :: mass_tmp(pcols,pver) - real(r8) :: cb(pcols) - real(r8) :: cb_aerosol_type(pcols,N_AEROSOL_TYPES) !column burden aerosol types - real(r8) :: mmr_aerosol_type(pcols,pver,N_AEROSOL_TYPES) !concentration aerosol types -#endif - integer :: i, k, m, n + integer :: i, k, m real(r8) :: wrk(ncol,pver) ! real(r8) :: tmp(ncol,pver) ! real(r8) :: m(ncol,pver) @@ -627,9 +511,6 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf real(r8) :: area(ncol), mass(ncol,pver) real(r8) :: wgt -#ifdef OSLO_AERO - character(len=16) :: spc_name -#endif !-------------------------------------------------------------------- ! ... "diagnostic" groups @@ -666,10 +547,6 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf call outfld( 'AREA', area(:ncol), ncol, lchnk ) call outfld( 'MASS', mass(:ncol,:), ncol, lchnk ) -#ifdef OSLO_AERO - cb_aerosol_type(:,:) = 0.0_r8 - mmr_aerosol_type(:,:,:) = 0.0_r8 -#endif do m = 1,gas_pcnst !...FOY (counting Fluorines, not chlorines or bromines) @@ -749,51 +626,7 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf if ( any( hox_species == m ) ) then vmr_hox(:ncol,:) = vmr_hox(:ncol,:) + wgt * vmr(:ncol,:,m) endif - -#ifdef OSLO_AERO - spc_name = trim(solsym(m)) - call cnst_get_ind(spc_name, n, abort=.false.) - - if (n.gt.0) then - if ( any( aer_species == m ) .or. isAerosol(n) ) then - call outfld( solsym(m), mmr(:ncol,:,m), ncol ,lchnk ) - call outfld( trim(solsym(m))//'_SRF', mmr(:ncol,pver,m), ncol ,lchnk ) - else - call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) - call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) - endif - else - call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) - call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) - end if - - if (n > 0) then - cloudTracerIndex = getCloudTracerIndexDirect(n) - if (cloudTracerIndex > 0)then - cloudTracerName = getCloudTracerName(n) - call pbuf_get_field(pbuf, cloudTracerIndex, cloudTracerField ) - call outfld ( trim(cloudTracerName),cloudTracerField,pcols,lchnk) - - !Treat column burden (cloud tracer) - mass_tmp(:ncol,:) = cloudTracerField(:ncol,:) *pdel(:ncol,:) * rgrav - cb(:ncol) = sum(mass_tmp(:ncol,:),2) - call outfld(trim('cb_'//trim(cloudTracerName)), cb, pcols, lchnk) - endif - - !Treat column burden (normal tracer) - mass_tmp(:ncol,:) = mmr(:ncol,:,m) * pdel(:ncol,:) * rgrav - cb(:ncol) = sum(mass_tmp(:ncol,:),2) - call outfld(trim('cb_'//trim(spc_name)), cb, pcols, lchnk) - - ! Sum column burden per aerosol type - if(aerosolType(n) .gt. 0)then - cb_aerosol_type(:ncol,aerosolType(n)) = cb_aerosol_type(:ncol,aerosolType(n)) + cb(:ncol) - - !Total mass mixing ratio of aerosol type - mmr_aerosol_type(:ncol,:,aerosolType(n)) = mmr_aerosol_type(:ncol,:,aerosolType(n)) + mmr(:ncol,:,m) - endif - end if !Check if this is a chemistry tracer -#else + if ( any( aer_species == m ) ) then call outfld( solsym(m), mmr(:ncol,:,m), ncol ,lchnk ) call outfld( trim(solsym(m))//'_SRF', mmr(:ncol,pver,m), ncol ,lchnk ) @@ -801,7 +634,6 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf call outfld( solsym(m), vmr(:ncol,:,m), ncol ,lchnk ) call outfld( trim(solsym(m))//'_SRF', vmr(:ncol,pver,m), ncol ,lchnk ) endif -#endif call outfld( depvel_name(m), depvel(:ncol,m), ncol ,lchnk ) call outfld( depflx_name(m), depflx(:ncol,m), ncol ,lchnk ) @@ -868,12 +700,7 @@ subroutine chm_diags( lchnk, ncol, vmr, mmr, rxt_rates, invariants, depvel, depf ! enddo -#ifdef OSLO_AERO - do n=1,N_AEROSOL_TYPES - call outfld("mmr_"//trim(aerosol_type_name(n)), mmr_aerosol_type(:ncol,:,n), ncol,lchnk) - call outfld("cb_"//trim(aerosol_type_name(n)), cb_aerosol_type(:ncol,n), ncol,lchnk) - enddo -#endif + call outfld( 'NOX', vmr_nox (:ncol,:), ncol, lchnk ) call outfld( 'NOY', vmr_noy (:ncol,:), ncol, lchnk ) call outfld( 'HOX', vmr_hox (:ncol,:), ncol, lchnk ) @@ -1003,11 +830,7 @@ end subroutine chm_diags subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) use cam_history, only : outfld -#ifdef OSLO_AERO - use phys_grid, only : get_wght_all_p, get_area_all_p -#else use phys_grid, only : get_wght_all_p -#endif integer, intent(in) :: lchnk integer, intent(in) :: ncol @@ -1016,9 +839,6 @@ subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) real(r8), intent(in) :: pdel(ncol,pver) real(r8), dimension(ncol) :: noy_wk, sox_wk, nhx_wk, wrk_wd -#ifdef OSLO_AERO - real(r8), dimension(ncol) :: area -#endif integer :: m, k real(r8) :: wght(ncol) ! @@ -1028,11 +848,6 @@ subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) sox_wk(:) = 0._r8 nhx_wk(:) = 0._r8 -#ifdef OSLO_AERO - call get_area_all_p(lchnk, ncol, area) - area = area * rearth**2 -#endif - call get_wght_all_p(lchnk, ncol, wght) do m = 1,gas_pcnst @@ -1048,9 +863,6 @@ subroutine het_diags( het_rates, mmr, pdel, lchnk, ncol ) ! if (gas_wetdep_method=='MOZ') then call outfld( wetdep_name(m), wrk_wd(:ncol), ncol, lchnk ) -#ifdef OSLO_AERO - call outfld( wetdep_name_area(m), wrk_wd(:ncol)/area(:ncol) ,ncol, lchnk ) -#endif call outfld( wtrate_name(m), het_rates(:ncol,:,m), ncol, lchnk ) if ( any(noy_species == m ) ) then diff --git a/src/chemistry/mozart/mo_drydep.F90 b/src/chemistry/mozart/mo_drydep.F90 index e81f3d66f7..9241af802e 100644 --- a/src/chemistry/mozart/mo_drydep.F90 +++ b/src/chemistry/mozart/mo_drydep.F90 @@ -1616,9 +1616,6 @@ subroutine dvel_inti_xactive( depvel_lnd_file, clim_soilw_file, season_wes_file ! determine if modal aerosols are active so that fraction_landuse array is initialized for modal aerosal dry dep call phys_getopts(prog_modal_aero_out=prog_modal_aero) -#ifdef OSLO_AERO - prog_modal_aero = .TRUE. -#endif call dvel_inti_fromlnd() diff --git a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 index 5ebeb676a3..71a380f16b 100644 --- a/src/chemistry/mozart/mo_gas_phase_chemdr.F90 +++ b/src/chemistry/mozart/mo_gas_phase_chemdr.F90 @@ -6,11 +6,7 @@ module mo_gas_phase_chemdr use cam_history, only : fieldname_len use chem_mods, only : phtcnt, rxntot, gas_pcnst use chem_mods, only : rxt_tag_cnt, rxt_tag_lst, rxt_tag_map, extcnt, num_rnts -#ifdef OSLO_AERO - use oslo_aero_dust, only : dust_names, ndust => dust_nbin -#else use dust_model, only : dust_names, ndust => dust_nbin -#endif use ppgrid, only : pcols, pver use phys_control, only : phys_getopts use carma_flags_mod, only : carma_hetchem_feedback @@ -30,10 +26,6 @@ module mo_gas_phase_chemdr integer :: het1_ndx integer :: ndx_cldfr, ndx_cmfdqr, ndx_nevapr, ndx_cldtop, ndx_prain integer :: ndx_h2so4 -#ifdef OSLO_AERO - logical :: inv_o3, inv_oh, inv_no3, inv_ho2 - integer :: id_o3, id_oh, id_no3, id_ho2 -#endif ! ! CCMI ! @@ -61,11 +53,7 @@ module mo_gas_phase_chemdr subroutine gas_phase_chemdr_inti() -#ifdef OSLO_AERO - use mo_chem_utls, only : get_spc_ndx, get_extfrc_ndx, get_rxt_ndx, get_inv_ndx -#else use mo_chem_utls, only : get_spc_ndx, get_extfrc_ndx, get_rxt_ndx -#endif use cam_history, only : addfld,add_default,horiz_only use mo_chm_diags, only : chm_diags_inti use constituents, only : cnst_get_ind @@ -86,25 +74,6 @@ subroutine gas_phase_chemdr_inti() call phys_getopts( convproc_do_aer_out = convproc_do_aer, history_cesm_forcing_out=history_cesm_forcing ) -#ifdef OSLO_AERO - inv_o3 = get_inv_ndx('O3') > 0 - inv_oh = get_inv_ndx('OH') > 0 - inv_no3 = get_inv_ndx('NO3') > 0 - inv_ho2 = get_inv_ndx('HO2') > 0 - if (inv_o3) then - id_o3 = get_inv_ndx('O3') - endif - if (inv_oh) then - id_oh = get_inv_ndx('OH') - endif - if (inv_no3) then - id_no3 = get_inv_ndx('NO3') - endif - if (inv_ho2) then - id_ho2 = get_inv_ndx('HO2') - endif -#endif - ndx_h2so4 = get_spc_ndx('H2SO4') ! ! CCMI @@ -231,23 +200,6 @@ subroutine gas_phase_chemdr_inti() call addfld( 'HCL_GAS', (/ 'lev' /), 'I', 'mol/mol', 'gas-phase hcl' ) call addfld( 'HCL_STS', (/ 'lev' /), 'I', 'mol/mol', 'STS condensed HCL' ) -#ifdef OSLO_AERO - ! Adding extra fields for oxi-output (before and after diurnal variations.) - call addfld ('OH_bef ', (/ 'lev' /), 'A','unit', 'OH invariants before adding diurnal variations' ) - call addfld ('HO2_bef ', (/ 'lev' /), 'A','unit', 'HO2 invariants before adding diurnal variations' ) - call addfld ('NO3_bef ', (/ 'lev' /), 'A','unit', 'NO3 invariants before adding diurnal variations' ) - call addfld ('OH_aft ', (/ 'lev' /), 'A','unit', 'OH invariants after adding diurnal variations' ) - call addfld ('HO2_aft ', (/ 'lev' /), 'A','unit', 'HO2 invariants after adding diurnal variations' ) - call addfld ('NO3_aft ', (/ 'lev' /), 'A','unit', 'NO3 invariants after adding diurnal variations' ) - - call add_default ('OH_bef ', 1, ' ') - call add_default ('HO2_bef ', 1, ' ') - call add_default ('NO3_bef ', 1, ' ') - call add_default ('OH_aft ', 1, ' ') - call add_default ('HO2_aft ', 1, ' ') - call add_default ('NO3_aft ', 1, ' ') -#endif - if (het1_ndx>0) then call addfld( 'het1_total', (/ 'lev' /), 'I', '/s', 'total N2O5 + H2O het rate constant' ) endif @@ -343,9 +295,6 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & use mo_chm_diags, only : chm_diags, het_diags use perf_mod, only : t_startf, t_stopf use gas_wetdep_opts, only : gas_wetdep_method -#ifdef OSLO_AERO - use oslo_aero_diurnal_var, only : set_diurnal_invariants -#endif use physics_buffer, only : physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx use infnan, only : nan, assignment(=) use rate_diags, only : rate_diags_calc @@ -360,6 +309,7 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & ! for aqueous chemistry and aerosol growth ! use aero_model, only : aero_model_gasaerexch + use aero_model, only : aero_model_strat_surfarea implicit none @@ -672,21 +622,6 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & !----------------------------------------------------------------------- call setinv( invariants, tfld, h2ovmr, vmr, pmid, ncol, lchnk, pbuf ) -#ifdef OSLO_AERO - !----------------------------------------------------------------------- - ! ... Set the "day/night cycle for prescribed oxidants" - !----------------------------------------------------------------------- - call outfld('OH_bef', invariants(:,:,id_oh), ncol, lchnk) - call outfld('HO2_bef', invariants(:,:,id_ho2), ncol, lchnk) - call outfld('NO3_bef', invariants(:,:,id_no3), ncol, lchnk) - - if (inv_oh.or.inv_ho2.or.inv_no3) & !++IH: added inv_no3 - call set_diurnal_invariants(invariants,delt,ncol,lchnk,inv_oh,inv_ho2,id_oh,id_ho2,inv_no3,id_no3) !++IH: added inv_no3 and id_no3 - - call outfld('OH_aft', invariants(:,:,id_oh), ncol, lchnk) - call outfld('HO2_aft', invariants(:,:,id_ho2), ncol, lchnk) - call outfld('NO3_aft', invariants(:,:,id_no3), ncol, lchnk) -#endif !----------------------------------------------------------------------- ! ... stratosphere aerosol surface area !----------------------------------------------------------------------- @@ -1183,17 +1118,11 @@ subroutine gas_phase_chemdr(lchnk, ncol, imozart, q, & endif end do -#ifdef OSLO_AERO - call chm_diags( lchnk, ncol, vmr(:ncol,:,:), mmr_new(:ncol,:,:), & - reaction_rates(:ncol,:,:), invariants(:ncol,:,:), depvel(:ncol,:), sflx(:ncol,:), & - mmr_tend(:ncol,:,:), pdel(:ncol,:), pmid(:ncol,:), troplev(:ncol), wetdepflx_diag(:ncol,:), & - nhx_nitrogen_flx(:ncol), noy_nitrogen_flx(:ncol), pbuf ) -#else call chm_diags( lchnk, ncol, vmr(:ncol,:,:), mmr_new(:ncol,:,:), & reaction_rates(:ncol,:,:), invariants(:ncol,:,:), depvel(:ncol,:), sflx(:ncol,:), & mmr_tend(:ncol,:,:), pdel(:ncol,:), pmid(:ncol,:), troplev(:ncol), wetdepflx_diag(:ncol,:), & nhx_nitrogen_flx(:ncol), noy_nitrogen_flx(:ncol) ) -#endif + call rate_diags_calc( reaction_rates(:,:,:), vmr(:,:,:), invariants(:,:,indexm), ncol, lchnk ) ! ! jfl diff --git a/src/chemistry/mozart/mo_neu_wetdep.F90 b/src/chemistry/mozart/mo_neu_wetdep.F90 index 88c354b7d9..b187b83e69 100644 --- a/src/chemistry/mozart/mo_neu_wetdep.F90 +++ b/src/chemistry/mozart/mo_neu_wetdep.F90 @@ -14,10 +14,6 @@ module mo_neu_wetdep use cam_abortutils, only : endrun use seq_drydep_mod, only : n_species_table, species_name_table, dheff use gas_wetdep_opts, only : gas_wetdep_method, gas_wetdep_list, gas_wetdep_cnt -#ifdef OSLO_AERO - use mo_constants, only: rgrav - use phys_control, only: phys_getopts -#endif ! implicit none ! @@ -93,7 +89,7 @@ subroutine neu_wetdep_init select case( trim(test_name) ) ! ! CCMI: added SO2t and NH_50W -! +! case( 'HYAC', 'CH3COOH' , 'HCOOH', 'EOOH', 'IEPOX' ) test_name = 'CH2O' case ( 'SOGB','SOGI','SOGM','SOGT','SOGX' ) @@ -102,10 +98,10 @@ subroutine neu_wetdep_init test_name = 'SO2' case ( 'CLONO2','BRONO2','HCL','HOCL','HOBR','HBR', 'Pb', 'MACROOH', 'ISOPOOH', 'XOOH', 'H2SO4', 'HF', 'COF2', 'COFCL') test_name = 'HNO3' - case ( 'NH_50W', 'NDEP', 'NHDEP', 'NH4', 'NH4NO3' ) + case ( 'NH_50W', 'NDEP', 'NHDEP', 'NH4', 'NH4NO3' ) test_name = 'HNO3' case ( 'ALKOOH', 'MEKOOH', 'TOLOOH' ) - test_name = 'CH3OOH' + test_name = 'CH3OOH' case( 'PHENOOH', 'BENZOOH', 'C6H5OOH', 'BZOOH', 'XYLOLOOH', 'XYLENOOH', 'HPALD' ) test_name = 'CH3OOH' case( 'TERPOOH', 'TERP2OOH', 'MBOOOH' ) @@ -119,15 +115,15 @@ subroutine neu_wetdep_init case( 'NC4CHO', 'NC4CH2OH', 'TERPNIT', 'NTERPOOH' ) test_name = 'H2O2' case( 'SOAGbb0' ) ! Henry's Law coeff. added for VBS SOA's, biomass burning is the same as fossil fuels - test_name = 'SOAGff0' + test_name = 'SOAGff0' case( 'SOAGbb1' ) - test_name = 'SOAGff1' + test_name = 'SOAGff1' case( 'SOAGbb2' ) - test_name = 'SOAGff2' + test_name = 'SOAGff2' case( 'SOAGbb3' ) - test_name = 'SOAGff3' + test_name = 'SOAGff3' case( 'SOAGbb4' ) - test_name = 'SOAGff4' + test_name = 'SOAGff4' end select ! do l = 1,n_species_table @@ -158,7 +154,7 @@ subroutine neu_wetdep_init end if ! end do - + if (any ( mapping_to_heff(:) == -99 )) call endrun('mo_neu_wet->depwetdep_init: unmapped species error' ) ! if ( debug ) then @@ -231,7 +227,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & prain, nevapr, cld, cmfdqr, wd_tend, wd_tend_int) ! use ppgrid, only : pcols, pver -!!DEK +!!DEK use phys_grid, only : get_area_all_p, get_rlat_all_p use shr_const_mod, only : SHR_CONST_REARTH,SHR_CONST_G use cam_history, only : outfld @@ -280,11 +276,6 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & !!DEK real(r8) :: pi real(r8) :: lats(pcols) - -#ifdef OSLO_AERO - real(r8) :: wrk_wd(pcols) - logical history_aerosol -#endif ! ! from cam/src/physics/cam/stratiform.F90 ! @@ -349,7 +340,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & do k=pver-1,1,-1 rls (:,k) = max(0._r8,totprec(:,k)-totevap(:,k)+rls(:,k+1)) !evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+totprec(:,k)+1.e-36_r8)) - evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+1.e-36_r8)) + evaprate(:,k) = min(1._r8,totevap(:,k)/(rls(:,k+1)+1.e-36_r8)) end do ! ! compute effective Henry's law coefficients @@ -443,7 +434,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & ! tendency calculation (on model grid) ! dtwr(1:ncol,:,:) = wd_mmr(1:ncol,:,:) - dtwr(1:ncol,:,:) - dtwr(1:ncol,:,:) = dtwr(1:ncol,:,:) / delt + dtwr(1:ncol,:,:) = dtwr(1:ncol,:,:) / delt !!DEK polarward of 60S, 60N and <200hPa set to zero! call get_rlat_all_p(lchnk, pcols, lats ) @@ -452,7 +443,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & if ( abs( lats(i)*180._r8/pi ) > 60._r8 ) then if ( pmid(i,k) < 20000._r8) then dtwr(i,k,:) = 0._r8 - endif + endif endif end do end do @@ -462,7 +453,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & do m=1,gas_wetdep_cnt wd_tend(1:ncol,:,mapping_to_mmr(m)) = wd_tend(1:ncol,:,mapping_to_mmr(m)) + dtwr(1:ncol,:,m) call outfld( 'DTWR_'//trim(gas_wetdep_list(m)),dtwr(:,:,m),ncol,lchnk ) - + call outfld( 'HEFF_'//trim(gas_wetdep_list(m)),heff(:,pver:1:-1,m),ncol,lchnk ) ! ! vertical integrated wet deposition rate [kg/m2/s] @@ -479,24 +470,7 @@ subroutine neu_wetdep_tend(lchnk,ncol,mmr,pmid,pdel,zint,tfld,delt, & if ( debug) print *,'mo_neu ',mapping_to_mmr(m),(wk_out(1:ncol)) wd_tend_int(1:ncol,mapping_to_mmr(m)) = wk_out(1:ncol) ! - end do - -!This is output normally in mo_chm_diags, but -!if neu wetdep, we have to output it here! -#ifdef OSLO_AERO - call phys_getopts( history_aerosol_out = history_aerosol) - if(history_aerosol)then - do m=1,gas_wetdep_cnt - wrk_wd(:ncol) = 0.0_r8 - do k=1,pver - !Note sign: tendency is negative, so this becomes a positive flux! - wrk_wd(:ncol) = wrk_wd(:ncol) & - - wd_tend(1:ncol,k,mapping_to_mmr(m))*pdel(:ncol,k)*rgrav !kg/m2/sec - end do - call outfld('WD_A_'//trim(gas_wetdep_list(m)),wrk_wd(:ncol),ncol,lchnk) - end do - end if -#endif + end do ! if ( do_diag ) then call outfld('QT_RAIN_HNO3', qt_rain, ncol, lchnk ) @@ -530,14 +504,14 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & !-LAER could be used as LWASHTYP !---WILL THIS WORK FOR T42->T21??????????? !----------------------------------------------------------------------- - + integer LPAR, NTRACE real(r8), intent(inout) :: QTTJFL(LPAR,NTRACE) real(r8), intent(in) :: DTSCAV, QM(LPAR),POFL(LPAR),DELZ(LPAR),GAREA real(r8), intent(in) :: RLS(LPAR),CLWC(LPAR),CIWC(LPAR),CFR(LPAR),TEM(LPAR), & EVAPRATE(LPAR) real(r8), intent(in) :: HSTAR(LPAR,NTRACE),TCMASS(NTRACE) - logical , intent(in) :: TCKAQB(NTRACE),TCNION(NTRACE) + logical , intent(in) :: TCKAQB(NTRACE),TCNION(NTRACE) ! real(r8), intent(inout) :: qt_rain(lpar) real(r8), intent(inout) :: qt_rime(lpar) @@ -572,7 +546,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & real(r8) QTNETLCXA,QTNETLCXB,QTNETLAX,QTNETL real(r8) QTDISSTAR - + real(r8), parameter :: CFMIN=0.1_r8 real(r8), parameter :: CWMIN=1.0e-5_r8 @@ -625,9 +599,9 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & end if !----------------------------------------------------------------------- - LE = LPAR-1 + LE = LPAR-1 ! - rls_flag(1:le) = rls(1:le) > zero + rls_flag(1:le) = rls(1:le) > zero freezing(1:le) = tem(1:le) < tice rlsog(1:le) = rls(1:le)/garea ! @@ -724,7 +698,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & QTWASHCXA = zero QTRAINCXA = zero QTRAINCXB = zero - + RAMPCT = zero RCXPCT = zero @@ -892,7 +866,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & endif !----------------------------------------------------------------------- ! If there is some in-cloud precip left, we have new precip formation -! Will be spread over whole cloud fraction +! Will be spread over whole cloud fraction !----------------------------------------------------------------------- ! Calculate precip rate in old and new cloud fractions !----------------------------------------------------------------------- @@ -948,14 +922,14 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & if( is_hno3 .and. l >= 15 ) then write(*,*) ' ' write(*,*) 'washout: rca,rcxa,deltarime,dor,rprecip,dnew @ l = ',l - write(*,'(1p,6g15.7)') rca,rcxa,deltarime,dor,rprecip,dnew + write(*,'(1p,6g15.7)') rca,rcxa,deltarime,dor,rprecip,dnew write(*,*) 'washout: dcxa,dcxb,wemp,remp,demp' write(*,'(1p,5g15.7)') dcxa,dcxb,wemp,remp,demp write(*,*) ' ' end if endif - if( QTT(L) > zero ) then + if( QTT(L) > zero ) then !----------------------------------------------------------------------- ! ICE SCAVENGING !----------------------------------------------------------------------- @@ -988,11 +962,11 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & endif endif !----------------------------------------------------------------------- -! For ice, accretion removal for hno3 and aerosols is propotional to riming, +! For ice, accretion removal for hno3 and aerosols is propotional to riming, ! no accretion removal for gases ! remove only in mixed portion of cloud ! Limit DELTARIMEMASS to RNEW*DTSCAV for ice - evaporation of rimed ice to match -! RNEW precip rate would result in HNO3 escaping from ice (no trapping) +! RNEW precip rate would result in HNO3 escaping from ice (no trapping) !----------------------------------------------------------------------- if( DELTARIME > zero ) then if( LICETYP == 1 ) then @@ -1004,7 +978,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & QTCXA = QTT(L)*FCXA call DISGAS( CLWX*(FCXA/CFXX(L)), FCXA, TCMASS(N), & HSTAR(L,N), TEM(L), POFL(L), & - QM(L), QTCXA, QTDISRIME ) + QM(L), QTCXA, QTDISRIME ) QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) if ( debug ) then if( is_hno3 .and. l >= 15 ) then @@ -1016,9 +990,9 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & endif QTRIMECXA = QTCXA* & (one - exp((-COLEFFSNOW/(DCA*1.e-3_r8))* & - (RCA/(2._r8*RHOSNOW))* & !uses GBA R + (RCA/(2._r8*RHOSNOW))* & !uses GBA R (QTDISSTAR/QTCXA)*DTSCAV)) - QTRIMECXA = min( QTRIMECXA, & + QTRIMECXA = min( QTRIMECXA, & ((RNEW*GAREA*DTSCAV)/(CLWX*QM(L)*(FCXA/CFXX(L))))*QTDISSTAR) elseif( LICETYP == 2 ) then QTRIMECXA = zero @@ -1057,13 +1031,13 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & DELTARIME = zero endif !----------------------------------------------------------------------- -! If there is some in-cloud precip left, we have new precip formation +! If there is some in-cloud precip left, we have new precip formation !----------------------------------------------------------------------- RPRECIP = (RNEW-(DELTARIME*FCXA))/CFXX(L) !GBA RCXA = RCA + DELTARIME + RPRECIP !kg/m2/s GBA RCXB = RPRECIP !kg/m2/s GBA - DCXA = FOUR + DCXA = FOUR if( FCXB > zero ) then DCXB = FOUR else @@ -1106,8 +1080,8 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & QTDISSTAR = (QTDISRIME*QTCXA)/(QTDISRIME + QTCXA) QTRIMECXA = QTCXA* & (one - exp(-0.24_r8*COLEFFRAIN* & - ((RCA)**0.75_r8)* & !local - (QTDISSTAR/QTCXA)*DTSCAV)) + ((RCA)**0.75_r8)* & !local + (QTDISSTAR/QTCXA)*DTSCAV)) QTRIMECXA = min( QTRIMECXA, & ((RNEW*GAREA*DTSCAV)/(CLWX*QM(L)*(FCXA/CFXX(L))))*QTDISSTAR) else @@ -1195,14 +1169,14 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & RAXADJ = RAXADJF/FAXADJ else RAXADJ = zero - endif + endif else RAXADJ = zero RAMPCT = zero FAXADJ = zero endif endif - + QTEVAPAXP = min( QTTOPAA,QTTOPAA - (RAMPCT*(QTTOPAA-QTEVAPAXP)) ) FAX = FAXADJ RAX = RAXADJ @@ -1232,9 +1206,9 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & ! T>Tmix, hno3&aerosols are incorporated into ice structure: ! do not release ! For rain, assume full evaporation of some raindrops -! proportional evaporation for all species -! washout for gases using Rbot -! impact washout for hno3/aerosol portion in gas phase +! proportional evaporation for all species +! washout for gases using Rbot +! impact washout for hno3/aerosol portion in gas phase !----------------------------------------------------------------------- ! if (TEM(L) < TICE ) then is_freezing_a : & @@ -1254,7 +1228,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & else QTEVAPCXA = zero endif - elseif( LICETYP == 2 ) then + elseif( LICETYP == 2 ) then QTEVAPCXA = zero endif else is_freezing_a @@ -1318,7 +1292,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & !----------------------------------------------------------------------- ! END SCAVENGING -! Require CF if our ambient evaporation rate would give less +! Require CF if our ambient evaporation rate would give less ! precip than R from model. !----------------------------------------------------------------------- if( do_diag .and. is_hno3 ) then @@ -1419,16 +1393,16 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & write(*,*) ' ' endif endif - + if (RCA > zero) then - DCA = (RCXA*FCXA*CLOLDPCT)/(RCA*FCA)*DCXA + & + DCA = (RCXA*FCXA*CLOLDPCT)/(RCA*FCA)*DCXA + & (RCXB*FCXB*CLNEWPCT)/(RCA*FCA)*DCXB + & (RAX*FAX*AMCLPCT)/(RCA*FCA)*DAX else DCA = zero FCA = zero endif - + else FCA = zero DCA = zero @@ -1498,13 +1472,13 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & !----------------------------------------------------------------------- QTNETLCXA = QTRAINCXA + QTRIMECXA + QTWASHCXA - QTEVAPCXA QTNETLCXA = min( QTT(L)*FCXA,QTNETLCXA ) - + QTNETLCXB =QTRAINCXB QTNETLCXB = min( QTT(L)*FCXB,QTNETLCXB ) QTNETLAX = QTWASHAX - QTEVAPAX QTNETLAX = min( QTT(L)*FAX,QTNETLAX ) - + QTTNEW(L) = QTT(L) - (QTNETLCXA + QTNETLCXB + QTNETLAX) if( do_diag .and. is_hno3 ) then @@ -1598,7 +1572,7 @@ subroutine WASHO(LPAR,NTRACE,DTSCAV,QTTJFL,QM,POFL,DELZ, & endif endif !----------------------------------------------------------------------- -! reload new tracer mass and rescale moments: check upper limits (LE) +! reload new tracer mass and rescale moments: check upper limits (LE) !----------------------------------------------------------------------- QTTJFL(:le,N) = QTTNEW(:le) @@ -1610,15 +1584,15 @@ end subroutine washo subroutine DISGAS (CLWX,CFX,MOLMASS,HSTAR,TM,PR,QM,QT,QTDIS) !--------------------------------------------------------------------- implicit none - real(r8), intent(in) :: CLWX,CFX !cloud water,cloud fraction + real(r8), intent(in) :: CLWX,CFX !cloud water,cloud fraction real(r8), intent(in) :: MOLMASS !molecular mass of tracer real(r8), intent(in) :: HSTAR !Henry's Law coeffs A*exp(-B/T) real(r8), intent(in) :: TM !temperature of box (K) real(r8), intent(in) :: PR !pressure of box (hPa) real(r8), intent(in) :: QM !air mass in box (kg) real(r8), intent(in) :: QT !tracer in box (kg) - real(r8), intent(out) :: QTDIS !tracer dissolved in aqueous phase - + real(r8), intent(out) :: QTDIS !tracer dissolved in aqueous phase + real(r8) MUEMP real(r8), parameter :: INV298 = 1._r8/298._r8 real(r8), parameter :: TMIX=258._r8 @@ -1646,10 +1620,10 @@ end subroutine DISGAS subroutine RAINGAS (RRAIN,DTSCAV,CLWX,CFX,QM,QT,QTDIS,QTRAIN) !----------------------------------------------------------------------- !---New trace-gas rainout from large-scale precip with two time scales, -!---one based on precip formation from cloud water and one based on +!---one based on precip formation from cloud water and one based on !---Henry's Law solubility: correct limit for delta-t -!--- -!---NB this code does not consider the aqueous dissociation (eg, C-q) +!--- +!---NB this code does not consider the aqueous dissociation (eg, C-q) !--- that makes uptake of HNO3 and H2SO4 so complete. To do so would !--- require that we keep track of the pH of the falling rain. !---THUS the Henry's Law coefficient KHA needs to be enhanced to incldue this! @@ -1663,9 +1637,9 @@ subroutine RAINGAS (RRAIN,DTSCAV,CLWX,CFX,QM,QT,QTDIS,QTRAIN) real(r8), intent(in) :: DTSCAV !time step (s) real(r8), intent(in) :: CLWX,CFX !cloud water and cloud fraction real(r8), intent(in) :: QM !air mass in box (kg) - real(r8), intent(in) :: QT !tracer in box (kg) - real(r8), intent(in) :: QTDIS !tracer in aqueous phase (kg) - real(r8), intent(out) :: QTRAIN !tracer picked up by new rain + real(r8), intent(in) :: QT !tracer in box (kg) + real(r8), intent(in) :: QTDIS !tracer in aqueous phase (kg) + real(r8), intent(out) :: QTRAIN !tracer picked up by new rain real(r8) QTLF,QTDISSTAR @@ -1674,12 +1648,12 @@ subroutine RAINGAS (RRAIN,DTSCAV,CLWX,CFX,QM,QT,QTDIS,QTRAIN) QTDISSTAR=(QTDIS*(QT*CFX))/(QTDIS+(QT*CFX)) - + !---Tracer Loss frequency (1/s) within cloud fraction: QTLF = (RRAIN*QTDISSTAR)/(CLWX*QM*QT*CFX) -!---in time = DTSCAV, the amount of QTT scavenged is calculated -!---from CF*AMOUNT OF UPTAKE +!---in time = DTSCAV, the amount of QTT scavenged is calculated +!---from CF*AMOUNT OF UPTAKE QTRAIN = QT*CFX*(1._r8 - exp(-DTSCAV*QTLF)) return @@ -1693,7 +1667,7 @@ subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & !---for most gases below-cloud washout assume Henry-Law equilib with precip !---assumes that precip is liquid, if frozen, do not call this sub !---since solubility is moderate, fraction of box with rain does not matter -!---NB this code does not consider the aqueous dissociation (eg, C-q) +!---NB this code does not consider the aqueous dissociation (eg, C-q) !--- that makes uptake of HNO3 and H2SO4 so complete. To do so would !--- require that we keep track of the pH of the falling rain. !---THUS the Henry's Law coefficient KHA needs to be enhanced to incldue this! @@ -1704,7 +1678,7 @@ subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & real(r8), intent(in) :: RWASH ! precip leaving bottom of box (kg/s) real(r8), intent(in) :: BOXF ! fraction of box with washout real(r8), intent(in) :: DTSCAV ! time step (s) - real(r8), intent(in) :: QTRTOP ! tracer-T in rain entering top of box + real(r8), intent(in) :: QTRTOP ! tracer-T in rain entering top of box ! over time step (kg) real(r8), intent(in) :: HSTAR ! Henry's Law coeffs A*exp(-B/T) real(r8), intent(in) :: TM ! temperature of box (K) @@ -1713,7 +1687,7 @@ subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & real(r8), intent(in) :: QM ! air mass in box (kg) real(r8), intent(out) :: QTWASH ! tracer picked up by precip (kg) real(r8), intent(out) :: QTEVAP ! tracer evaporated from precip (kg) - + real(r8), parameter :: INV298 = 1._r8/298._r8 real(r8) :: FWASH, QTMAX, QTDIF @@ -1746,7 +1720,7 @@ subroutine WASHGAS (RWASH,BOXF,DTSCAV,QTRTOP,HSTAR,TM,PR,QM, & QTWASH = 0._r8 QTEVAP = QTRTOP - QTMAX endif - + return end subroutine WASHGAS @@ -1756,14 +1730,14 @@ function DEMPIRICAL (CWATER,RRATE) use shr_spfn_mod, only: shr_spfn_gamma implicit none - real(r8), intent(in) :: CWATER + real(r8), intent(in) :: CWATER real(r8), intent(in) :: RRATE real(r8) :: DEMPIRICAL - + real(r8) RRATEX,WX,THETA,PHI,ETA,BETA,ALPHA,BEE real(r8) GAMTHETA,GAMBETA - + RRATEX=RRATE*3600._r8 !mm/hr @@ -1783,7 +1757,7 @@ function DEMPIRICAL (CWATER,RRATE) GAMBETA = shr_spfn_gamma(BETA+1._r8) DEMPIRICAL=(((WX*ETA*GAMTHETA)/(1.0e6_r8*ALPHA*PHI*GAMBETA))** & (-1._r8/BEE))*10._r8 ! in mm (wx/1e6 for cgs) - + return end function DEMPIRICAL diff --git a/src/chemistry/mozart/mo_photo.F90 b/src/chemistry/mozart/mo_photo.F90 index 6a090ca673..d02570d5b0 100644 --- a/src/chemistry/mozart/mo_photo.F90 +++ b/src/chemistry/mozart/mo_photo.F90 @@ -119,11 +119,7 @@ subroutine photo_inti( xs_coef_file, xs_short_file, xs_long_file, rsf_file, & use ioFileMod, only : getfil use mo_chem_utls, only : get_spc_ndx, get_rxt_ndx, get_inv_ndx use mo_jlong, only : jlong_init -#ifdef OSLO_AERO - use oslo_aero_seasalt, only : sslt_names=>seasalt_names, sslt_ncnst=>seasalt_nbin -#else use seasalt_model, only : sslt_names=>seasalt_names, sslt_ncnst=>seasalt_nbin -#endif use mo_jshort, only : jshort_init use mo_jeuv, only : jeuv_init, neuv use phys_grid, only : get_ncols_p, get_rlat_all_p @@ -980,11 +976,7 @@ subroutine xactive_photo( photos, vmr, temper, cwat, cldfr, & use mo_photoin, only : photoin use mo_tuv_inti, only : nlng use time_manager, only : get_curr_date -#ifdef OSLO_AERO - use oslo_aero_dust, only : dust_nbin -#else use dust_model, only : dust_nbin -#endif use phys_grid, only : get_rlat_all_p, get_rlon_all_p implicit none diff --git a/src/chemistry/mozart/mo_setaer.F90 b/src/chemistry/mozart/mo_setaer.F90 index 58b25414aa..34442f5ae5 100644 --- a/src/chemistry/mozart/mo_setaer.F90 +++ b/src/chemistry/mozart/mo_setaer.F90 @@ -655,13 +655,8 @@ subroutine setaer( z, airden, rh, aocs1, aocs2, acbs1, acbs2,& use chem_mods, only : adv_mass use mo_constants, only : avogadro use mo_chem_utls, only : get_spc_ndx -#ifdef OSLO_AERO - use oslo_aero_dust, only : dust_names - use oslo_aero_seasalt, only : sslt_names=>seasalt_names -#else use dust_model, only : dust_names use seasalt_model, only : sslt_names=>seasalt_names -#endif implicit none diff --git a/src/chemistry/mozart/mo_srf_emissions.F90 b/src/chemistry/mozart/mo_srf_emissions.F90 index 722ee0997b..f1cc056d9c 100644 --- a/src/chemistry/mozart/mo_srf_emissions.F90 +++ b/src/chemistry/mozart/mo_srf_emissions.F90 @@ -12,9 +12,6 @@ module mo_srf_emissions use ppgrid, only : pcols, begchunk, endchunk use cam_logfile, only : iulog use tracer_data, only : trfld,trfile -#ifdef OSLO_AERO - use oslo_aero_ocean, only: oslo_aero_dms_inq -#endif implicit none @@ -42,9 +39,6 @@ module mo_srf_emissions type(emission), allocatable :: emissions(:) integer :: n_emis_files integer :: c10h16_ndx, isop_ndx -#ifdef OSLO_AERO - integer :: dms_ndx -#endif contains @@ -263,10 +257,6 @@ subroutine srf_emissions_inti( srf_emis_specifier, emis_type_in, emis_cycle_yr, c10h16_ndx = get_spc_ndx('C10H16') isop_ndx = get_spc_ndx('ISOP') -#ifdef OSLO_AERO - dms_ndx = get_spc_ndx('DMS') -#endif - end subroutine srf_emissions_inti subroutine set_srf_emissions_time( pbuf2d, state ) @@ -383,16 +373,6 @@ subroutine set_srf_emissions( lchnk, ncol, sflx ) declination = dec_max * cos((doy_loc - 172._r8)*twopi/dayspy) tod = (calday - doy_loc) + .5_r8 -#ifdef OSLO_AERO - ! Remove DMS emissions if option is not "from file" - ! Online emissions are treated in seasalt module - if (.not. oslo_aero_dms_inq()) then ! Returns "True" if "emissions from file" - if (dms_ndx .gt. 0)then - sflx(:,dms_ndx) = 0.0_r8 - end if - end if -#endif - do i = 1,ncol ! polar_day = .false. diff --git a/src/chemistry/mozart/mo_usrrxt.F90 b/src/chemistry/mozart/mo_usrrxt.F90 index aa7f526a94..e77d711f6c 100644 --- a/src/chemistry/mozart/mo_usrrxt.F90 +++ b/src/chemistry/mozart/mo_usrrxt.F90 @@ -3,9 +3,6 @@ module mo_usrrxt use shr_kind_mod, only : r8 => shr_kind_r8 use cam_logfile, only : iulog use ppgrid, only : pver, pcols -#ifdef OSLO_AERO - use oslo_aero_params, only: nmodes_oslo=> nmodes -#endif implicit none @@ -573,13 +570,10 @@ subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, & real(r8), pointer :: sfc_array(:,:,:), dm_array(:,:,:) -#ifdef OSLO_AERO - ntot_amode = nmodes_oslo -#else ! get info about the modal aerosols ! get ntot_amode call rad_cnst_get_info(0, nmodes=ntot_amode) -#endif + if (ntot_amode>0) then allocate(sfc_array(pcols,pver,ntot_amode), dm_array(pcols,pver,ntot_amode) ) else @@ -1188,7 +1182,7 @@ subroutine usrrxt( rxt, temp, tempi, tempe, invariants, h2ovmr, & where( tp(:ncol) < trlim3 ) rxt(:,k,ion3_ndx) = 1.4e-10_r8 * tp(:)**.44_r8 rxt(:,k,ion11_ndx) = 1.e-11_r8 * tp(:)**.23_r8 - elsewhere + elsewhere rxt(:,k,ion3_ndx) = 5.2e-11_r8 / tp(:)**.2_r8 rxt(:,k,ion11_ndx) = 3.6e-12_r8 / tp(:)**.41_r8 end where diff --git a/src/control/runtime_opts.F90 b/src/control/runtime_opts.F90 index 358b1d9d7c..f390d45744 100644 --- a/src/control/runtime_opts.F90 +++ b/src/control/runtime_opts.F90 @@ -38,9 +38,6 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) use physconst, only: physconst_readnl use physics_buffer, only: pbuf_readnl use phys_control, only: phys_ctl_readnl -#ifdef OSLO_AERO - use oslo_aero_control, only: oslo_aero_ctl_readnl -#endif use wv_saturation, only: wv_sat_readnl use ref_pres, only: ref_pres_readnl use cam3_aero_data, only: cam3_aero_data_readnl @@ -48,11 +45,7 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) use dadadj_cam, only: dadadj_readnl use macrop_driver, only: macrop_driver_readnl use microp_driver, only: microp_driver_readnl -#ifdef OSLO_AERO - use oslo_aero_microp, only: oslo_aero_microp_readnl -#else use microp_aero, only: microp_aero_readnl -#endif use subcol, only: subcol_readnl use cloud_fraction, only: cldfrc_readnl use cldfrc2m, only: cldfrc2m_readnl @@ -143,11 +136,7 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) call dadadj_readnl(nlfilename) call macrop_driver_readnl(nlfilename) call microp_driver_readnl(nlfilename) -#ifdef OSLO_AERO - call oslo_aero_microp_readnl(nlfilename) -#else call microp_aero_readnl(nlfilename) -#endif call clubb_readnl(nlfilename) call subcol_readnl(nlfilename) call cldfrc_readnl(nlfilename) @@ -190,9 +179,6 @@ subroutine read_namelist(nlfilename, single_column, scmlat, scmlon) call rayleigh_friction_readnl(nlfilename) #if ( defined OFFLINE_DYN ) call metdata_readnl(nlfilename) -#endif -#ifdef OSLO_AERO - call oslo_aero_ctl_readnl(nlfilename) #endif call offline_driver_readnl(nlfilename) call analytic_ic_readnl(nlfilename) diff --git a/src/physics/cam/cam_diagnostics.F90 b/src/physics/cam/cam_diagnostics.F90 index 9aff68ca04..4f9060a2b2 100644 --- a/src/physics/cam/cam_diagnostics.F90 +++ b/src/physics/cam/cam_diagnostics.F90 @@ -1396,7 +1396,7 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) do k=2,pver ftem(:ncol,1) = ftem(:ncol,1) + ftem(:ncol,k) end do - call outfld ('ATMEINT ',ftem(:ncol,1) ,pcols ,lchnk ) + call outfld ('ATMEINT ',ftem(:,1) ,pcols ,lchnk ) !! Boundary layer atmospheric stability, temperature, water vapor diagnostics @@ -1956,8 +1956,8 @@ end subroutine diag_physvar_ic !####################################################################### - !subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) - subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, dsema) !tht + !subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) + subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, eflx, dsema, tmp_t) !tht !--------------------------------------------------------------- ! @@ -1976,9 +1976,9 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, ds type(physics_tend ), intent(in) :: tend real(r8), intent(in) :: ztodt ! physics timestep - real(r8) , intent(inout) :: tmp_t (pcols,pver) !tht: holds last physics_updated T (FV) - real(r8) , intent(in), optional ::eflx (pcols ) !tht: surface sensible heat flux assoc.with mass adj. - real(r8) , intent(in), optional ::dsema(pcols ) !tht: column enthalpy tendency assoc. with mass adj. + real(r8) , intent(in), optional :: eflx (pcols) !tht: surface sensible heat flux assoc.with mass adj. + real(r8) , intent(in), optional :: dsema(pcols) !tht: column enthalpy tendency assoc. with mass adj. + real(r8) , intent(inout), optional :: tmp_t(pcols,pver) !tht: holds last physics_updated T (FV) !---------------------------Local workspace----------------------------- @@ -2005,10 +2005,16 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, ds !tht: heat tendencies from dme_adjust if (dycore_is('LR')) then - tmp_t(:ncol,:pver) = (state%t(:ncol,:pver) - tmp_t(:ncol,:pver))/ztodt ! T tendency - call outfld('PTTEND_DME', tmp_t, pcols, lchnk ) - if(present(dsema))call outfld('IETEND_DME', dsema, pcols, lchnk) ! dry enthalpy - if(present(eflx) )call outfld('EFLX' , eflx, pcols, lchnk) ! moist enthalpy + if (present(tmp_t)) then + tmp_t(:ncol,:pver) = (state%t(:ncol,:pver) - tmp_t(:ncol,:pver))/ztodt ! T tendency + call outfld('PTTEND_DME', tmp_t, pcols, lchnk ) + end if + if(present(dsema)) then + call outfld('IETEND_DME', dsema, pcols, lchnk) ! dry enthalpy + end if + if(present(eflx) ) then + call outfld('EFLX' , eflx, pcols, lchnk) ! moist enthalpy + end if end if ! Total physics tendency for Temperature @@ -2148,9 +2154,9 @@ end subroutine diag_phys_tend_writeout_moist !####################################################################### - subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & - ! tmp_q, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini) - tmp_q, tmp_t, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini, eflx, dsema) !+tht + subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & + !tmp_q, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini) + tmp_q, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini, eflx, dsema, tmp_t) !+tht !--------------------------------------------------------------- ! @@ -2166,20 +2172,18 @@ subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & type(physics_tend ), intent(in) :: tend real(r8), intent(in) :: ztodt ! physics timestep real(r8) , intent(inout) :: tmp_q (pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8) , intent(inout) :: tmp_t (pcols,pver) !tht: holds last physics_updated T (FV) real(r8), intent(inout) :: tmp_cldliq(pcols,pver) ! As input, holds pre-adjusted tracers (FV) real(r8), intent(inout) :: tmp_cldice(pcols,pver) ! As input, holds pre-adjusted tracers (FV) real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics - real(r8) , intent(in), optional ::eflx (pcols ) !tht: surface sensible heat flux assoc.with mass adj. - real(r8) , intent(in), optional ::dsema(pcols ) !tht: column enthalpy tendency assoc. with mass adj. + real(r8) , intent(in), optional :: eflx (pcols) !tht: surface sensible heat flux assoc.with mass adj. + real(r8) , intent(in), optional :: dsema(pcols) !tht: column enthalpy tendency assoc. with mass adj. real(r8) , intent(inout), optional :: tmp_t(pcols,pver) !tht: holds last physics_updated T (FV) - !----------------------------------------------------------------------- !call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) - call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, dsema) !tht + call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, eflx=eflx, dsema=dsema, tmp_t=tmp_t) !tht if (moist_physics) then call diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & tmp_q, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini) diff --git a/src/physics/cam/diffusion_solver.F90 b/src/physics/cam/diffusion_solver.F90 deleted file mode 100644 index fd33773066..0000000000 --- a/src/physics/cam/diffusion_solver.F90 +++ /dev/null @@ -1,989 +0,0 @@ - - module diffusion_solver - - !------------------------------------------------------------------------------------ ! - ! Module to solve vertical diffusion equations using a tri-diagonal solver. ! - ! The module will also apply countergradient fluxes, and apply molecular ! - ! diffusion for constituents. ! - ! ! - ! Public interfaces : ! - ! init_vdiff initializes time independent coefficients ! - ! compute_vdiff solves diffusion equations ! - ! vdiff_selector type for storing fields selected to be diffused ! - ! vdiff_select selects fields to be diffused ! - ! operator(.not.) extends .not. to operate on type vdiff_selector ! - ! any provides functionality of intrinsic any for type vdiff_selector ! - ! ! - !------------------------------------ Code History ---------------------------------- ! - ! Initial subroutines : B. Boville and others, 1991-2004 ! - ! Modularization : J. McCaa, September 2004 ! - ! Most Recent Code : Sungsu Park, Aug. 2006, Dec. 2008, Jan. 2010. ! - !------------------------------------------------------------------------------------ ! - - implicit none - private - save - - integer, parameter :: r8 = selected_real_kind(12) ! 8 byte real - - ! ----------------- ! - ! Public interfaces ! - ! ----------------- ! - - public init_vdiff ! Initialization - public new_fieldlist_vdiff ! Returns an empty fieldlist - public compute_vdiff ! Full routine - public vdiff_selector ! Type for storing fields selected to be diffused - public vdiff_select ! Selects fields to be diffused - public operator(.not.) ! Extends .not. to operate on type vdiff_selector - public any ! Provides functionality of intrinsic any for type vdiff_selector - - ! Below stores logical array of fields to be diffused - - type vdiff_selector - private - logical, allocatable, dimension(:) :: fields - end type vdiff_selector - - ! Below extends .not. to operate on type vdiff_selector - - interface operator(.not.) - module procedure not - end interface - - ! Below provides functionality of intrinsic any for type vdiff_selector - - interface any - module procedure my_any - end interface - - ! ------------ ! - ! Private data ! - ! ------------ ! - - ! Unit number for log output - integer :: iulog = -1 - - real(r8), private :: cpair ! Specific heat of dry air - real(r8), private :: gravit ! Acceleration due to gravity - real(r8), private :: rair ! Gas constant for dry air - - logical, private :: do_iss ! Use implicit turbulent surface stress computation - - ! Parameters used for Turbulent Mountain Stress - - real(r8), parameter :: z0fac = 0.025_r8 ! Factor determining z_0 from orographic standard deviation - real(r8), parameter :: z0max = 100._r8 ! Max value of z_0 for orography - real(r8), parameter :: horomin = 10._r8 ! Min value of subgrid orographic height for mountain stress - real(r8), parameter :: dv2min = 0.01_r8 ! Minimum shear squared - - logical :: am_correction ! logical switch for AM correction - - contains - - ! =============================================================================== ! - ! ! - ! =============================================================================== ! - - subroutine init_vdiff( kind, iulog_in, rair_in, cpair_in, gravit_in, do_iss_in, & - am_correction_in, errstring ) - - integer, intent(in) :: kind ! Kind used for reals - integer, intent(in) :: iulog_in ! Unit number for log output. - real(r8), intent(in) :: rair_in ! Input gas constant for dry air - real(r8), intent(in) :: cpair_in ! Input heat capacity for dry air - real(r8), intent(in) :: gravit_in ! Input gravitational acceleration - logical, intent(in) :: do_iss_in ! Input ISS flag - logical, intent(in) :: am_correction_in! for angular momentum conservation - character(128), intent(out) :: errstring ! Output status - - errstring = '' - iulog = iulog_in - if( kind .ne. r8 ) then - write(iulog,*) 'KIND of reals passed to init_vdiff -- exiting.' - errstring = 'init_vdiff' - return - endif - - rair = rair_in - cpair = cpair_in - gravit = gravit_in - do_iss = do_iss_in - am_correction = am_correction_in - - end subroutine init_vdiff - - ! =============================================================================== ! - ! ! - ! =============================================================================== ! - - type(vdiff_selector) pure function new_fieldlist_vdiff(ncnst) - - integer, intent(in) :: ncnst ! Number of constituents - - allocate( new_fieldlist_vdiff%fields( 3 + ncnst ) ) - new_fieldlist_vdiff%fields = .false. - - end function new_fieldlist_vdiff - - ! =============================================================================== ! - ! ! - ! =============================================================================== ! - - subroutine compute_vdiff( lchnk , & - pcols , pver , ncnst , ncol , tint , & - p , t , rhoi , ztodt , taux , & - tauy , shflx , cflx , & - kvh , kvm , kvq , cgs , cgh , & - zi , ksrftms , dragblj , & - qmincg , fieldlist , fieldlistm , & - u , v , q , dse , & - tautmsx , tautmsy , dtk , topflx , errstring , & - tauresx , tauresy , itaures , cpairv , dse_top, & - do_molec_diff , use_temperature_molec_diff, vd_lu_qdecomp, & - ubc_mmr, ubc_flux, kvt, pmid, & - cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & - kq_scal, mw_fac) - - !-------------------------------------------------------------------------- ! - ! Driver routine to compute vertical diffusion of momentum, moisture, trace ! - ! constituents and dry static energy. The new temperature is computed from ! - ! the diffused dry static energy. ! - ! Turbulent diffusivities and boundary layer nonlocal transport terms are ! - ! obtained from the turbulence module. ! - !-------------------------------------------------------------------------- ! - -! Used for CAM debugging. -! use phys_debug_util, only : phys_debug_col -! use time_manager, only : is_first_step, get_nstep - - use coords_1d, only: Coords1D - use linear_1d_operators, only : BoundaryType, BoundaryFixedLayer, & - BoundaryData, BoundaryFlux, TriDiagDecomp - use vdiff_lu_solver, only : fin_vol_lu_decomp - use beljaars_drag_cam, only : do_beljaars - ! FIXME: This should not be needed - use physconst, only: rairv - - use phys_control, only : phys_getopts - - ! Modification : Ideally, we should diffuse 'liquid-ice static energy' (sl), not the dry static energy. - ! Also, vertical diffusion of cloud droplet number concentration and aerosol number - ! concentration should be done very carefully in the future version. - - ! --------------- ! - ! Input Arguments ! - ! --------------- ! - - integer, intent(in) :: lchnk - integer, intent(in) :: pcols - integer, intent(in) :: pver - integer, intent(in) :: ncnst - integer, intent(in) :: ncol ! Number of atmospheric columns - integer, intent(in) :: itaures ! Indicator determining whether 'tauresx,tauresy' - ! is updated (1) or non-updated (0) in this subroutine. - - type(Coords1D), intent(in) :: p ! Pressure coordinates [ Pa ] - real(r8), intent(in) :: tint(pcols,pver+1) ! Temperature [ K ] - real(r8), intent(in) :: t(pcols,pver) ! Temperature [ K ] - real(r8), intent(in) :: rhoi(pcols,pver+1) ! Density of air at interfaces [ kg/m3 ] - real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] - real(r8), intent(in) :: taux(pcols) ! Surface zonal stress. - ! Input u-momentum per unit time per unit area into the atmosphere [ N/m2 ] - real(r8), intent(in) :: tauy(pcols) ! Surface meridional stress. - ! Input v-momentum per unit time per unit area into the atmosphere [ N/m2 ] - real(r8), intent(in) :: shflx(pcols) ! Surface sensible heat flux [ W/m2 ] - real(r8), intent(in) :: cflx(pcols,ncnst) ! Surface constituent flux [ kg/m2/s ] - real(r8), intent(in) :: zi(pcols,pver+1) ! Interface heights [ m ] - real(r8), intent(in) :: ksrftms(pcols) ! Surface drag coefficient for turbulent mountain stress. > 0. [ kg/s/m2 ] - real(r8), intent(in) :: dragblj(pcols,pver) ! Drag profile from Beljaars SGO form drag > 0. [ 1/s ] - real(r8), intent(in) :: qmincg(ncnst) ! Minimum constituent mixing ratios from cg fluxes - real(r8), intent(in) :: cpairv(pcols,pver) ! Specific heat at constant pressure - real(r8), intent(in) :: kvh(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] - - logical, intent(in) :: do_molec_diff ! Flag indicating multiple constituent diffusivities - logical, intent(in) :: use_temperature_molec_diff! Flag indicating that molecular diffusion should apply to temperature, not - ! dry static energy. - - type(vdiff_selector), intent(in) :: fieldlist ! Array of flags selecting which fields to diffuse - type(vdiff_selector), intent(in) :: fieldlistm ! Array of flags selecting which fields for molecular diffusion - - ! Dry static energy top boundary condition. - real(r8), intent(in) :: dse_top(pcols) - - real(r8), intent(in) :: kvm(pcols,pver+1) ! Eddy viscosity ( Eddy diffusivity for momentum ) [ m2/s ] - real(r8), intent(in) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents - real(r8), intent(in) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] - real(r8), intent(in) :: cgh(pcols,pver+1) ! Counter-gradient term for heat - - ! ---------------------- ! - ! Input-Output Arguments ! - ! ---------------------- ! - - real(r8), intent(inout) :: u(pcols,pver) ! U wind. This input is the 'raw' input wind to - ! PBL scheme without iterative provisional update. [ m/s ] - real(r8), intent(inout) :: v(pcols,pver) ! V wind. This input is the 'raw' input wind to PBL scheme - ! without iterative provisional update. [ m/s ] - real(r8), intent(inout) :: q(pcols,pver,ncnst) ! Moisture and trace constituents [ kg/kg, #/kg ? ] - real(r8), intent(inout) :: dse(pcols,pver) ! Dry static energy [ J/kg ] - - real(r8), intent(inout) :: tauresx(pcols) ! Input : Reserved surface stress at previous time step - real(r8), intent(inout) :: tauresy(pcols) ! Output : Reserved surface stress at current time step - - ! ---------------- ! - ! Output Arguments ! - ! ---------------- ! - - real(r8), intent(out) :: dtk(pcols,pver) ! T tendency from KE dissipation - real(r8), intent(out) :: tautmsx(pcols) ! Implicit zonal turbulent mountain surface stress - ! [ N/m2 = kg m/s /s/m2 ] - real(r8), intent(out) :: tautmsy(pcols) ! Implicit meridional turbulent mountain surface stress - ! [ N/m2 = kg m/s /s/m2 ] - real(r8), intent(out) :: topflx(pcols) ! Molecular heat flux at the top interface - character(128), intent(out) :: errstring ! Output status - - ! ------------------ ! - ! Optional Arguments ! - ! ------------------ ! - - ! The molecular diffusion module will likely change significantly in - ! the future, and this module may directly depend on it after that. - ! Until then, we have these highly specific interfaces hard-coded. - - optional :: vd_lu_qdecomp ! Constituent-dependent molecular diffusivity routine - - interface - function vd_lu_qdecomp( & - pcols , pver , ncol , fixed_ubc , mw , & - kv , kq_scal, mw_facm , dpidz_sq , coords , & - interface_boundary, molec_boundary, & - tint , ztodt , nbot_molec , & - lchnk , t , m , no_molec_decomp) result(decomp) - import - integer, intent(in) :: pcols - integer, intent(in) :: pver - integer, intent(in) :: ncol - integer, intent(in) :: nbot_molec - logical, intent(in) :: fixed_ubc - real(r8), intent(in) :: kv(pcols,pver+1) - real(r8), intent(in) :: kq_scal(pcols,pver+1) - real(r8), intent(in) :: mw - real(r8), intent(in) :: mw_facm(pcols,pver+1) - real(r8), intent(in) :: dpidz_sq(ncol,pver+1) - type(Coords1D), intent(in) :: coords - type(BoundaryType), intent(in) :: interface_boundary - type(BoundaryType), intent(in) :: molec_boundary - real(r8), intent(in) :: tint(pcols,pver+1) - real(r8), intent(in) :: ztodt - integer, intent(in) :: lchnk - real(r8), intent(in) :: t(pcols,pver) - integer, intent(in) :: m - type(TriDiagDecomp), intent(in) :: no_molec_decomp - type(TriDiagDecomp) :: decomp - end function vd_lu_qdecomp - end interface - - real(r8), intent(in), optional :: ubc_mmr(pcols,ncnst) ! Upper boundary mixing ratios [ kg/kg ] - real(r8), intent(in), optional :: ubc_flux(pcols,ncnst) ! Upper boundary flux [ kg/s/m^2 ] - - real(r8), intent(in), optional :: kvt(pcols,pver+1) ! Kinematic molecular conductivity - - ! FIXME: This input should not be needed (and should not be passed in in vertical_diffusion). - real(r8), intent(in), optional :: pmid(pcols,pver) - - real(r8), intent(in), optional :: cnst_mw(ncnst) ! Molecular weight [ kg/kmole ] - logical, intent(in), optional :: cnst_fixed_ubc(ncnst) ! Whether upper boundary condition is fixed - logical, intent(in), optional :: cnst_fixed_ubflx(ncnst) ! Whether upper boundary flux is a fixed non-zero value - - integer, intent(in), optional :: nbot_molec ! Bottom level where molecular diffusivity is applied - - ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity - real(r8), intent(in), optional :: kq_scal(pcols,pver+1) - ! Local sqrt(1/M_q + 1/M_d) for each constituent - real(r8), intent(in), optional :: mw_fac(pcols,pver+1,ncnst) - - ! --------------- ! - ! Local Variables ! - ! --------------- ! - - integer :: i, k, m ! Longitude, level, constituent indices - logical :: lqtst(pcols) ! Adjust vertical profiles - - ! LU decomposition information. - type(TriDiagDecomp) :: decomp - type(TriDiagDecomp) :: no_molec_decomp - - ! Square of derivative of pressure with height (on interfaces). - real(r8) :: dpidz_sq(ncol,pver+1) - - ! Pressure coordinates over the molecular diffusion range only. - type(Coords1D) :: p_molec - - ! Boundary layer objects - type(BoundaryType) :: interface_boundary - type(BoundaryType) :: molec_boundary - - real(r8) :: tmp1(pcols) ! Temporary storage - real(r8) :: tmpi1(pcols,pver+1) ! Interface KE dissipation - real(r8) :: tmpi2(pcols,pver+1) ! dt*(g*rho)**2/dp at interfaces - real(r8) :: keg_in(pcols,pver) ! KE on entry to subroutine - real(r8) :: keg_out(pcols,pver) ! KE after U and V dissipation/diffusion - real(r8) :: rrho(pcols) ! 1./bottom level density - - real(r8) :: tautotx(pcols) ! Total surface stress ( zonal ) - real(r8) :: tautoty(pcols) ! Total surface stress ( meridional ) - - real(r8) :: dinp_u(pcols,pver+1) ! Vertical difference at interfaces, input u - real(r8) :: dinp_v(pcols,pver+1) ! Vertical difference at interfaces, input v - real(r8) :: dout_u ! Vertical difference at interfaces, output u - real(r8) :: dout_v ! Vertical difference at interfaces, output v - - real(r8) :: qtm(pcols,pver) ! Temporary copy of q - - real(r8) :: ws(pcols) ! Lowest-level wind speed [ m/s ] - real(r8) :: tau(pcols) ! Turbulent surface stress ( not including mountain stress ) - real(r8) :: ksrfturb(pcols) ! Surface drag coefficient of 'normal' stress. > 0. - ! Virtual mass input per unit time per unit area [ kg/s/m2 ] - real(r8) :: ksrf(pcols) ! Surface drag coefficient of 'normal' stress + - ! Surface drag coefficient of 'tms' stress. > 0. [ kg/s/m2 ] - real(r8) :: usum_in(pcols) ! Vertical integral of input u-momentum. Total zonal - ! momentum per unit area in column [ sum of u*dp/g = kg m/s m-2 ] - real(r8) :: vsum_in(pcols) ! Vertical integral of input v-momentum. Total meridional - ! momentum per unit area in column [ sum of v*dp/g = kg m/s m-2 ] - real(r8) :: usum_mid(pcols) ! Vertical integral of u-momentum after adding explicit residual stress - real(r8) :: vsum_mid(pcols) ! Vertical integral of v-momentum after adding explicit residual stress - real(r8) :: usum_out(pcols) ! Vertical integral of u-momentum after doing implicit diffusion - real(r8) :: vsum_out(pcols) ! Vertical integral of v-momentum after doing implicit diffusion - real(r8) :: tauimpx(pcols) ! Actual net stress added at the current step other than mountain stress - real(r8) :: tauimpy(pcols) ! Actual net stress added at the current step other than mountain stress - real(r8) :: ramda ! dt/timeres [ no unit ] - - real(r8) :: taubljx(pcols) ! recomputed explicit/residual beljaars stress - real(r8) :: taubljy(pcols) ! recomputed explicit/residual beljaars stress - - ! Rate at which external (surface) stress damps wind speeds (1/s). - real(r8) :: tau_damp_rate(ncol, pver) - - ! Combined molecular and eddy diffusion. - real(r8) :: kv_total(pcols,pver+1) - - logical :: use_spcam - - !-------------------------------- - ! Variables needed for WACCM-X - !-------------------------------- - real(r8) :: ttemp(ncol,pver) ! temporary temperature array - real(r8) :: ttemp0(ncol,pver) ! temporary temperature array - - ! ------------------------------------------------ ! - ! Parameters for implicit surface stress treatment ! - ! ------------------------------------------------ ! - - real(r8), parameter :: wsmin = 1._r8 ! Minimum sfc wind speed for estimating frictional - ! transfer velocity ksrf. [ m/s ] - real(r8), parameter :: ksrfmin = 1.e-4_r8 ! Minimum surface drag coefficient [ kg/s/m^2 ] - real(r8), parameter :: timeres = 7200._r8 ! Relaxation time scale of residual stress ( >= dt ) [ s ] - - ! ----------------------- ! - ! Main Computation Begins ! - ! ----------------------- ! - - call phys_getopts(use_spcam_out = use_spcam) - - errstring = '' - if( ( diffuse(fieldlist,'u') .or. diffuse(fieldlist,'v') ) .and. .not. diffuse(fieldlist,'s') ) then - errstring = 'diffusion_solver.compute_vdiff: must diffuse s if diffusing u or v' - return - end if - - !--------------------------------------- ! - ! Computation of Molecular Diffusivities ! - !--------------------------------------- ! - - ! Modification : Why 'kvq' is not changed by molecular diffusion ? - - if( do_molec_diff ) then - - if( (.not.present(vd_lu_qdecomp)) .or. (.not.present(kvt)) & - .or. (.not. present(ubc_mmr)) .or. (.not. present(ubc_flux)) ) then - errstring = 'compute_vdiff: do_molec_diff true but vd_lu_qdecomp or kvt missing' - return - endif - - p_molec = p%section([1, ncol], [1, nbot_molec]) - molec_boundary = BoundaryFixedLayer(p%del(:,nbot_molec+1)) - - endif - - ! Boundary condition for a fixed concentration directly on a boundary - ! interface (i.e. a boundary layer of size 0). - interface_boundary = BoundaryFixedLayer(spread(0._r8, 1, ncol)) - - ! Note that the *derivative* dp/dz is g*rho - dpidz_sq = gravit*rhoi(:ncol,:) - dpidz_sq = dpidz_sq * dpidz_sq - - rrho(:ncol) = rair * t(:ncol,pver) / p%mid(:,pver) - - tmpi2(:ncol,1) = ztodt * dpidz_sq(:,1) / ( p%mid(:,1) - p%ifc(:,1) ) - tmpi2(:ncol,2:pver) = ztodt * dpidz_sq(:,2:pver) * p%rdst - - ! FIXME: The following four lines are kept in only to preserve answers; - ! they really should be taken out completely. - if (do_molec_diff) & - tmpi2(:ncol,1) = ztodt * (gravit * rhoi(:ncol,1))**2 / ( pmid(:ncol,1) - p%ifc(:,1) ) - dpidz_sq(:,1) = gravit*(p%ifc(:,1) / (rairv(:ncol,1,lchnk)*t(:ncol,1))) - dpidz_sq(:,1) = dpidz_sq(:,1)*dpidz_sq(:,1) - - tmp1(:ncol) = ztodt * gravit * p%rdel(:,pver) - - !---------------------------- ! - ! Diffuse Horizontal Momentum ! - !---------------------------- ! - - do k = 1, pver - do i = 1, ncol - keg_in(i,k) = 0.5_r8 * ( u(i,k)*u(i,k) + v(i,k)*v(i,k) ) - end do - end do - - if( diffuse(fieldlist,'u') .or. diffuse(fieldlist,'v') ) then - - ! Compute the vertical upward differences of the input u,v for KE dissipation - ! at each interface. - ! Velocity = 0 at surface, so difference at the bottom interface is -u,v(pver) - ! These 'dinp_u, dinp_v' are computed using the non-diffused input wind. - - do i = 1, ncol - dinp_u(i,1) = 0._r8 - dinp_v(i,1) = 0._r8 - dinp_u(i,pver+1) = -u(i,pver) - dinp_v(i,pver+1) = -v(i,pver) - end do - do k = 2, pver - do i = 1, ncol - dinp_u(i,k) = u(i,k) - u(i,k-1) - dinp_v(i,k) = v(i,k) - v(i,k-1) - end do - end do - - ! -------------------------------------------------------------- ! - ! Do 'Implicit Surface Stress' treatment for numerical stability ! - ! in the lowest model layer. ! - ! -------------------------------------------------------------- ! - - if( do_iss ) then - - ! Compute surface drag coefficient for implicit diffusion - ! including turbulent mountain stress. - - do i = 1, ncol - ws(i) = max( sqrt( u(i,pver)**2._r8 + v(i,pver)**2._r8 ), wsmin ) - tau(i) = sqrt( taux(i)**2._r8 + tauy(i)**2._r8 ) - ksrfturb(i) = max( tau(i) / ws(i), ksrfmin ) - end do - ksrf(:ncol) = ksrfturb(:ncol) + ksrftms(:ncol) ! Do all surface stress ( normal + tms ) implicitly - - ! Vertical integration of input momentum. - ! This is total horizontal momentum per unit area [ kg*m/s/m2 ] in each column. - ! Note (u,v) are the raw input to the PBL scheme, not the - ! provisionally-marched ones within the iteration loop of the PBL scheme. - - do i = 1, ncol - usum_in(i) = 0._r8 - vsum_in(i) = 0._r8 - do k = 1, pver - usum_in(i) = usum_in(i) + (1._r8/gravit)*u(i,k)*p%del(i,k) - vsum_in(i) = vsum_in(i) + (1._r8/gravit)*v(i,k)*p%del(i,k) - end do - end do - - ! Add residual stress of previous time step explicitly into the lowest - ! model layer with a relaxation time scale of 'timeres'. - - if (am_correction) then - ! preserve time-mean torque - ramda = 1._r8 - else - ramda = ztodt / timeres - endif - - u(:ncol,pver) = u(:ncol,pver) + tmp1(:ncol)*tauresx(:ncol)*ramda - v(:ncol,pver) = v(:ncol,pver) + tmp1(:ncol)*tauresy(:ncol)*ramda - - ! Vertical integration of momentum after adding explicit residual stress - ! into the lowest model layer. - - do i = 1, ncol - usum_mid(i) = 0._r8 - vsum_mid(i) = 0._r8 - do k = 1, pver - usum_mid(i) = usum_mid(i) + (1._r8/gravit)*u(i,k)*p%del(i,k) - vsum_mid(i) = vsum_mid(i) + (1._r8/gravit)*v(i,k)*p%del(i,k) - end do - end do - - else - - ! In this case, do 'turbulent mountain stress' implicitly, - ! but do 'normal turbulent stress' explicitly. - ! In this case, there is no 'residual stress' as long as 'tms' is - ! treated in a fully implicit way, which is true. - - ! 1. Do 'tms' implicitly - - ksrf(:ncol) = ksrftms(:ncol) - - ! 2. Do 'normal stress' explicitly - - u(:ncol,pver) = u(:ncol,pver) + tmp1(:ncol)*taux(:ncol) - v(:ncol,pver) = v(:ncol,pver) + tmp1(:ncol)*tauy(:ncol) - - end if ! End of 'do iss' ( implicit surface stress ) - - ! --------------------------------------------------------------------------------------- ! - ! Diffuse horizontal momentum implicitly using tri-diagnonal matrix. ! - ! The 'u,v' are input-output: the output 'u,v' are implicitly diffused winds. ! - ! For implicit 'normal' stress : ksrf = ksrftms + ksrfturb, ! - ! u(pver) : explicitly include 'residual normal' stress ! - ! For explicit 'normal' stress : ksrf = ksrftms ! - ! u(pver) : explicitly include 'normal' stress ! - ! Note that in all the two cases above, 'tms' is fully implicitly treated. ! - ! --------------------------------------------------------------------------------------- ! - - ! In most layers, no damping at all. - tau_damp_rate = 0._r8 - - ! Physical interpretation: - ! ksrf is stress per unit wind speed. - ! p%del / gravit is approximately the mass in the layer per unit of - ! surface area. - ! Therefore, gravit*ksrf/p%del is the acceleration of wind per unit - ! wind speed, i.e. the rate at which wind is exponentially damped by - ! surface stress. - - ! Beljaars et al SGO scheme incorporated here. It - ! appears as a "3D" tau_damp_rate specification. - - tau_damp_rate(:,pver) = -gravit*ksrf(:ncol)*p%rdel(:,pver) - do k=1,pver - tau_damp_rate(:,k) = tau_damp_rate(:,k) + dragblj(:ncol,k) - end do - - decomp = fin_vol_lu_decomp(ztodt, p, & - coef_q=tau_damp_rate, coef_q_diff=kvm(:ncol,:)*dpidz_sq) - - call decomp%left_div(u(:ncol,:)) - call decomp%left_div(v(:ncol,:)) - call decomp%finalize() - - ! ---------------------------------------------------------------------- ! - ! Calculate 'total' ( tautotx ) and 'tms' ( tautmsx ) stresses that ! - ! have been actually added into the atmosphere at the current time step. ! - ! Also, update residual stress, if required. ! - ! ---------------------------------------------------------------------- ! - - do i = 1, ncol - - ! Compute the implicit 'tms' using the updated winds. - ! Below 'tautmsx(i),tautmsy(i)' are pure implicit mountain stresses - ! that has been actually added into the atmosphere both for explicit - ! and implicit approach. - - tautmsx(i) = -ksrftms(i)*u(i,pver) - tautmsy(i) = -ksrftms(i)*v(i,pver) - - ! We want to add vertically-integrated Beljaars drag to residual stress. - ! So this has to be calculated locally. - ! We may want to rethink the residual drag calculation performed here on. (jtb) - taubljx(i) = 0._r8 - taubljy(i) = 0._r8 - do k = 1, pver - taubljx(i) = taubljx(i) + (1._r8/gravit)*dragblj(i,k)*u(i,k)*p%del(i,k) - taubljy(i) = taubljy(i) + (1._r8/gravit)*dragblj(i,k)*v(i,k)*p%del(i,k) - end do - - if( do_iss ) then - - ! Compute vertical integration of final horizontal momentum - - usum_out(i) = 0._r8 - vsum_out(i) = 0._r8 - do k = 1, pver - usum_out(i) = usum_out(i) + (1._r8/gravit)*u(i,k)*p%del(i,k) - vsum_out(i) = vsum_out(i) + (1._r8/gravit)*v(i,k)*p%del(i,k) - end do - - ! Compute net stress added into the atmosphere at the current time step. - ! Note that the difference between 'usum_in' and 'usum_out' are induced - ! by 'explicit residual stress + implicit total stress' for implicit case, while - ! by 'explicit normal stress + implicit tms stress' for explicit case. - ! Here, 'tautotx(i)' is net stress added into the air at the current time step. - - tauimpx(i) = ( usum_out(i) - usum_in(i) ) / ztodt - tauimpy(i) = ( vsum_out(i) - vsum_in(i) ) / ztodt - - tautotx(i) = tauimpx(i) - tautoty(i) = tauimpy(i) - - ! Compute residual stress and update if required. - ! Note that the total stress we should have added at the current step is - ! the sum of 'taux(i) - ksrftms(i)*u(i,pver) + tauresx(i)'. - - if( itaures .eq. 1 ) then - tauresx(i) = taux(i) + tautmsx(i) + taubljx(i) + tauresx(i)- tauimpx(i) - tauresy(i) = tauy(i) + tautmsy(i) + taubljy(i) + tauresy(i)- tauimpy(i) - endif - - else - - tautotx(i) = tautmsx(i) + taux(i) - tautoty(i) = tautmsy(i) + tauy(i) - tauresx(i) = 0._r8 - tauresy(i) = 0._r8 - - end if ! End of 'do_iss' if - - end do ! End of 'do i = 1, ncol' loop - - ! ------------------------------------ ! - ! Calculate kinetic energy dissipation ! - ! ------------------------------------ ! - - ! Modification : In future, this should be set exactly same as - ! the ones in the convection schemes - - ! 1. Compute dissipation term at interfaces - ! Note that 'u,v' are already diffused wind, and 'tautotx,tautoty' are - ! implicit stress that has been actually added. On the other hand, - ! 'dinp_u, dinp_v' were computed using non-diffused input wind. - - ! Modification : I should check whether non-consistency between 'u' and 'dinp_u' - ! is correctly intended approach. I think so. - - k = pver + 1 - do i = 1, ncol - tmpi1(i,1) = 0._r8 - tmpi1(i,k) = 0.5_r8 * ztodt * gravit * & - ( (-u(i,k-1) + dinp_u(i,k))*tautotx(i) + (-v(i,k-1) + dinp_v(i,k))*tautoty(i) ) - end do - - do k = 2, pver - do i = 1, ncol - dout_u = u(i,k) - u(i,k-1) - dout_v = v(i,k) - v(i,k-1) - tmpi1(i,k) = 0.25_r8 * tmpi2(i,k) * kvm(i,k) * & - ( dout_u**2 + dout_v**2 + dout_u*dinp_u(i,k) + dout_v*dinp_v(i,k) ) - end do - end do - - if (do_beljaars) then - - ! 2. Add Kinetic Energy change across dissipation to Static Energy - do k = 1, pver - do i = 1, ncol - keg_out(i,k) = 0.5_r8 * ( u(i,k)*u(i,k) + v(i,k)*v(i,k) ) - end do - end do - - do k = 1, pver - do i = 1, ncol - dtk(i,k) = keg_in(i,k) - keg_out(i,k) - dse(i,k) = dse(i,k) + dtk(i,k) ! + dkeblj(i,k) - end do - end do - - else - - ! 2. Compute dissipation term at midpoints, add to dry static energy - do k = 1, pver - do i = 1, ncol - dtk(i,k) = ( tmpi1(i,k+1) + tmpi1(i,k) ) * p%rdel(i,k) - dse(i,k) = dse(i,k) + dtk(i,k) - end do - end do - - end if - - end if ! End of diffuse horizontal momentum, diffuse(fieldlist,'u') routine - - !-------------------------- ! - ! Diffuse Dry Static Energy ! - !-------------------------- ! - - ! Modification : In future, we should diffuse the fully conservative - ! moist static energy,not the dry static energy. - - if( diffuse(fieldlist,'s') ) then - if (.not. use_spcam) then - - ! Add counter-gradient to input static energy profiles - - do k = 1, pver - dse(:ncol,k) = dse(:ncol,k) + ztodt * p%rdel(:,k) * gravit * & - ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgh(:ncol,k+1) & - - rhoi(:ncol,k ) * kvh(:ncol,k ) * cgh(:ncol,k ) ) - end do - endif - ! Add the explicit surface fluxes to the lowest layer - dse(:ncol,pver) = dse(:ncol,pver) + tmp1(:ncol) * shflx(:ncol) - - ! Diffuse dry static energy - - !--------------------------------------------------- - ! Solve for temperature using thermal conductivity - !--------------------------------------------------- - if ( use_temperature_molec_diff ) then - !---------------------------------------------------------------------------------------------------- - ! In Extended WACCM, kvt is calculated rather kvh. This is because molecular diffusion operates on - ! temperature, while eddy diffusion operates on dse. Also, pass in constituent dependent "constants" - !---------------------------------------------------------------------------------------------------- - - ! Boundary layer thickness of "0._r8" signifies that the boundary - ! condition is defined directly on the top interface. - decomp = fin_vol_lu_decomp(ztodt, p, & - coef_q_diff=kvh(:ncol,:)*dpidz_sq, & - upper_bndry=interface_boundary) - - if (.not. use_spcam) then - call decomp%left_div(dse(:ncol,:), & - l_cond=BoundaryData(dse_top(:ncol))) - endif - - call decomp%finalize() - - ! Calculate flux at top interface - - ! Modification : Why molecular diffusion does not work for dry static energy in all layers ? - - topflx(:ncol) = - kvh(:ncol,1) * tmpi2(:ncol,1) / (ztodt*gravit) * & - ( dse(:ncol,1) - dse_top(:ncol) ) - - decomp = fin_vol_lu_decomp(ztodt, p, & - coef_q_diff=kvt(:ncol,:)*dpidz_sq, & - coef_q_weight=cpairv(:ncol,:)) - - ttemp0 = t(:ncol,:) - ttemp = ttemp0 - - ! upper boundary is zero flux for extended model - if (.not. use_spcam) then - call decomp%left_div(ttemp) - end if - - call decomp%finalize() - - !------------------------------------- - ! Update dry static energy - !------------------------------------- - do k = 1,pver - dse(:ncol,k) = dse(:ncol,k) + & - cpairv(:ncol,k)*(ttemp(:,k) - ttemp0(:,k)) - enddo - - else - - if (do_molec_diff) then - kv_total(:ncol,:) = kvh(:ncol,:) + kvt(:ncol,:)/cpair - else - kv_total(:ncol,:) = kvh(:ncol,:) - end if - - ! Boundary layer thickness of "0._r8" signifies that the boundary - ! condition is defined directly on the top interface. - decomp = fin_vol_lu_decomp(ztodt, p, & - coef_q_diff=kv_total(:ncol,:)*dpidz_sq, & - upper_bndry=interface_boundary) - - if (.not. use_spcam) then - call decomp%left_div(dse(:ncol,:), & - l_cond=BoundaryData(dse_top(:ncol))) - end if - - call decomp%finalize() - - ! Calculate flux at top interface - - ! Modification : Why molecular diffusion does not work for dry static energy in all layers ? - - if( do_molec_diff ) then - topflx(:ncol) = - kv_total(:ncol,1) * tmpi2(:ncol,1) / (ztodt*gravit) * & - ( dse(:ncol,1) - dse_top(:ncol) ) - else - topflx(:ncol) = 0._r8 - end if - - endif - - endif - - !---------------------------- ! - ! Diffuse Water Vapor Tracers ! - !---------------------------- ! - - ! Modification : For aerosols, I need to use separate treatment - ! for aerosol mass and aerosol number. - - ! Loop through constituents - - no_molec_decomp = fin_vol_lu_decomp(ztodt, p, & - coef_q_diff=kvq(:ncol,:)*dpidz_sq) - - do m = 1, ncnst - - if( diffuse(fieldlist,'q',m) ) then - if (.not. use_spcam) then - - ! Add the nonlocal transport terms to constituents in the PBL. - ! Check for neg q's in each constituent and put the original vertical - ! profile back if a neg value is found. A neg value implies that the - ! quasi-equilibrium conditions assumed for the countergradient term are - ! strongly violated. - - qtm(:ncol,:pver) = q(:ncol,:pver,m) - - do k = 1, pver - q(:ncol,k,m) = q(:ncol,k,m) + & - ztodt * p%rdel(:,k) * gravit * ( cflx(:ncol,m) * rrho(:ncol) ) * & - ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgs(:ncol,k+1) & - - rhoi(:ncol,k ) * kvh(:ncol,k ) * cgs(:ncol,k ) ) - end do - lqtst(:ncol) = all(q(:ncol,1:pver,m) >= qmincg(m), 2) - do k = 1, pver - q(:ncol,k,m) = merge( q(:ncol,k,m), qtm(:ncol,k), lqtst(:ncol) ) - end do - endif - - ! Add the explicit surface fluxes to the lowest layer - - q(:ncol,pver,m) = q(:ncol,pver,m) + tmp1(:ncol) * cflx(:ncol,m) - - ! Diffuse constituents. - - ! This is for solving molecular diffusion of minor species, thus, for WACCM-X, bypass O and O2 (major species) - ! Major species diffusion is calculated separately. -Hanli Liu - - if( do_molec_diff .and. diffuse(fieldlistm,'q',m)) then - - decomp = vd_lu_qdecomp( pcols , pver , ncol , cnst_fixed_ubc(m), cnst_mw(m), & - kvq , kq_scal, mw_fac(:,:,m) ,dpidz_sq , p_molec, & - interface_boundary, molec_boundary, & - tint , ztodt , nbot_molec , & - lchnk , t , m , no_molec_decomp) - - ! This to calculate the upper boundary flux of H. -Hanli Liu - if ((cnst_fixed_ubflx(m))) then - - ! ubc_flux is a flux of mass density through space, i.e.: - ! ubc_flux = rho_i * dz/dt = q_i * rho * dz/dt - ! For flux of mmr through pressure level, multiply by g: - ! q_i * rho * gravit * dz/dt = q_i * dp/dt - - call decomp%left_div(q(:ncol,:,m), & - l_cond=BoundaryFlux( & - -gravit*ubc_flux(:ncol,m), ztodt, & - p%del(:,1))) - - else - call decomp%left_div(q(:ncol,:,m), & - l_cond=BoundaryData(ubc_mmr(:ncol,m))) - end if - - call decomp%finalize() - - else - - if (.not. use_spcam) then - ! Currently, no ubc for constituents without molecular - ! diffusion (they cannot diffuse out the top of the model). - call no_molec_decomp%left_div(q(:ncol,:,m)) - end if - - end if - - end if - end do - - call no_molec_decomp%finalize() - - end subroutine compute_vdiff - - ! =============================================================================== ! - ! ! - ! =============================================================================== ! - - character(128) function vdiff_select( fieldlist, name, qindex ) - ! --------------------------------------------------------------------- ! - ! This function sets the field with incoming name as one to be diffused ! - ! --------------------------------------------------------------------- ! - type(vdiff_selector), intent(inout) :: fieldlist - character(*), intent(in) :: name - integer, intent(in), optional :: qindex - - vdiff_select = '' - select case (name) - case ('u','U') - fieldlist%fields(1) = .true. - case ('v','V') - fieldlist%fields(2) = .true. - case ('s','S') - fieldlist%fields(3) = .true. - case ('q','Q') - if( present(qindex) ) then - fieldlist%fields(3 + qindex) = .true. - else - fieldlist%fields(4) = .true. - endif - case default - write(vdiff_select,*) 'Bad argument to vdiff_index: ', name - end select - return - - end function vdiff_select - - type(vdiff_selector) function not(a) - ! ------------------------------------------------------------- ! - ! This function extends .not. to operate on type vdiff_selector ! - ! ------------------------------------------------------------- ! - type(vdiff_selector), intent(in) :: a - allocate(not%fields(size(a%fields))) - not%fields = .not. a%fields - end function not - - logical function my_any(a) - ! -------------------------------------------------- ! - ! This function extends the intrinsic function 'any' ! - ! to operate on type vdiff_selector ! - ! -------------------------------------------------- ! - type(vdiff_selector), intent(in) :: a - my_any = any(a%fields) - end function my_any - - logical function diffuse(fieldlist,name,qindex) - ! ---------------------------------------------------------------------------- ! - ! This function reports whether the field with incoming name is to be diffused ! - ! ---------------------------------------------------------------------------- ! - type(vdiff_selector), intent(in) :: fieldlist - character(*), intent(in) :: name - integer, intent(in), optional :: qindex - - select case (name) - case ('u','U') - diffuse = fieldlist%fields(1) - case ('v','V') - diffuse = fieldlist%fields(2) - case ('s','S') - diffuse = fieldlist%fields(3) - case ('q','Q') - if( present(qindex) ) then - diffuse = fieldlist%fields(3 + qindex) - else - diffuse = fieldlist%fields(4) - endif - case default - diffuse = .false. - end select - return - end function diffuse - -end module diffusion_solver diff --git a/src/physics/cam/vertical_diffusion.F90 b/src/physics/cam/vertical_diffusion.F90 index ee9b2f1ce1..9fdc98b1e1 100644 --- a/src/physics/cam/vertical_diffusion.F90 +++ b/src/physics/cam/vertical_diffusion.F90 @@ -72,9 +72,6 @@ module vertical_diffusion use ref_pres, only : do_molec_diff, nbot_molec use phys_control, only : phys_getopts use time_manager, only : is_first_step -#ifdef OSLO_AERO - use oslo_aero_share, only: getNumberOfAerosolTracers, fillAerosolTracerList -#endif implicit none private @@ -321,16 +318,14 @@ subroutine vertical_diffusion_init(pbuf2d) ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. call phys_getopts(prog_modal_aero_out=prog_modal_aero) - -#ifdef OSLO_AERO - prog_modal_aero = .TRUE. - pmam_ncnst = getNumberOfAerosolTracers() - allocate(pmam_cnst_idx(pmam_ncnst)) - call fillAerosolTracerList(pmam_cnst_idx) -#else if (prog_modal_aero) then - ! NOTE THAT THIS BREAKS THE CONCEPT OF KEEPEING MAM-AEROSOLS OUT OF - ! DIFFUSION, BUT IF YOU ARE USING MAM, YOU SHOULD NOT BEE HERE ANYWAY!! + + ! Get the constituent indices of the number and mass mixing ratios of the modal + ! aerosols. + ! + ! N.B. - This implementation assumes that the prognostic modal aerosols are + ! impacting the climate calculation (i.e., can get info from list 0). + ! ! First need total number of mam constituents call rad_cnst_get_info(0, nmodes=nmodes) @@ -338,6 +333,7 @@ subroutine vertical_diffusion_init(pbuf2d) call rad_cnst_get_info(0, m, nspec=nspec) pmam_ncnst = pmam_ncnst + 1 + nspec end do + allocate(pmam_cnst_idx(pmam_ncnst)) ! Get the constituent indicies @@ -352,7 +348,6 @@ subroutine vertical_diffusion_init(pbuf2d) end do end do end if -#endif ! Initialize upper boundary condition module @@ -579,10 +574,6 @@ subroutine vertical_diffusion_init(pbuf2d) if( history_budget ) then call add_default( vdiffnam(ixcldliq), history_budget_histfile_num, ' ' ) call add_default( vdiffnam(ixcldice), history_budget_histfile_num, ' ' ) -#ifdef OSLO_AERO - call add_default( vdiffnam(ixnumliq), history_budget_histfile_num, ' ' ) - call add_default( vdiffnam(ixnumice), history_budget_histfile_num, ' ' ) -#endif if( history_budget_histfile_num > 1 ) then call add_default( vdiffnam(1), history_budget_histfile_num, ' ' ) call add_default( 'DTV' , history_budget_histfile_num, ' ' ) @@ -1062,16 +1053,16 @@ subroutine vertical_diffusion_tend( & tem2(:ncol,:), ftem(:ncol,:)) ftem_prePBL(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 - call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) - call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) - call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) - call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) - call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) + call outfld( 'qt_pre_PBL ', qt_prePBL, pcols, lchnk ) + call outfld( 'sl_pre_PBL ', sl_prePBL, pcols, lchnk ) + call outfld( 'slv_pre_PBL ', slv_prePBL, pcols, lchnk ) + call outfld( 'u_pre_PBL ', state%u, pcols, lchnk ) + call outfld( 'v_pre_PBL ', state%v, pcols, lchnk ) call outfld( 'qv_pre_PBL ', state%q(:,:,1), pcols, lchnk ) call outfld( 'ql_pre_PBL ', state%q(:,:,ixcldliq), pcols, lchnk ) call outfld( 'qi_pre_PBL ', state%q(:,:,ixcldice), pcols, lchnk ) - call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) - call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) + call outfld( 't_pre_PBL ', state%t, pcols, lchnk ) + call outfld( 'rh_pre_PBL ', ftem_prePBL, pcols, lchnk ) end if @@ -1179,14 +1170,11 @@ subroutine vertical_diffusion_tend( & ! Modal aerosol species not diffused, so just add the explicit surface fluxes to the ! lowest layer - ! NOTE: Oslo aero adds emissions together with dry deposition -#ifndef OSLO_AERO tmp1(:ncol) = ztodt * gravit * state%rpdel(:ncol,pver) do m = 1, pmam_ncnst l = pmam_cnst_idx(m) q_tmp(:ncol,pver,l) = q_tmp(:ncol,pver,l) + tmp1(:ncol) * cam_in%cflx(:ncol,l) enddo -#endif end if ! -------------------------------------------------------- ! @@ -1398,32 +1386,33 @@ subroutine vertical_diffusion_tend( & if (.not. do_pbl_diags) then - call outfld( 'sl_aft_PBL' , sl, pcols, lchnk ) - call outfld( 'qt_aft_PBL' , qt, pcols, lchnk ) - call outfld( 'slv_aft_PBL' , slv, pcols, lchnk ) - call outfld( 'u_aft_PBL' , u_aft_PBL, pcols, lchnk ) - call outfld( 'v_aft_PBL' , v_aft_PBL, pcols, lchnk ) - call outfld( 'qv_aft_PBL' , qv_aft_PBL, pcols, lchnk ) - call outfld( 'ql_aft_PBL' , ql_aft_PBL, pcols, lchnk ) - call outfld( 'qi_aft_PBL' , qi_aft_PBL, pcols, lchnk ) - call outfld( 't_aft_PBL ' , t_aftPBL, pcols, lchnk ) - call outfld( 'rh_aft_PBL' , ftem_aftPBL, pcols, lchnk ) - call outfld( 'slflx_PBL' , slflx, pcols, lchnk ) - call outfld( 'qtflx_PBL' , qtflx, pcols, lchnk ) - call outfld( 'uflx_PBL' , uflx, pcols, lchnk ) - call outfld( 'vflx_PBL' , vflx, pcols, lchnk ) - call outfld( 'slflx_cg_PBL' , slflx_cg, pcols, lchnk ) - call outfld( 'qtflx_cg_PBL' , qtflx_cg, pcols, lchnk ) - call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) - call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) - call outfld( 'slten_PBL' , slten, pcols, lchnk ) - call outfld( 'uten_PBL' , ptend%u(:,:), pcols, lchnk ) - call outfld( 'vten_PBL' , ptend%v(:,:), pcols, lchnk ) - call outfld( 'qvten_PBL' , ptend%q(:,:,1), pcols, lchnk ) - call outfld( 'qlten_PBL' , ptend%q(:,:,ixcldliq), pcols, lchnk ) - call outfld( 'qiten_PBL' , ptend%q(:,:,ixcldice), pcols, lchnk ) - call outfld( 'tten_PBL' , tten, pcols, lchnk ) - call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) + call outfld( 'sl_aft_PBL' , sl, pcols, lchnk ) + call outfld( 'qt_aft_PBL' , qt, pcols, lchnk ) + call outfld( 'slv_aft_PBL' , slv, pcols, lchnk ) + call outfld( 'u_aft_PBL' , u_aft_PBL, pcols, lchnk ) + call outfld( 'v_aft_PBL' , v_aft_PBL, pcols, lchnk ) + call outfld( 'qv_aft_PBL' , qv_aft_PBL, pcols, lchnk ) + call outfld( 'ql_aft_PBL' , ql_aft_PBL, pcols, lchnk ) + call outfld( 'qi_aft_PBL' , qi_aft_PBL, pcols, lchnk ) + call outfld( 't_aft_PBL ' , t_aftPBL, pcols, lchnk ) + call outfld( 'rh_aft_PBL' , ftem_aftPBL, pcols, lchnk ) + call outfld( 'slflx_PBL' , slflx, pcols, lchnk ) + call outfld( 'qtflx_PBL' , qtflx, pcols, lchnk ) + call outfld( 'uflx_PBL' , uflx, pcols, lchnk ) + call outfld( 'vflx_PBL' , vflx, pcols, lchnk ) + call outfld( 'slflx_cg_PBL' , slflx_cg, pcols, lchnk ) + call outfld( 'qtflx_cg_PBL' , qtflx_cg, pcols, lchnk ) + call outfld( 'uflx_cg_PBL' , uflx_cg, pcols, lchnk ) + call outfld( 'vflx_cg_PBL' , vflx_cg, pcols, lchnk ) + call outfld( 'slten_PBL' , slten, pcols, lchnk ) + call outfld( 'qtten_PBL' , qtten, pcols, lchnk ) + call outfld( 'uten_PBL' , ptend%u(:,:), pcols, lchnk ) + call outfld( 'vten_PBL' , ptend%v(:,:), pcols, lchnk ) + call outfld( 'qvten_PBL' , ptend%q(:,:,1), pcols, lchnk ) + call outfld( 'qlten_PBL' , ptend%q(:,:,ixcldliq), pcols, lchnk ) + call outfld( 'qiten_PBL' , ptend%q(:,:,ixcldice), pcols, lchnk ) + call outfld( 'tten_PBL' , tten, pcols, lchnk ) + call outfld( 'rhten_PBL' , rhten, pcols, lchnk ) end if diff --git a/src/physics/cam/zm_microphysics.F90 b/src/physics/cam/zm_microphysics.F90 index 8c6eb9c864..29607725bc 100644 --- a/src/physics/cam/zm_microphysics.F90 +++ b/src/physics/cam/zm_microphysics.F90 @@ -1465,13 +1465,12 @@ subroutine zm_mphy(su, qu, mu, du, eu, cmel, cmei, zf, pm, te, end if -#ifndef OSLO_AERO call activate_modal( & wu(i,k), wmix, wdiab, wmin, wmax, & t(i,k), rho(i,k), naermod, aero%nmodes, vaerosol, & hygro, fn, fm, & fluxn, fluxm, flux_fullact, in_cloud_in=in_cloud, smax_f=smax_f) -#endif + do m = 1, aero%nmodes nlsrc = nlsrc + fn(m)*naermod(m) ! number nucleated end do diff --git a/src/physics/rrtmg/radiation.F90 b/src/physics/rrtmg/radiation.F90 index 8e77504688..e65809c11d 100644 --- a/src/physics/rrtmg/radiation.F90 +++ b/src/physics/rrtmg/radiation.F90 @@ -1,1699 +1,1428 @@ module radiation - !--------------------------------------------------------------------------------- - ! - ! CAM interface to RRTMG radiation parameterization - ! - !--------------------------------------------------------------------------------- - - use shr_kind_mod, only: r8=>shr_kind_r8 - use spmd_utils, only: masterproc - use ppgrid, only: pcols, pver, pverp, begchunk, endchunk - use physics_types, only: physics_state, physics_ptend - use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx - use camsrfexch, only: cam_out_t, cam_in_t - use physconst, only: cappa, cpair - - use time_manager, only: get_nstep, is_first_restart_step, & - get_curr_calday, get_step_size - - use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_info, & - rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & - liqcldoptics, icecldoptics - - use radconstants, only: nswbands, nlwbands, rrtmg_sw_cloudsim_band, rrtmg_lw_cloudsim_band, & - idx_sw_diag - - use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & - cospsimulator_intr_run, cosp_nradsteps - - use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs - - use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active - use cam_history_support, only: fillvalue - - use pio, only: file_desc_t, var_desc_t, & - pio_int, pio_noerr, & - pio_seterrorhandling, pio_bcast_error, & - pio_inq_varid, pio_def_var, & - pio_put_var, pio_get_var - - use cam_abortutils, only: endrun - use error_messages, only: handle_err - use perf_mod, only: t_startf, t_stopf - use cam_logfile, only: iulog -#ifdef OSLO_AERO - use prescribed_volcaero, only: has_prescribed_volcaero, has_prescribed_volcaero_cmip6, solar_bands, terrestrial_bands - use oslo_aero_optical_params, only: oslo_aero_optical_params_calc - use oslo_aero_params, only: nmodes, nbmodes -#endif - - implicit none - private - - public :: & - radiation_readnl, &! read namelist variables - radiation_register, &! registers radiation physics buffer fields - radiation_nextsw_cday, &! calendar day of next radiation calculation - radiation_do, &! query which radiation calcs are done this timestep - radiation_init, &! initialization - radiation_define_restart, &! define variables for restart - radiation_write_restart, &! write variables to restart - radiation_read_restart, &! read variables from restart - radiation_tend, &! compute heating rates and fluxes - rad_out_t ! type for diagnostic outputs - - integer,public, allocatable :: cosp_cnt(:) ! counter for cosp - integer,public :: cosp_cnt_init = 0 !initial value for cosp counter - - type rad_out_t - - real(r8) :: solin(pcols) ! Solar incident flux - - real(r8) :: qrsc(pcols,pver) - - real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux - real(r8) :: fsntoa(pcols) ! Net solar flux at TOA - real(r8) :: fsntoac(pcols) ! Clear sky net solar flux at TOA - real(r8) :: fsutoa(pcols) ! upwelling solar flux at TOA - - real(r8) :: fsnirt(pcols) ! Near-IR flux absorbed at toa - real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa - real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns - - real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb - real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb - real(r8) :: fsnr(pcols) ! fns interpolated to tropopause - - real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux - real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux - - real(r8) :: qrlc(pcols,pver) - - real(r8) :: flntc(pcols) ! Clear sky lw flux at model top - real(r8) :: flut(pcols) ! Upward flux at top of model - real(r8) :: flutc(pcols) ! Upward Clear Sky flux at top of model - real(r8) :: lwcf(pcols) ! longwave cloud forcing - - real(r8) :: fln200(pcols) ! net longwave flux interpolated to 200 mb - real(r8) :: fln200c(pcols) ! net clearsky longwave flux interpolated to 200 mb - real(r8) :: flnr(pcols) ! net longwave flux interpolated to tropopause - - real(r8) :: flnsc(pcols) ! Clear sky lw flux at srf (up-down) - real(r8) :: fldsc(pcols) ! Clear sky lw flux at srf (down) - - real(r8) :: tot_cld_vistau(pcols,pver) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: tot_icld_vistau(pcols,pver) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth (only during day, night = fillvalue) - real(r8) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth (only during day, night = fillvalue) - real(r8) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth for output on history files - - real(r8) :: cld_tau_cloudsim(pcols,pver) - real(r8) :: aer_tau400(pcols,0:pver) - real(r8) :: aer_tau550(pcols,0:pver) - real(r8) :: aer_tau700(pcols,0:pver) - - end type rad_out_t - - ! Namelist variables - - integer :: iradsw = -1 ! freq. of shortwave radiation calc in time steps (positive) - ! or hours (negative). - integer :: iradlw = -1 ! frequency of longwave rad. calc. in time steps (positive) - ! or hours (negative). - - integer :: irad_always = 0 ! Specifies length of time in timesteps (positive) - ! or hours (negative) SW/LW radiation will be - ! run continuously from the start of an - ! initial or restart run - logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations - logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. - - ! Physics buffer indices - integer :: qrs_idx = 0 - integer :: qrl_idx = 0 - integer :: su_idx = 0 - integer :: sd_idx = 0 - integer :: lu_idx = 0 - integer :: ld_idx = 0 - integer :: fsds_idx = 0 - integer :: fsns_idx = 0 - integer :: fsnt_idx = 0 - integer :: flns_idx = 0 - integer :: flnt_idx = 0 - integer :: cldfsnow_idx = 0 - integer :: cld_idx = 0 -#ifdef OSLO_AERO - integer :: volc_idx = 0 -#endif - - character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) - - ! averaging time interval for zenith angle - real(r8) :: dt_avg = 0._r8 - - ! PIO descriptors (for restarts) - type(var_desc_t) :: cospcnt_desc - -#ifdef AEROCOM - logical :: do_aerocom = .true. -#else - logical :: do_aerocom = .false. -#endif +!--------------------------------------------------------------------------------- +! +! CAM interface to RRTMG radiation parameterization +! +!--------------------------------------------------------------------------------- + +use shr_kind_mod, only: r8=>shr_kind_r8 +use spmd_utils, only: masterproc +use ppgrid, only: pcols, pver, pverp, begchunk, endchunk +use physics_types, only: physics_state, physics_ptend +use physics_buffer, only: physics_buffer_desc, pbuf_get_field, pbuf_old_tim_idx +use camsrfexch, only: cam_out_t, cam_in_t +use physconst, only: cappa, cpair + +use time_manager, only: get_nstep, is_first_restart_step, & + get_curr_calday, get_step_size + +use rad_constituents, only: N_DIAG, rad_cnst_get_call_list, rad_cnst_get_info, & + rad_cnst_get_gas, rad_cnst_out, oldcldoptics, & + liqcldoptics, icecldoptics + +use radconstants, only: nswbands, nlwbands, rrtmg_sw_cloudsim_band, rrtmg_lw_cloudsim_band, & + idx_sw_diag + +use cospsimulator_intr, only: docosp, cospsimulator_intr_init, & + cospsimulator_intr_run, cosp_nradsteps + +use scamMod, only: scm_crm_mode, single_column, have_cld, cldobs + +use cam_history, only: addfld, add_default, horiz_only, outfld, hist_fld_active +use cam_history_support, only: fillvalue + +use pio, only: file_desc_t, var_desc_t, & + pio_int, pio_noerr, & + pio_seterrorhandling, pio_bcast_error, & + pio_inq_varid, pio_def_var, & + pio_put_var, pio_get_var + +use cam_abortutils, only: endrun +use error_messages, only: handle_err +use perf_mod, only: t_startf, t_stopf +use cam_logfile, only: iulog + +implicit none +private +save + +public :: & + radiation_readnl, &! read namelist variables + radiation_register, &! registers radiation physics buffer fields + radiation_nextsw_cday, &! calendar day of next radiation calculation + radiation_do, &! query which radiation calcs are done this timestep + radiation_init, &! initialization + radiation_define_restart, &! define variables for restart + radiation_write_restart, &! write variables to restart + radiation_read_restart, &! read variables from restart + radiation_tend, &! compute heating rates and fluxes + rad_out_t ! type for diagnostic outputs + +integer,public, allocatable :: cosp_cnt(:) ! counter for cosp +integer,public :: cosp_cnt_init = 0 !initial value for cosp counter + +type rad_out_t + real(r8) :: solin(pcols) ! Solar incident flux + + real(r8) :: qrsc(pcols,pver) + + real(r8) :: fsntc(pcols) ! Clear sky total column abs solar flux + real(r8) :: fsntoa(pcols) ! Net solar flux at TOA + real(r8) :: fsntoac(pcols) ! Clear sky net solar flux at TOA + real(r8) :: fsutoa(pcols) ! upwelling solar flux at TOA + + real(r8) :: fsnirt(pcols) ! Near-IR flux absorbed at toa + real(r8) :: fsnrtc(pcols) ! Clear sky near-IR flux absorbed at toa + real(r8) :: fsnirtsq(pcols) ! Near-IR flux absorbed at toa >= 0.7 microns + + real(r8) :: fsn200(pcols) ! fns interpolated to 200 mb + real(r8) :: fsn200c(pcols) ! fcns interpolated to 200 mb + real(r8) :: fsnr(pcols) ! fns interpolated to tropopause + + real(r8) :: fsnsc(pcols) ! Clear sky surface abs solar flux + real(r8) :: fsdsc(pcols) ! Clear sky surface downwelling solar flux + + real(r8) :: qrlc(pcols,pver) + + real(r8) :: flntc(pcols) ! Clear sky lw flux at model top + real(r8) :: flut(pcols) ! Upward flux at top of model + real(r8) :: flutc(pcols) ! Upward Clear Sky flux at top of model + real(r8) :: lwcf(pcols) ! longwave cloud forcing + + real(r8) :: fln200(pcols) ! net longwave flux interpolated to 200 mb + real(r8) :: fln200c(pcols) ! net clearsky longwave flux interpolated to 200 mb + real(r8) :: flnr(pcols) ! net longwave flux interpolated to tropopause + + real(r8) :: flnsc(pcols) ! Clear sky lw flux at srf (up-down) + real(r8) :: fldsc(pcols) ! Clear sky lw flux at srf (down) + + real(r8) :: tot_cld_vistau(pcols,pver) ! gbx water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: tot_icld_vistau(pcols,pver) ! in-cld water+ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: liq_icld_vistau(pcols,pver) ! in-cld liq cloud optical depth (only during day, night = fillvalue) + real(r8) :: ice_icld_vistau(pcols,pver) ! in-cld ice cloud optical depth (only during day, night = fillvalue) + real(r8) :: snow_icld_vistau(pcols,pver) ! snow in-cloud visible sw optical depth for output on history files + + real(r8) :: cld_tau_cloudsim(pcols,pver) + real(r8) :: aer_tau400(pcols,0:pver) + real(r8) :: aer_tau550(pcols,0:pver) + real(r8) :: aer_tau700(pcols,0:pver) + +end type rad_out_t + +! Namelist variables + +integer :: iradsw = -1 ! freq. of shortwave radiation calc in time steps (positive) + ! or hours (negative). +integer :: iradlw = -1 ! frequency of longwave rad. calc. in time steps (positive) + ! or hours (negative). + +integer :: irad_always = 0 ! Specifies length of time in timesteps (positive) + ! or hours (negative) SW/LW radiation will be + ! run continuously from the start of an + ! initial or restart run +logical :: use_rad_dt_cosz = .false. ! if true, use radiation dt for all cosz calculations +logical :: spectralflux = .false. ! calculate fluxes (up and down) per band. + +! Physics buffer indices +integer :: qrs_idx = 0 +integer :: qrl_idx = 0 +integer :: su_idx = 0 +integer :: sd_idx = 0 +integer :: lu_idx = 0 +integer :: ld_idx = 0 +integer :: fsds_idx = 0 +integer :: fsns_idx = 0 +integer :: fsnt_idx = 0 +integer :: flns_idx = 0 +integer :: flnt_idx = 0 +integer :: cldfsnow_idx = 0 +integer :: cld_idx = 0 + +character(len=4) :: diag(0:N_DIAG) =(/' ','_d1 ','_d2 ','_d3 ','_d4 ','_d5 ','_d6 ','_d7 ','_d8 ','_d9 ','_d10'/) + +! averaging time interval for zenith angle +real(r8) :: dt_avg = 0._r8 + +! PIO descriptors (for restarts) +type(var_desc_t) :: cospcnt_desc !=============================================================================== contains !=============================================================================== - subroutine radiation_readnl(nlfile) +subroutine radiation_readnl(nlfile) - ! Read radiation_nl namelist group. + ! Read radiation_nl namelist group. - use namelist_utils, only: find_group_name - use units, only: getunit, freeunit - use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical + use namelist_utils, only: find_group_name + use units, only: getunit, freeunit + use spmd_utils, only: mpicom, mstrid=>masterprocid, mpi_integer, mpi_logical - character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input + character(len=*), intent(in) :: nlfile ! filepath for file containing namelist input - ! Local variables - integer :: unitn, ierr - integer :: dtime ! timestep size - character(len=*), parameter :: sub = 'radiation_readnl' + ! Local variables + integer :: unitn, ierr + integer :: dtime ! timestep size + character(len=*), parameter :: sub = 'radiation_readnl' - namelist /radiation_nl/ iradsw, iradlw, irad_always, & - use_rad_dt_cosz, spectralflux - !----------------------------------------------------------------------------- - - if (masterproc) then - unitn = getunit() - open( unitn, file=trim(nlfile), status='old' ) - call find_group_name(unitn, 'radiation_nl', status=ierr) - if (ierr == 0) then - read(unitn, radiation_nl, iostat=ierr) - if (ierr /= 0) then - call endrun(sub // ':: ERROR reading namelist') - end if - end if - close(unitn) - call freeunit(unitn) - end if + namelist /radiation_nl/ iradsw, iradlw, irad_always, & + use_rad_dt_cosz, spectralflux + !----------------------------------------------------------------------------- + + if (masterproc) then + unitn = getunit() + open( unitn, file=trim(nlfile), status='old' ) + call find_group_name(unitn, 'radiation_nl', status=ierr) + if (ierr == 0) then + read(unitn, radiation_nl, iostat=ierr) + if (ierr /= 0) then + call endrun(sub // ':: ERROR reading namelist') + end if + end if + close(unitn) + call freeunit(unitn) + end if - ! Broadcast namelist variables - call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradsw") - call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradlw") - call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: irad_always") - call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_dt_cosz") - call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) - if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: spectralflux") + ! Broadcast namelist variables + call mpi_bcast(iradsw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradsw") + call mpi_bcast(iradlw, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: iradlw") + call mpi_bcast(irad_always, 1, mpi_integer, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: irad_always") + call mpi_bcast(use_rad_dt_cosz, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: use_rad_dt_cosz") + call mpi_bcast(spectralflux, 1, mpi_logical, mstrid, mpicom, ierr) + if (ierr /= 0) call endrun(sub//": FATAL: mpi_bcast: spectralflux") - ! Convert iradsw, iradlw and irad_always from hours to timesteps if necessary - dtime = get_step_size() - if (iradsw < 0) iradsw = nint((-iradsw *3600._r8)/dtime) - if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) - if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) + ! Convert iradsw, iradlw and irad_always from hours to timesteps if necessary + dtime = get_step_size() + if (iradsw < 0) iradsw = nint((-iradsw *3600._r8)/dtime) + if (iradlw < 0) iradlw = nint((-iradlw *3600._r8)/dtime) + if (irad_always < 0) irad_always = nint((-irad_always*3600._r8)/dtime) + + !----------------------------------------------------------------------- + ! Print runtime options to log. + !----------------------------------------------------------------------- + + if (masterproc) then + write(iulog,*) 'RRTMG radiation scheme parameters:' + write(iulog,10) iradsw, iradlw, irad_always, use_rad_dt_cosz, spectralflux + end if + +10 format(' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & + ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & + ' SW/LW calc done every timestep for first N steps. N=',i5/, & + ' Use average zenith angle: ',l5/, & + ' Output spectrally resolved fluxes: ',l5/) + +end subroutine radiation_readnl + +!================================================================================================ + +subroutine radiation_register + + ! Register radiation fields in the physics buffer + + use physics_buffer, only: pbuf_add_field, dtype_r8 + use radiation_data, only: rad_data_register + + call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate + call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate + + call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux + call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux + call pbuf_add_field('FSNT' , 'global',dtype_r8,(/pcols/), fsnt_idx) ! Top-of-model net shortwave flux + + call pbuf_add_field('FLNS' , 'global',dtype_r8,(/pcols/), flns_idx) ! Surface net longwave flux + call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux + + ! If the namelist has been configured for preserving the spectral fluxes, then create + ! physics buffer variables to store the results. + if (spectralflux) then + call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) + call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) + call pbuf_add_field('LU' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), lu_idx) ! longwave upward flux (per band) + call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) + end if + + call rad_data_register() + +end subroutine radiation_register + +!================================================================================================ + +function radiation_do(op, timestep) + + ! Return true if the specified operation is done this timestep. + + character(len=*), intent(in) :: op ! name of operation + integer, intent(in), optional:: timestep + logical :: radiation_do ! return value + + ! Local variables + integer :: nstep ! current timestep number + !----------------------------------------------------------------------- + + if (present(timestep)) then + nstep = timestep + else + nstep = get_nstep() + end if + + select case (op) + + case ('sw') ! do a shortwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradsw == 1 & + .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + case ('lw') ! do a longwave heating calc this timestep? + radiation_do = nstep == 0 .or. iradlw == 1 & + .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & + .or. nstep <= irad_always + + case default + call endrun('radiation_do: unknown operation:'//op) + + end select +end function radiation_do + +!================================================================================================ + +real(r8) function radiation_nextsw_cday() + + ! Return calendar day of next sw radiation calculation + + ! Local variables + integer :: nstep ! timestep counter + logical :: dosw ! true => do shosrtwave calc + integer :: offset ! offset for calendar day calculation + integer :: dTime ! integer timestep size + real(r8):: calday ! calendar day of + !----------------------------------------------------------------------- + + radiation_nextsw_cday = -1._r8 + dosw = .false. + nstep = get_nstep() + dtime = get_step_size() + offset = 0 + do while (.not. dosw) + nstep = nstep + 1 + offset = offset + dtime + if (radiation_do('sw', nstep)) then + radiation_nextsw_cday = get_curr_calday(offset=offset) + dosw = .true. + end if + end do + if(radiation_nextsw_cday == -1._r8) then + call endrun('error in radiation_nextsw_cday') + end if + +end function radiation_nextsw_cday + +!================================================================================================ + +subroutine radiation_init(pbuf2d) + + ! Initialize the radiation parameterization, add fields to the history buffer + + use physics_buffer, only: pbuf_get_index, pbuf_set_field + use phys_control, only: phys_getopts + use radsw, only: radsw_init + use radlw, only: radlw_init + use rad_solar_var, only: rad_solar_var_init + use radiation_data, only: rad_data_init + use cloud_rad_props, only: cloud_rad_props_init + use modal_aer_opt, only: modal_aer_opt_init + use rrtmg_state, only: rrtmg_state_init + use time_manager, only: is_first_step + + + ! arguments + type(physics_buffer_desc), pointer :: pbuf2d(:,:) + + ! local variables + integer :: icall, nmodes + logical :: active_calls(0:N_DIAG) + integer :: nstep ! current timestep number + logical :: history_amwg ! output the variables used by the AMWG diag package + logical :: history_vdiag ! output the variables used by the AMWG variability diag package + logical :: history_budget ! output tendencies and state variables for CAM4 + ! temperature, water vapor, cloud ice and cloud + ! liquid budgets. + integer :: history_budget_histfile_num ! output history file number for budget fields + integer :: err + + integer :: dtime + !----------------------------------------------------------------------- + + call rad_solar_var_init() + call rrtmg_state_init() + call rad_data_init(pbuf2d) ! initialize output fields for offline driver + call radsw_init() + call radlw_init() + call cloud_rad_props_init() + + cld_idx = pbuf_get_index('CLD') + cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err) + + if (is_first_step()) then + call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) + end if + + ! Set the radiation timestep for cosz calculations if requested using the adjusted iradsw value from radiation + if (use_rad_dt_cosz) then + dtime = get_step_size() + dt_avg = iradsw*dtime + end if + + call phys_getopts(history_amwg_out = history_amwg, & + history_vdiag_out = history_vdiag, & + history_budget_out = history_budget, & + history_budget_histfile_num_out = history_budget_histfile_num) + + ! Determine whether modal aerosols are affecting the climate, and if so + ! then initialize the modal aerosol optics module + call rad_cnst_get_info(0, nmodes=nmodes) + if (nmodes > 0) call modal_aer_opt_init() + + ! "irad_always" is number of time steps to execute radiation continuously from start of + ! initial OR restart run + nstep = get_nstep() + if (irad_always > 0) then + nstep = get_nstep() + irad_always = irad_always + nstep + end if + + if (docosp) call cospsimulator_intr_init + + allocate(cosp_cnt(begchunk:endchunk)) + if (is_first_restart_step()) then + cosp_cnt(begchunk:endchunk) = cosp_cnt_init + else + cosp_cnt(begchunk:endchunk) = 0 + end if + + call addfld('O3colAbove', horiz_only, 'A', 'DU', 'Column O3 above model top', sampling_seq='rad_lwsw') + + call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total gbx cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('TOT_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('LIQ_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Liquid in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + call addfld('ICE_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Ice in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + + if (cldfsnow_idx > 0) then + call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Snow in-cloud extinction visible sw optical depth', & + sampling_seq='rad_lwsw', flag_xyfill=.true.) + endif + + ! get list of active radiation calls + call rad_cnst_get_call_list(active_calls) + + ! Add shortwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + + call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') + + call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') + call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & + sampling_seq='rad_lwsw') + call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & + sampling_seq='rad_lwsw') + call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & + sampling_seq='rad_lwsw') + call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') + call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & + 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') + + call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & + sampling_seq='rad_lwsw') + + call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & + sampling_seq='rad_lwsw') + + call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & + sampling_seq='rad_lwsw') + call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & + sampling_seq='rad_lwsw') + + call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') + call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') + call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') + call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') + + if (history_amwg) then + call add_default('SOLIN'//diag(icall), 1, ' ') + call add_default('QRS'//diag(icall), 1, ' ') + call add_default('FSNT'//diag(icall), 1, ' ') + call add_default('FSNTC'//diag(icall), 1, ' ') + call add_default('FSNTOA'//diag(icall), 1, ' ') + call add_default('FSNTOAC'//diag(icall), 1, ' ') + call add_default('SWCF'//diag(icall), 1, ' ') + call add_default('FSNS'//diag(icall), 1, ' ') + call add_default('FSNSC'//diag(icall), 1, ' ') + call add_default('FSUTOA'//diag(icall), 1, ' ') + call add_default('FSDSC'//diag(icall), 1, ' ') + call add_default('FSDS'//diag(icall), 1, ' ') + endif + + end if + end do + + if (scm_crm_mode) then + call add_default('FUS ', 1, ' ') + call add_default('FUSC ', 1, ' ') + call add_default('FDS ', 1, ' ') + call add_default('FDSC ', 1, ' ') + endif + + ! Add longwave radiation fields to history master field list. + + do icall = 0, N_DIAG + + if (active_calls(icall)) then + + call addfld('QRL'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Longwave heating rate', sampling_seq='rad_lwsw') + call addfld('QRLC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky longwave heating rate', & + sampling_seq='rad_lwsw') + call addfld('FLNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLNTCLR'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky ONLY points net longwave flux at top of model',& + sampling_seq='rad_lwsw') + call addfld('FREQCLR'//diag(icall), horiz_only, 'A', 'Frac', 'Frequency of Occurrence of Clearsky', & + sampling_seq='rad_lwsw') + call addfld('FLUT'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('FLUTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky upwelling longwave flux at top of model', & + sampling_seq='rad_lwsw') + call addfld('LWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Longwave cloud forcing', sampling_seq='rad_lwsw') + + call addfld('FLN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FLN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at 200 mb', & + sampling_seq='rad_lwsw') + call addfld('FLNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at tropopause', & + sampling_seq='rad_lwsw') + + call addfld('FLNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky Downwelling longwave flux at surface', & + sampling_seq='rad_lwsw') + call addfld('FUL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave upward flux') + call addfld('FDL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave downward flux') + call addfld('FULC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky upward flux') + call addfld('FDLC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky downward flux') + + if (history_amwg) then + call add_default('QRL'//diag(icall), 1, ' ') + call add_default('FLNT'//diag(icall), 1, ' ') + call add_default('FLNTC'//diag(icall), 1, ' ') + call add_default('FLNTCLR'//diag(icall), 1, ' ') + call add_default('FREQCLR'//diag(icall), 1, ' ') + call add_default('FLUT'//diag(icall), 1, ' ') + call add_default('FLUTC'//diag(icall), 1, ' ') + call add_default('LWCF'//diag(icall), 1, ' ') + call add_default('FLNS'//diag(icall), 1, ' ') + call add_default('FLNSC'//diag(icall), 1, ' ') + call add_default('FLDS'//diag(icall), 1, ' ') + endif + + end if + end do + + call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') + + if (scm_crm_mode) then + call add_default ('FUL ', 1, ' ') + call add_default ('FULC ', 1, ' ') + call add_default ('FDL ', 1, ' ') + call add_default ('FDLC ', 1, ' ') + endif + + ! Heating rate needed for d(theta)/dt computation + call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') + + if ( history_budget .and. history_budget_histfile_num > 1 ) then + call add_default ('QRL ', history_budget_histfile_num, ' ') + call add_default ('QRS ', history_budget_histfile_num, ' ') + end if + + if (history_vdiag) then + call add_default('FLUT', 2, ' ') + call add_default('FLUT', 3, ' ') + end if + +end subroutine radiation_init - !----------------------------------------------------------------------- - ! Print runtime options to log. - !----------------------------------------------------------------------- +!=============================================================================== + +subroutine radiation_define_restart(file) + + ! define variables to be written to restart file + + ! arguments + type(file_desc_t), intent(inout) :: file - if (masterproc) then - write(iulog,*) 'RRTMG radiation scheme parameters:' - write(iulog,10) iradsw, iradlw, irad_always, use_rad_dt_cosz, spectralflux - end if - -10 format(' Frequency (timesteps) of Shortwave Radiation calc: ',i5/, & - ' Frequency (timesteps) of Longwave Radiation calc: ',i5/, & - ' SW/LW calc done every timestep for first N steps. N=',i5/, & - ' Use average zenith angle: ',l5/, & - ' Output spectrally resolved fluxes: ',l5/) - - end subroutine radiation_readnl - - !================================================================================================ - - subroutine radiation_register - - ! Register radiation fields in the physics buffer - - use physics_buffer, only: pbuf_add_field, dtype_r8 - use radiation_data, only: rad_data_register + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- - call pbuf_add_field('QRS' , 'global',dtype_r8,(/pcols,pver/), qrs_idx) ! shortwave radiative heating rate - call pbuf_add_field('QRL' , 'global',dtype_r8,(/pcols,pver/), qrl_idx) ! longwave radiative heating rate - - call pbuf_add_field('FSDS' , 'global',dtype_r8,(/pcols/), fsds_idx) ! Surface solar downward flux - call pbuf_add_field('FSNS' , 'global',dtype_r8,(/pcols/), fsns_idx) ! Surface net shortwave flux - call pbuf_add_field('FSNT' , 'global',dtype_r8,(/pcols/), fsnt_idx) ! Top-of-model net shortwave flux - - call pbuf_add_field('FLNS' , 'global',dtype_r8,(/pcols/), flns_idx) ! Surface net longwave flux - call pbuf_add_field('FLNT' , 'global',dtype_r8,(/pcols/), flnt_idx) ! Top-of-model net longwave flux - - ! If the namelist has been configured for preserving the spectral fluxes, then create - ! physics buffer variables to store the results. - if (spectralflux) then - call pbuf_add_field('SU' , 'global',dtype_r8,(/pcols,pverp,nswbands/), su_idx) ! shortwave upward flux (per band) - call pbuf_add_field('SD' , 'global',dtype_r8,(/pcols,pverp,nswbands/), sd_idx) ! shortwave downward flux (per band) - call pbuf_add_field('LU' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), lu_idx) ! longwave upward flux (per band) - call pbuf_add_field('LD' , 'global',dtype_r8,(/pcols,pverp,nlwbands/), ld_idx) ! longwave downward flux (per band) - end if - - call rad_data_register() - - end subroutine radiation_register - - !================================================================================================ - - function radiation_do(op, timestep) - - ! Return true if the specified operation is done this timestep. - - character(len=*), intent(in) :: op ! name of operation - integer, intent(in), optional:: timestep - logical :: radiation_do ! return value - - ! Local variables - integer :: nstep ! current timestep number - !----------------------------------------------------------------------- - - if (present(timestep)) then - nstep = timestep - else - nstep = get_nstep() - end if - - select case (op) - - case ('sw') ! do a shortwave heating calc this timestep? - radiation_do = nstep == 0 .or. iradsw == 1 & - .or. (mod(nstep-1,iradsw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - case ('lw') ! do a longwave heating calc this timestep? - radiation_do = nstep == 0 .or. iradlw == 1 & - .or. (mod(nstep-1,iradlw) == 0 .and. nstep /= 1) & - .or. nstep <= irad_always - - case default - call endrun('radiation_do: unknown operation:'//op) - - end select - end function radiation_do - - !================================================================================================ - - real(r8) function radiation_nextsw_cday() - - ! Return calendar day of next sw radiation calculation - - ! Local variables - integer :: nstep ! timestep counter - logical :: dosw ! true => do shosrtwave calc - integer :: offset ! offset for calendar day calculation - integer :: dTime ! integer timestep size - real(r8):: calday ! calendar day of - !----------------------------------------------------------------------- - - radiation_nextsw_cday = -1._r8 - dosw = .false. - nstep = get_nstep() - dtime = get_step_size() - offset = 0 - do while (.not. dosw) - nstep = nstep + 1 - offset = offset + dtime - if (radiation_do('sw', nstep)) then - radiation_nextsw_cday = get_curr_calday(offset=offset) - dosw = .true. - end if - end do - if(radiation_nextsw_cday == -1._r8) then - call endrun('error in radiation_nextsw_cday') - end if - - end function radiation_nextsw_cday - - !================================================================================================ - - subroutine radiation_init(pbuf2d) - - ! Initialize the radiation parameterization, add fields to the history buffer - - use physics_buffer, only: pbuf_get_index, pbuf_set_field - use phys_control, only: phys_getopts - use radsw, only: radsw_init - use radlw, only: radlw_init - use rad_solar_var, only: rad_solar_var_init - use radiation_data, only: rad_data_init - use cloud_rad_props, only: cloud_rad_props_init - use modal_aer_opt, only: modal_aer_opt_init - use rrtmg_state, only: rrtmg_state_init - use time_manager, only: is_first_step - - - ! arguments - type(physics_buffer_desc), pointer :: pbuf2d(:,:) - - ! local variables - integer :: icall, nmodes - logical :: active_calls(0:N_DIAG) - integer :: nstep ! current timestep number - logical :: history_amwg ! output the variables used by the AMWG diag package - logical :: history_vdiag ! output the variables used by the AMWG variability diag package - logical :: history_budget ! output tendencies and state variables for CAM4 - ! temperature, water vapor, cloud ice and cloud - ! liquid budgets. - integer :: history_budget_histfile_num ! output history file number for budget fields - integer :: err - - integer :: dtime - !----------------------------------------------------------------------- - - call rad_solar_var_init() - call rrtmg_state_init() - call rad_data_init(pbuf2d) ! initialize output fields for offline driver - call radsw_init() - call radlw_init() - call cloud_rad_props_init() - - cld_idx = pbuf_get_index('CLD') - cldfsnow_idx = pbuf_get_index('CLDFSNOW',errcode=err) - - if (is_first_step()) then - call pbuf_set_field(pbuf2d, qrl_idx, 0._r8) - end if - - - ! Set the radiation timestep for cosz calculations if requested using the adjusted iradsw value from radiation - if (use_rad_dt_cosz) then - dtime = get_step_size() - dt_avg = iradsw*dtime - end if - - call phys_getopts(history_amwg_out = history_amwg, & - history_vdiag_out = history_vdiag, & - history_budget_out = history_budget, & - history_budget_histfile_num_out = history_budget_histfile_num) - - ! Determine whether modal aerosols are affecting the climate, and if so - ! then initialize the modal aerosol optics module - call rad_cnst_get_info(0, nmodes=nmodes) - if (nmodes > 0) call modal_aer_opt_init() - - ! "irad_always" is number of time steps to execute radiation continuously from start of - ! initial OR restart run - nstep = get_nstep() - if (irad_always > 0) then - nstep = get_nstep() - irad_always = irad_always + nstep - end if - - if (docosp) call cospsimulator_intr_init - - allocate(cosp_cnt(begchunk:endchunk)) - if (is_first_restart_step()) then - cosp_cnt(begchunk:endchunk) = cosp_cnt_init - else - cosp_cnt(begchunk:endchunk) = 0 - end if - - call addfld('O3colAbove', horiz_only, 'A', 'DU', 'Column O3 above model top', sampling_seq='rad_lwsw') - - call addfld('TOT_CLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total gbx cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('TOT_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Total in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('LIQ_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Liquid in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - call addfld('ICE_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Ice in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - - if (cldfsnow_idx > 0) then - call addfld('SNOW_ICLD_VISTAU', (/ 'lev' /), 'A', '1', 'Snow in-cloud extinction visible sw optical depth', & - sampling_seq='rad_lwsw', flag_xyfill=.true.) - endif - - ! get list of active radiation calls - call rad_cnst_get_call_list(active_calls) - - ! Add shortwave radiation fields to history master field list. - - do icall = 0, N_DIAG - - if (active_calls(icall)) then - - call addfld('SOLIN'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar insolation', sampling_seq='rad_lwsw') - - call addfld('QRS'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Solar heating rate', sampling_seq='rad_lwsw') - call addfld('QRSC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky solar heating rate', & - sampling_seq='rad_lwsw') - call addfld('FSNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FSNTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNTOAC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('SWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Shortwave cloud forcing', & - sampling_seq='rad_lwsw') - call addfld('FSUTOA'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling solar flux at top of atmosphere', & - sampling_seq='rad_lwsw') - call addfld('FSNIRTOA'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAC'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Clearsky net near-infrared flux (Nimbus-7 WFOV) at top of atmosphere', sampling_seq='rad_lwsw') - call addfld('FSNRTOAS'//diag(icall), horiz_only, 'A', 'W/m2', & - 'Net near-infrared flux (>= 0.7 microns) at top of atmosphere', sampling_seq='rad_lwsw') - - call addfld('FSN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FSN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net shortwave flux at 200 mb', & - sampling_seq='rad_lwsw') - - call addfld('FSNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at tropopause', & - sampling_seq='rad_lwsw') - - call addfld('SOLL'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLS'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible direct to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLLD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward near infrared diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('SOLSD'//diag(icall), horiz_only, 'A', 'W/m2', 'Solar downward visible diffuse to surface', & - sampling_seq='rad_lwsw') - call addfld('FSNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FSDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FSDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky downwelling solar flux at surface', & - sampling_seq='rad_lwsw') - - call addfld('FUS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave upward flux') - call addfld('FDS'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave downward flux') - call addfld('FUSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky upward flux') - call addfld('FDSC'//diag(icall), (/ 'ilev' /), 'I', 'W/m2', 'Shortwave clear-sky downward flux') - - if (history_amwg) then - call add_default('SOLIN'//diag(icall), 1, ' ') - call add_default('QRS'//diag(icall), 1, ' ') - call add_default('FSNT'//diag(icall), 1, ' ') - call add_default('FSNTC'//diag(icall), 1, ' ') - call add_default('FSNTOA'//diag(icall), 1, ' ') - call add_default('FSNTOAC'//diag(icall), 1, ' ') - call add_default('SWCF'//diag(icall), 1, ' ') - call add_default('FSNS'//diag(icall), 1, ' ') - call add_default('FSNSC'//diag(icall), 1, ' ') - call add_default('FSUTOA'//diag(icall), 1, ' ') - call add_default('FSDSC'//diag(icall), 1, ' ') - call add_default('FSDS'//diag(icall), 1, ' ') - endif - - end if - end do - -#ifdef OSLO_AERO - call addfld('FDSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky downward flux') - call addfld('FUSCDRF', (/ 'ilev' /), 'A', 'W/m2', 'Shortwave clear-sky upward flux') -#endif - - if (scm_crm_mode) then - call add_default('FUS ', 1, ' ') - call add_default('FUSC ', 1, ' ') - call add_default('FDS ', 1, ' ') - call add_default('FDSC ', 1, ' ') - endif - - ! Add longwave radiation fields to history master field list. - - do icall = 0, N_DIAG - - if (active_calls(icall)) then - - call addfld('QRL'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Longwave heating rate', sampling_seq='rad_lwsw') - call addfld('QRLC'//diag(icall), (/ 'lev' /), 'A', 'K/s', 'Clearsky longwave heating rate', & - sampling_seq='rad_lwsw') - call addfld('FLNT'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLNTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLNTCLR'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky ONLY points net longwave flux at top of model',& - sampling_seq='rad_lwsw') - call addfld('FREQCLR'//diag(icall), horiz_only, 'A', 'Frac', 'Frequency of Occurrence of Clearsky', & - sampling_seq='rad_lwsw') - call addfld('FLUT'//diag(icall), horiz_only, 'A', 'W/m2', 'Upwelling longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('FLUTC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky upwelling longwave flux at top of model', & - sampling_seq='rad_lwsw') - call addfld('LWCF'//diag(icall), horiz_only, 'A', 'W/m2', 'Longwave cloud forcing', sampling_seq='rad_lwsw') - - call addfld('FLN200'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FLN200C'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at 200 mb', & - sampling_seq='rad_lwsw') - call addfld('FLNR'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at tropopause', & - sampling_seq='rad_lwsw') - - call addfld('FLNS'//diag(icall), horiz_only, 'A', 'W/m2', 'Net longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLNSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky net longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLDS'//diag(icall), horiz_only, 'A', 'W/m2', 'Downwelling longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FLDSC'//diag(icall), horiz_only, 'A', 'W/m2', 'Clearsky Downwelling longwave flux at surface', & - sampling_seq='rad_lwsw') - call addfld('FUL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave upward flux') - call addfld('FDL'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave downward flux') - call addfld('FULC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky upward flux') - call addfld('FDLC'//diag(icall), (/ 'ilev' /),'I', 'W/m2', 'Longwave clear-sky downward flux') - - if (history_amwg) then - call add_default('QRL'//diag(icall), 1, ' ') - call add_default('FLNT'//diag(icall), 1, ' ') - call add_default('FLNTC'//diag(icall), 1, ' ') - call add_default('FLNTCLR'//diag(icall), 1, ' ') - call add_default('FREQCLR'//diag(icall), 1, ' ') - call add_default('FLUT'//diag(icall), 1, ' ') - call add_default('FLUTC'//diag(icall), 1, ' ') - call add_default('LWCF'//diag(icall), 1, ' ') - call add_default('FLNS'//diag(icall), 1, ' ') - call add_default('FLNSC'//diag(icall), 1, ' ') - call add_default('FLDS'//diag(icall), 1, ' ') - endif - - end if - end do - - call addfld('EMIS', (/ 'lev' /), 'A', '1', 'Cloud longwave emissivity') - - if (scm_crm_mode) then - call add_default ('FUL ', 1, ' ') - call add_default ('FULC ', 1, ' ') - call add_default ('FDL ', 1, ' ') - call add_default ('FDLC ', 1, ' ') - endif - - ! Heating rate needed for d(theta)/dt computation - call addfld ('HR',(/ 'lev' /), 'A','K/s','Heating rate needed for d(theta)/dt computation') - - if ( history_budget .and. history_budget_histfile_num > 1 ) then - call add_default ('QRL ', history_budget_histfile_num, ' ') - call add_default ('QRS ', history_budget_histfile_num, ' ') - end if - - if (history_vdiag) then - call add_default('FLUT', 2, ' ') - call add_default('FLUT', 3, ' ') - end if - - end subroutine radiation_init - - !=============================================================================== - - subroutine radiation_define_restart(file) - - ! define variables to be written to restart file - - ! arguments - type(file_desc_t), intent(inout) :: file - - ! local variables - integer :: ierr - !---------------------------------------------------------------------------- - - call pio_seterrorhandling(File, PIO_BCAST_ERROR) - - if (docosp) then - ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) - end if - - end subroutine radiation_define_restart - - !=============================================================================== - - subroutine radiation_write_restart(file) - - ! write variables to restart file - - ! arguments - type(file_desc_t), intent(inout) :: file - - ! local variables - integer :: ierr - !---------------------------------------------------------------------------- + call pio_seterrorhandling(File, PIO_BCAST_ERROR) - if (docosp) then - ierr = pio_put_var(File, cospcnt_desc, (/cosp_cnt(begchunk)/)) - end if + if (docosp) then + ierr = pio_def_var(File, 'cosp_cnt_init', pio_int, cospcnt_desc) + end if - end subroutine radiation_write_restart - - !=============================================================================== - - subroutine radiation_read_restart(file) +end subroutine radiation_define_restart + +!=============================================================================== + +subroutine radiation_write_restart(file) - ! read variables from restart file + ! write variables to restart file - ! arguments - type(file_desc_t), intent(inout) :: file + ! arguments + type(file_desc_t), intent(inout) :: file - ! local variables + ! local variables + integer :: ierr + !---------------------------------------------------------------------------- - integer :: err_handling - integer :: ierr + if (docosp) then + ierr = pio_put_var(File, cospcnt_desc, (/cosp_cnt(begchunk)/)) + end if + +end subroutine radiation_write_restart + +!=============================================================================== - type(var_desc_t) :: vardesc - !---------------------------------------------------------------------------- +subroutine radiation_read_restart(file) - if (docosp) then - call pio_seterrorhandling(File, PIO_BCAST_ERROR, err_handling) - ierr = pio_inq_varid(File, 'cosp_cnt_init', vardesc) - call pio_seterrorhandling(File, err_handling) - if (ierr /= PIO_NOERR) then - cosp_cnt_init = 0 - else - ierr = pio_get_var(File, vardesc, cosp_cnt_init) - end if - end if + ! read variables from restart file - end subroutine radiation_read_restart + ! arguments + type(file_desc_t), intent(inout) :: file - !=============================================================================== + ! local variables - subroutine radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) + integer :: err_handling + integer :: ierr - !----------------------------------------------------------------------- - ! - ! Driver for radiation computation. - ! - ! Revision history: - ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. - ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. - ! - ! 2019-05-06 A. KirkevÃ¥g: Changes for testing the - ! "simple plumes" aerosols, based on NorESM1 code P. Räisänen. - !----------------------------------------------------------------------- + type(var_desc_t) :: vardesc + !---------------------------------------------------------------------------- - use phys_grid, only: get_rlat_all_p, get_rlon_all_p - use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr - use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz + if (docosp) then + call pio_seterrorhandling(File, PIO_BCAST_ERROR, err_handling) + ierr = pio_inq_varid(File, 'cosp_cnt_init', vardesc) + call pio_seterrorhandling(File, err_handling) + if (ierr /= PIO_NOERR) then + cosp_cnt_init = 0 + else + ierr = pio_get_var(File, vardesc, cosp_cnt_init) + end if + end if - use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw +end subroutine radiation_read_restart + +!=============================================================================== - use cloud_rad_props, only: get_ice_optics_sw, get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & - ice_cloud_get_rad_props_lw, cloud_rad_props_get_lw, & - snow_cloud_get_rad_props_lw, get_snow_optics_sw - use slingo, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw - use ebert_curry, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw +subroutine radiation_tend( & + state, ptend, pbuf, cam_out, cam_in, net_flx, rd_out) + + !----------------------------------------------------------------------- + ! + ! Driver for radiation computation. + ! + ! Revision history: + ! 2007-11-05 M. Iacono Install rrtmg_lw and sw as radiation model. + ! 2007-12-27 M. Iacono Modify to use CAM cloud optical properties with rrtmg. + !----------------------------------------------------------------------- + + use phys_grid, only: get_rlat_all_p, get_rlon_all_p + use cam_control_mod, only: eccen, mvelpp, lambm0, obliqr + use shr_orb_mod, only: shr_orb_decl, shr_orb_cosz + + use aer_rad_props, only: aer_rad_props_sw, aer_rad_props_lw + + use cloud_rad_props, only: get_ice_optics_sw, get_liquid_optics_sw, liquid_cloud_get_rad_props_lw, & + ice_cloud_get_rad_props_lw, cloud_rad_props_get_lw, & + snow_cloud_get_rad_props_lw, get_snow_optics_sw + use slingo, only: slingo_liq_get_rad_props_lw, slingo_liq_optics_sw + use ebert_curry, only: ec_ice_optics_sw, ec_ice_get_rad_props_lw + + use rad_solar_var, only: get_variability + use radsw, only: rad_rrtmg_sw + use radlw, only: rad_rrtmg_lw + use radheat, only: radheat_tend + + use radiation_data, only: rad_data_write + use rrtmg_state, only: rrtmg_state_create, rrtmg_state_update, rrtmg_state_destroy, rrtmg_state_t, & + num_rrtmg_levs + + use interpolate_data, only: vertinterp + use tropopause, only: tropopause_find, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE + + use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps + + ! Arguments + type(physics_state), intent(in), target :: state + type(physics_ptend), intent(out) :: ptend + + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(inout) :: cam_out + type(cam_in_t), intent(in) :: cam_in + real(r8), intent(out) :: net_flx(pcols) + + type(rad_out_t), target, optional, intent(out) :: rd_out + + + ! Local variables + type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object + ! if the argument is not present + logical :: write_output + + integer :: i, k + integer :: lchnk, ncol + logical :: dosw, dolw + + real(r8) :: calday ! current calendar day + real(r8) :: delta ! Solar declination angle in radians + real(r8) :: eccf ! Earth orbit eccentricity factor + real(r8) :: clat(pcols) ! current latitudes(radians) + real(r8) :: clon(pcols) ! current longitudes(radians) + real(r8) :: coszrs(pcols) ! Cosine solar zenith angle + + ! Gathered indices of day and night columns + ! chunk_column_index = IdxDay(daylight_column_index) + integer :: Nday ! Number of daylight columns + integer :: Nnite ! Number of night columns + integer :: IdxDay(pcols) ! Indices of daylight columns + integer :: IdxNite(pcols) ! Indices of night columns + + integer :: itim_old + + real(r8), pointer :: cld(:,:) ! cloud fraction + real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" + real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate + real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate + real(r8), pointer :: fsds(:) ! Surface solar down flux + real(r8), pointer :: fsns(:) ! Surface solar absorbed flux + real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top + real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux + real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top + + real(r8), pointer, dimension(:,:,:) :: su => NULL() ! shortwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: sd => NULL() ! shortwave spectral flux down + real(r8), pointer, dimension(:,:,:) :: lu => NULL() ! longwave spectral flux up + real(r8), pointer, dimension(:,:,:) :: ld => NULL() ! longwave spectral flux down + + ! tropopause diagnostic + integer :: troplev(pcols) + real(r8) :: p_trop(pcols) + + type(rrtmg_state_t), pointer :: r_state ! contains the atm concentrations in layers needed for RRTMG + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: ice_tau (nswbands,pcols,pver) ! ice extinction optical depth + real(r8) :: ice_tau_w (nswbands,pcols,pver) ! ice single scattering albedo * tau + real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice assymetry parameter * tau * w + real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! ice forward scattered fraction * tau * w + real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth + real(r8) :: liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau + real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w + real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w + real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: cld_tau (nswbands,pcols,pver) ! cloud extinction optical depth + real(r8) :: cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau + real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau + real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau + real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) + + ! cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth + real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau + real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow assymetry parameter * tau * w + real(r8) :: snow_tau_w_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w + real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) + + ! combined cloud radiative parameters are "in cloud" not "in cell" + real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) + real(r8) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth + real(r8) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau + real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau + real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau + real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) + + real(r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band + + integer :: icall ! index through climate/diagnostic radiation calls + logical :: active_calls(0:N_DIAG) + + ! Aerosol radiative properties + real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth + real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau + real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau + real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau + real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) + + real(r8) :: fns(pcols,pverp) ! net shortwave flux + real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux + real(r8) :: fnl(pcols,pverp) ! net longwave flux + real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux + + ! for COSP + real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity + real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau + real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth + + real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables + + real(r8) :: freqclr(pcols) ! Frequency of occurrence of clear sky columns + real(r8) :: flntclr(pcols) ! Clearsky only columns (zero if cloudy) + + character(*), parameter :: name = 'radiation_tend' + + logical, parameter :: cosz_rad_call=.true. !+tht + !-------------------------------------------------------------------------------------- + + lchnk = state%lchnk + ncol = state%ncol + + if (present(rd_out)) then + rd => rd_out + write_output = .false. + else + allocate(rd) + write_output=.true. + end if + + dosw = radiation_do('sw') ! do shortwave heating calc this timestep? + dolw = radiation_do('lw') ! do longwave heating calc this timestep? + + ! Cosine solar zenith angle for current time step + calday = get_curr_calday() + call get_rlat_all_p(lchnk, ncol, clat) + call get_rlon_all_p(lchnk, ncol, clon) + + call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & + delta, eccf) + do i = 1, ncol + coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, cosz_rad_call) !+tht + end do + + ! Gather night/day column indices. + Nday = 0 + Nnite = 0 + do i = 1, ncol + if ( coszrs(i) > 0.0_r8 ) then + Nday = Nday + 1 + IdxDay(Nday) = i + else + Nnite = Nnite + 1 + IdxNite(Nnite) = i + end if + end do + + ! Associate pointers to physics buffer fields + itim_old = pbuf_old_tim_idx() + if (cldfsnow_idx > 0) then + call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + endif + call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) + + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, qrl_idx, qrl) + + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsds_idx, fsds) + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, flns_idx, flns) + call pbuf_get_field(pbuf, flnt_idx, flnt) + + if (spectralflux) then + call pbuf_get_field(pbuf, su_idx, su) + call pbuf_get_field(pbuf, sd_idx, sd) + call pbuf_get_field(pbuf, lu_idx, lu) + call pbuf_get_field(pbuf, ld_idx, ld) + end if + + ! For CRM, make cloud equal to input observations: + if (scm_crm_mode .and. have_cld) then + do k = 1, pver + cld(:ncol,k)= cldobs(k) + end do + end if + + ! Find tropopause height if needed for diagnostic output + if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then + call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) + endif + + if (dosw .or. dolw) then + + ! construct an RRTMG state object + r_state => rrtmg_state_create( state, cam_in ) + + call t_startf('cldoptics') + + if (cldfsnow_idx > 0) then + do k = 1, pver + do i = 1, ncol + cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) + end do + end do + else + cldfprime(:ncol,:) = cld(:ncol,:) + end if + + + if (dosw) then + + if (oldcldoptics) then + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) + case ('mitchell') + call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) + case default + call endrun('iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) + case ('gammadist') + call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) + case default + call endrun('liqcldoptics must be either slingo or gammadist') + end select + end if + + cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) + cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) + cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) + cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) + + if (cldfsnow_idx > 0) then + ! add in snow + call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) + do i = 1, ncol + do k = 1, pver + + if (cldfprime(i,k) > 0._r8) then + + c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & + + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & + + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & + + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) + + c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & + + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) + else + c_cld_tau(:,i,k) = 0._r8 + c_cld_tau_w(:,i,k) = 0._r8 + c_cld_tau_w_g(:,i,k) = 0._r8 + c_cld_tau_w_f(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) + c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) + c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) + c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) + end if + + ! Output cloud optical depth fields for the visible band + rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) + rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) + rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) + + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) + endif + + ! multiply by total cloud fraction to get gridbox value + rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) + + ! add fillvalue for night columns + do i = 1, Nnite + rd%tot_cld_vistau(IdxNite(i),:) = fillvalue + rd%tot_icld_vistau(IdxNite(i),:) = fillvalue + rd%liq_icld_vistau(IdxNite(i),:) = fillvalue + rd%ice_icld_vistau(IdxNite(i),:) = fillvalue + if (cldfsnow_idx > 0) then + rd%snow_icld_vistau(IdxNite(i),:) = fillvalue + end if + end do + + if (write_output) call radiation_output_cld(lchnk, ncol, rd) + + end if ! if (dosw) + + if (dolw) then + + if (oldcldoptics) then + call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) + else + select case (icecldoptics) + case ('ebertcurry') + call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) + case ('mitchell') + call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) + case default + call endrun('iccldoptics must be one either ebertcurry or mitchell') + end select + + select case (liqcldoptics) + case ('slingo') + call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) + case ('gammadist') + call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) + case default + call endrun('liqcldoptics must be either slingo or gammadist') + end select + + cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) + + end if + + if (cldfsnow_idx > 0) then + + ! add in snow + call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) + + do i = 1, ncol + do k = 1, pver + if (cldfprime(i,k) > 0._r8) then + c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & + + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) + else + c_cld_lw_abs(:,i,k) = 0._r8 + end if + end do + end do + else + c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) + end if + + end if ! if (dolw) + + call t_stopf('cldoptics') + + ! Solar radiation computation + + if (dosw) then + + call get_variability(sfac) + + ! Get the active climate/diagnostic shortwave calculations + call rad_cnst_get_call_list(active_calls) + + ! The climate (icall==0) calculation must occur last. + do icall = N_DIAG, 0, -1 + + if (active_calls(icall)) then + + ! update the concentrations in the RRTMG state object + call rrtmg_state_update(state, pbuf, icall, r_state) - use rad_solar_var, only: get_variability - use radsw, only: rad_rrtmg_sw - use radlw, only: rad_rrtmg_lw - use radheat, only: radheat_tend - - use radiation_data, only: rad_data_write - use rrtmg_state, only: rrtmg_state_create, rrtmg_state_update, rrtmg_state_destroy, rrtmg_state_t, & - num_rrtmg_levs - - use interpolate_data, only: vertinterp - use tropopause, only: tropopause_find, TROP_ALG_HYBSTOB, TROP_ALG_CLIMATE - - use cospsimulator_intr, only: docosp, cospsimulator_intr_run, cosp_nradsteps - - use constituents, only: pcnst -#ifdef OSLO_AERO - use physics_buffer, only: pbuf_get_index - use oslo_aero_control, only: oslo_aero_getopts - use oslo_aero_params - use oslo_aero_share -#endif - - ! Arguments - type(physics_state), intent(in), target :: state - type(physics_ptend), intent(out) :: ptend - - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(inout) :: cam_out - type(cam_in_t), intent(in) :: cam_in - real(r8), intent(out) :: net_flx(pcols) - - type(rad_out_t), target, optional, intent(out) :: rd_out - - - ! Local variables -#ifdef OSLO_AERO - real(r8) :: volc_fraction_coarse ! Fraction of volcanic aerosols going to coarse mode - integer :: band - character(len=3) :: c3 - logical :: idrf -#endif - type(rad_out_t), pointer :: rd ! allow rd_out to be optional by allocating a local object - ! if the argument is not present - logical :: write_output - - integer :: i, k - integer :: lchnk, ncol - logical :: dosw, dolw - -#ifdef OSLO_AERO - real(r8), pointer, dimension(:,:) :: rvolcmmr ! Read in stratospheric volcanoes aerosol mmr - real(r8), pointer, dimension(:,:) :: volcopt ! Read in stratospheric volcano SW optical parameter (CMIP6) -#endif - real(r8) :: calday ! current calendar day - real(r8) :: delta ! Solar declination angle in radians - real(r8) :: eccf ! Earth orbit eccentricity factor - real(r8) :: clat(pcols) ! current latitudes(radians) - real(r8) :: clon(pcols) ! current longitudes(radians) - real(r8) :: coszrs(pcols) ! Cosine solar zenith angle - - ! Gathered indices of day and night columns - ! chunk_column_index = IdxDay(daylight_column_index) - integer :: Nday ! Number of daylight columns - integer :: Nnite ! Number of night columns - integer :: IdxDay(pcols) ! Indices of daylight columns - integer :: IdxNite(pcols) ! Indices of night columns - - integer :: itim_old - - real(r8), pointer :: cld(:,:) ! cloud fraction - real(r8), pointer :: cldfsnow(:,:) ! cloud fraction of just "snow clouds- whatever they are" - real(r8), pointer :: qrs(:,:) ! shortwave radiative heating rate - real(r8), pointer :: qrl(:,:) ! longwave radiative heating rate - real(r8), pointer :: fsds(:) ! Surface solar down flux - real(r8), pointer :: fsns(:) ! Surface solar absorbed flux - real(r8), pointer :: fsnt(:) ! Net column abs solar flux at model top - real(r8), pointer :: flns(:) ! Srf longwave cooling (up-down) flux - real(r8), pointer :: flnt(:) ! Net outgoing lw flux at model top - - real(r8), pointer, dimension(:,:,:) :: su => NULL() ! shortwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: sd => NULL() ! shortwave spectral flux down - real(r8), pointer, dimension(:,:,:) :: lu => NULL() ! longwave spectral flux up - real(r8), pointer, dimension(:,:,:) :: ld => NULL() ! longwave spectral flux down - - ! tropopause diagnostic - integer :: troplev(pcols) - real(r8) :: p_trop(pcols) - - type(rrtmg_state_t), pointer :: r_state ! contains the atm concentrations in layers needed for RRTMG - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: ice_tau (nswbands,pcols,pver) ! ice extinction optical depth - real(r8) :: ice_tau_w (nswbands,pcols,pver) ! ice single scattering albedo * tau - real(r8) :: ice_tau_w_g(nswbands,pcols,pver) ! ice assymetry parameter * tau * w - real(r8) :: ice_tau_w_f(nswbands,pcols,pver) ! ice forward scattered fraction * tau * w - real(r8) :: ice_lw_abs (nlwbands,pcols,pver) ! ice absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: liq_tau (nswbands,pcols,pver) ! liquid extinction optical depth - real(r8) :: liq_tau_w (nswbands,pcols,pver) ! liquid single scattering albedo * tau - real(r8) :: liq_tau_w_g(nswbands,pcols,pver) ! liquid assymetry parameter * tau * w - real(r8) :: liq_tau_w_f(nswbands,pcols,pver) ! liquid forward scattered fraction * tau * w - real(r8) :: liq_lw_abs (nlwbands,pcols,pver) ! liquid absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: cld_tau (nswbands,pcols,pver) ! cloud extinction optical depth - real(r8) :: cld_tau_w (nswbands,pcols,pver) ! cloud single scattering albedo * tau - real(r8) :: cld_tau_w_g(nswbands,pcols,pver) ! cloud assymetry parameter * w * tau - real(r8) :: cld_tau_w_f(nswbands,pcols,pver) ! cloud forward scattered fraction * w * tau - real(r8) :: cld_lw_abs (nlwbands,pcols,pver) ! cloud absorption optics depth (LW) - - ! cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: snow_tau (nswbands,pcols,pver) ! snow extinction optical depth - real(r8) :: snow_tau_w (nswbands,pcols,pver) ! snow single scattering albedo * tau - real(r8) :: snow_tau_w_g(nswbands,pcols,pver) ! snow assymetry parameter * tau * w - real(r8) :: snow_tau_w_f(nswbands,pcols,pver) ! snow forward scattered fraction * tau * w - real(r8) :: snow_lw_abs (nlwbands,pcols,pver)! snow absorption optics depth (LW) - - ! combined cloud radiative parameters are "in cloud" not "in cell" - real(r8) :: cldfprime(pcols,pver) ! combined cloud fraction (snow plus regular) - real(r8) :: c_cld_tau (nswbands,pcols,pver) ! combined cloud extinction optical depth - real(r8) :: c_cld_tau_w (nswbands,pcols,pver) ! combined cloud single scattering albedo * tau - real(r8) :: c_cld_tau_w_g(nswbands,pcols,pver) ! combined cloud assymetry parameter * w * tau - real(r8) :: c_cld_tau_w_f(nswbands,pcols,pver) ! combined cloud forward scattered fraction * w * tau - real(r8) :: c_cld_lw_abs (nlwbands,pcols,pver) ! combined cloud absorption optics depth (LW) - - real(r8) :: sfac(1:nswbands) ! time varying scaling factors due to Solar Spectral Irrad at 1 A.U. per band - - integer :: icall ! index through climate/diagnostic radiation calls - logical :: active_calls(0:N_DIAG) - - ! Aerosol radiative properties - real(r8) :: aer_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth - real(r8) :: aer_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8) :: aer_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau - real(r8) :: aer_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau - real(r8) :: aer_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) - -#ifdef OSLO_AERO - ! Local variables used for calculating aerosol optics and direct and indirect forcings. - ! aodvis and absvis are AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) - ! Note that aodvis and absvis output should be devided by dayfoc to give physical (A)AOD values - real(r8) :: qdirind(pcols,pver,pcnst) ! Common tracers for indirect and direct calculations - real(r8) :: aodvis(pcols) ! AOD vis - real(r8) :: absvis(pcols) ! absorptive AOD vis - real(r8) :: clearodvis(pcols), clearabsvis(pcols), cloudfree(pcols), cloudfreemax(pcols) -#ifdef AEROCOM - real(r8) :: dod440(pcols),dod550(pcols),dod870(pcols),abs550(pcols),abs550alt(pcols) - real(r8) :: clearod440(pcols),clearod550(pcols),clearod870(pcols),clearabs550(pcols),clearabs550alt(pcols) -#endif - real(r8) :: ftem_1d(pcols) ! work-array to avoid NAN and pcols/ncol confusion - real(r8) :: Nnatk(pcols,pver,0:nmodes) ! Modal aerosol number concentration - real(r8) :: batotlw(pcols,pver,nlwbands) ! spectral aerosol absportion extinction in LW - real(r8) :: rhoda(pcols,pver) ! air mass density, unit kg/m^3 - real(r8) :: pmxrgnrf(pcols,pverp) ! temporary copy of pmxrgn - integer :: nmxrgnrf(pcols) ! temporary copy of nmxrgn - real(r8) :: rhtrunc(pcols,pver) ! relative humidity (as fraction) - real(r8) :: per_tau (pcols,0:pver,nswbands) ! aerosol extinction optical depth - real(r8) :: per_tau_w (pcols,0:pver,nswbands) ! aerosol single scattering albedo * tau - real(r8) :: per_tau_w_g(pcols,0:pver,nswbands) ! aerosol assymetry parameter * w * tau - real(r8) :: per_tau_w_f(pcols,0:pver,nswbands) ! aerosol forward scattered fraction * w * tau - real(r8) :: per_lw_abs (pcols,pver,nlwbands) ! aerosol absorption optics depth (LW) - integer :: ns ! spectral loop index - real(r8) :: volc_ext_sun(pcols,pver,nswbands) ! volcanic aerosol extinction for solar bands, CMIP6 - real(r8) :: volc_omega_sun(pcols,pver,nswbands) ! volcanic aerosol SSA for solar bands, CMIP6 - real(r8) :: volc_g_sun(pcols,pver,nswbands) ! volcanic aerosol g for solar bands, CMIP6 - real(r8) :: volc_ext_earth(pcols,pver,nlwbands) ! volcanic aerosol extinction for terrestrial bands, CMIP6 - real(r8) :: volc_omega_earth(pcols,pver,nlwbands) ! volcanic aerosol SSA for terrestrial bands, CMIP6 -#endif - - real(r8) :: fns(pcols,pverp) ! net shortwave flux - real(r8) :: fcns(pcols,pverp) ! net clear-sky shortwave flux - real(r8) :: fnl(pcols,pverp) ! net longwave flux - real(r8) :: fcnl(pcols,pverp) ! net clear-sky longwave flux - - ! for COSP - real(r8) :: emis(pcols,pver) ! Cloud longwave emissivity - real(r8) :: gb_snow_tau(pcols,pver) ! grid-box mean snow_tau - real(r8) :: gb_snow_lw(pcols,pver) ! grid-box mean LW snow optical depth - - real(r8) :: ftem(pcols,pver) ! Temporary workspace for outfld variables - - real(r8) :: freqclr(pcols) ! Frequency of occurrence of clear sky columns - real(r8) :: flntclr(pcols) ! Clearsky only columns (zero if cloudy) - - character(*), parameter :: name = 'radiation_tend' - - logical, parameter :: cosz_rad_call=.true. !+tht - !-------------------------------------------------------------------------------------- - - lchnk = state%lchnk - ncol = state%ncol - -#ifdef OSLO_AERO - per_lw_abs(:,:,:)=0._r8 - per_tau(:,:,:)=0._r8 - per_tau_w(:,:,:)=0._r8 - per_tau_w_g(:,:,:)=0._r8 - per_tau_w_f(:,:,:)=0._r8 -#endif - - if (present(rd_out)) then - rd => rd_out - write_output = .false. - else - allocate(rd) - write_output=.true. - end if - - dosw = radiation_do('sw') ! do shortwave heating calc this timestep? - dolw = radiation_do('lw') ! do longwave heating calc this timestep? - - ! Cosine solar zenith angle for current time step - calday = get_curr_calday() - call get_rlat_all_p(lchnk, ncol, clat) - call get_rlon_all_p(lchnk, ncol, clon) - - call shr_orb_decl(calday, eccen, mvelpp, lambm0, obliqr, & - delta, eccf) - do i = 1, ncol - coszrs(i) = shr_orb_cosz(calday, clat(i), clon(i), delta, dt_avg, cosz_rad_call) !+tht - end do - - ! Gather night/day column indices. - Nday = 0 - Nnite = 0 - do i = 1, ncol - if ( coszrs(i) > 0.0_r8 ) then - Nday = Nday + 1 - IdxDay(Nday) = i - else - Nnite = Nnite + 1 - IdxNite(Nnite) = i - end if - end do - - ! Associate pointers to physics buffer fields - itim_old = pbuf_old_tim_idx() - if (cldfsnow_idx > 0) then - call pbuf_get_field(pbuf, cldfsnow_idx, cldfsnow, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - endif - call pbuf_get_field(pbuf, cld_idx, cld, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, qrl_idx, qrl) - - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, fsds_idx, fsds) - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, flns_idx, flns) - call pbuf_get_field(pbuf, flnt_idx, flnt) - - if (spectralflux) then - call pbuf_get_field(pbuf, su_idx, su) - call pbuf_get_field(pbuf, sd_idx, sd) - call pbuf_get_field(pbuf, lu_idx, lu) - call pbuf_get_field(pbuf, ld_idx, ld) - end if - - ! For CRM, make cloud equal to input observations: - if (scm_crm_mode .and. have_cld) then - do k = 1, pver - cld(:ncol,k)= cldobs(k) - end do - end if - -#ifdef OSLO_AERO - qdirind(:ncol,:,:) = state%q(:ncol,:,:) - if (has_prescribed_volcaero) then - call oslo_aero_getopts(volc_fraction_coarse_out = volc_fraction_coarse) - call pbuf_get_field(pbuf, volc_idx, rvolcmmr, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - qdirind(:ncol,:,l_so4_pr) = qdirind(:ncol,:,l_so4_pr) + (1.0_r8 - volc_fraction_coarse)*rvolcmmr(:ncol,:) - qdirind(:ncol,:,l_ss_a3) = qdirind(:ncol,:,l_ss_a3) + volc_fraction_coarse*rvolcmmr(:ncol,:) - end if -#endif - - ! Find tropopause height if needed for diagnostic output - if (hist_fld_active('FSNR') .or. hist_fld_active('FLNR')) then - call tropopause_find(state, troplev, tropP=p_trop, primary=TROP_ALG_HYBSTOB, backup=TROP_ALG_CLIMATE) - endif - - if (dosw .or. dolw) then - - ! construct an RRTMG state object - r_state => rrtmg_state_create( state, cam_in ) - - call t_startf('cldoptics') - - if (cldfsnow_idx > 0) then - do k = 1, pver - do i = 1, ncol - cldfprime(i,k) = max(cld(i,k), cldfsnow(i,k)) - end do - end do - else - cldfprime(:ncol,:) = cld(:ncol,:) - end if - - - if (dosw) then - - - if (oldcldoptics) then - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.false.) - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.false.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f, oldicewp=.true.) - case ('mitchell') - call get_ice_optics_sw(state, pbuf, ice_tau, ice_tau_w, ice_tau_w_g, ice_tau_w_f) - case default - call endrun('iccldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f, oldliqwp=.true.) - case ('gammadist') - - call get_liquid_optics_sw(state, pbuf, liq_tau, liq_tau_w, liq_tau_w_g, liq_tau_w_f) - - case default - call endrun('liqcldoptics must be either slingo or gammadist') - end select - end if - - cld_tau(:,:ncol,:) = liq_tau(:,:ncol,:) + ice_tau(:,:ncol,:) - cld_tau_w(:,:ncol,:) = liq_tau_w(:,:ncol,:) + ice_tau_w(:,:ncol,:) - cld_tau_w_g(:,:ncol,:) = liq_tau_w_g(:,:ncol,:) + ice_tau_w_g(:,:ncol,:) - cld_tau_w_f(:,:ncol,:) = liq_tau_w_f(:,:ncol,:) + ice_tau_w_f(:,:ncol,:) - - if (cldfsnow_idx > 0) then - ! add in snow - call get_snow_optics_sw(state, pbuf, snow_tau, snow_tau_w, snow_tau_w_g, snow_tau_w_f) - do i = 1, ncol - do k = 1, pver - - if (cldfprime(i,k) > 0._r8) then - - c_cld_tau(:,i,k) = ( cldfsnow(i,k)*snow_tau(:,i,k) & - + cld(i,k)*cld_tau(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w(:,i,k) = ( cldfsnow(i,k)*snow_tau_w(:,i,k) & - + cld(i,k)*cld_tau_w(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_g(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_g(:,i,k) & - + cld(i,k)*cld_tau_w_g(:,i,k) )/cldfprime(i,k) - - c_cld_tau_w_f(:,i,k) = ( cldfsnow(i,k)*snow_tau_w_f(:,i,k) & - + cld(i,k)*cld_tau_w_f(:,i,k) )/cldfprime(i,k) - else - c_cld_tau(:,i,k) = 0._r8 - c_cld_tau_w(:,i,k) = 0._r8 - c_cld_tau_w_g(:,i,k) = 0._r8 - c_cld_tau_w_f(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_tau(:,:ncol,:) = cld_tau(:,:ncol,:) - c_cld_tau_w(:,:ncol,:) = cld_tau_w(:,:ncol,:) - c_cld_tau_w_g(:,:ncol,:) = cld_tau_w_g(:,:ncol,:) - c_cld_tau_w_f(:,:ncol,:) = cld_tau_w_f(:,:ncol,:) - end if - - ! Output cloud optical depth fields for the visible band - rd%tot_icld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:) - rd%liq_icld_vistau(:ncol,:) = liq_tau(idx_sw_diag,:ncol,:) - rd%ice_icld_vistau(:ncol,:) = ice_tau(idx_sw_diag,:ncol,:) - - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(:ncol,:) = snow_tau(idx_sw_diag,:ncol,:) - endif - - ! multiply by total cloud fraction to get gridbox value - rd%tot_cld_vistau(:ncol,:) = c_cld_tau(idx_sw_diag,:ncol,:)*cldfprime(:ncol,:) - - ! add fillvalue for night columns - do i = 1, Nnite - rd%tot_cld_vistau(IdxNite(i),:) = fillvalue - rd%tot_icld_vistau(IdxNite(i),:) = fillvalue - rd%liq_icld_vistau(IdxNite(i),:) = fillvalue - rd%ice_icld_vistau(IdxNite(i),:) = fillvalue - if (cldfsnow_idx > 0) then - rd%snow_icld_vistau(IdxNite(i),:) = fillvalue - end if - end do - - if (write_output) call radiation_output_cld(lchnk, ncol, rd) - - end if ! if (dosw) - - if (dolw) then - - if (oldcldoptics) then - call cloud_rad_props_get_lw(state, pbuf, cld_lw_abs, oldcloud=.true.) - else - select case (icecldoptics) - case ('ebertcurry') - call ec_ice_get_rad_props_lw(state, pbuf, ice_lw_abs, oldicewp=.true.) - case ('mitchell') - call ice_cloud_get_rad_props_lw(state, pbuf, ice_lw_abs) - case default - call endrun('iccldoptics must be one either ebertcurry or mitchell') - end select - - select case (liqcldoptics) - case ('slingo') - call slingo_liq_get_rad_props_lw(state, pbuf, liq_lw_abs, oldliqwp=.true.) - case ('gammadist') - call liquid_cloud_get_rad_props_lw(state, pbuf, liq_lw_abs) - case default - call endrun('liqcldoptics must be either slingo or gammadist') - end select - - cld_lw_abs(:,:ncol,:) = liq_lw_abs(:,:ncol,:) + ice_lw_abs(:,:ncol,:) - - end if - - if (cldfsnow_idx > 0) then - - ! add in snow - call snow_cloud_get_rad_props_lw(state, pbuf, snow_lw_abs) - - do i = 1, ncol - do k = 1, pver - if (cldfprime(i,k) > 0._r8) then - c_cld_lw_abs(:,i,k) = ( cldfsnow(i,k)*snow_lw_abs(:,i,k) & - + cld(i,k)*cld_lw_abs(:,i,k) )/cldfprime(i,k) - else - c_cld_lw_abs(:,i,k) = 0._r8 - end if - end do - end do - else - c_cld_lw_abs(:,:ncol,:) = cld_lw_abs(:,:ncol,:) - end if - - end if ! if (dolw) - - call t_stopf('cldoptics') - - ! Solar radiation computation - - if (dosw) then - -#ifdef OSLO_AERO - ! Volcanic optics for solar (SW) bands - do band=1, solar_bands - volc_ext_sun(1:ncol,1:pver,band)=0.0_r8 - volc_omega_sun(1:ncol,1:pver,band)=0.999_r8 - volc_g_sun(1:ncol,1:pver,band)=0.5_r8 - enddo - if (has_prescribed_volcaero_cmip6) then - do band=1, solar_bands - write(c3,'(i3)') band - volc_idx = pbuf_get_index('ext_sun'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_ext_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - volc_idx = pbuf_get_index('omega_sun'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_omega_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - volc_idx = pbuf_get_index('g_sun'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_g_sun(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - enddo - endif - ! Volcanic optics for terrestrial (LW) bands (g is not used here) - do band=1, terrestrial_bands - volc_ext_earth(1:ncol,1:pver,band)=0.0_r8 - volc_omega_earth(1:ncol,1:pver,band)=0.999_r8 - enddo - if (has_prescribed_volcaero_cmip6) then - do band=1, terrestrial_bands - write(c3,'(i3)') band - volc_idx = pbuf_get_index('ext_earth'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_ext_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - - volc_idx = pbuf_get_index('omega_earth'//trim(adjustl(c3))) - call pbuf_get_field(pbuf, volc_idx, volcopt, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) - volc_omega_earth(1:ncol,1:pver,band)=volcopt(1:ncol,1:pver) - enddo - endif - - ! No aerocom variables passed for now - ! dod440, dod550, dod870, abs550, abs550alt - call oslo_aero_optical_params_calc(lchnk, ncol, 10.0_r8*state%pint, state%pmid, & - coszrs, state, state%t, cld, qdirind, Nnatk, & - per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, per_lw_abs, & - volc_ext_sun, volc_omega_sun, volc_g_sun, volc_ext_earth, volc_omega_earth, & - aodvis, absvis) - -#endif - call get_variability(sfac) - - ! Get the active climate/diagnostic shortwave calculations - call rad_cnst_get_call_list(active_calls) - - ! The climate (icall==0) calculation must occur last. - do icall = N_DIAG, 0, -1 - - if (active_calls(icall)) then - - ! update the concentrations in the RRTMG state object - call rrtmg_state_update(state, pbuf, icall, r_state) - -#ifdef OSLO_AERO - !call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & - ! aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) - ! A first call with Oslo aerosols set to zero for radiative forcing diagnostics - ! follwoing the Ghan (2013) method: - - ! for calculation of direct radiative forcing, not necessarily "offline" as such anymore - ! (just nudged), but with an extra call with 0 aerosol extiction. - ! - idrf = .true. - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, & - per_tau*0.0_r8, per_tau_w, per_tau_w_g, per_tau_w_f, & - eccf, coszrs, rd%solin, sfac, cam_in%asdir, & - cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & - fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & - rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & - rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & - IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & - E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & - E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) - - - ftem(:ncol,:pver) = qrs(:ncol,:pver)/cpair - ! - ! Dump shortwave radiation information to history tape buffer (diagnostics) - ! - ! Note that DRF fields are now from the per_tau=0 call (clean), no longer with per_tau from pmxsub - call outfld('QRS_DRF ',ftem ,pcols,lchnk) - ftem(:ncol,:pver) = rd%qrsc(:ncol,:pver)/cpair - call outfld('QRSC_DRF',ftem ,pcols,lchnk) - call outfld('FSNT_DRF',fsnt(:) ,pcols,lchnk) - call outfld('FSNS_DRF',fsns(:) ,pcols,lchnk) - call outfld('FSNTCDRF',rd%fsntc(:) ,pcols,lchnk) - call outfld('FSNSCDRF',rd%fsnsc(:) ,pcols,lchnk) - if (do_aerocom) then - call outfld('FSUTADRF',rd%fsutoa(:),pcols,lchnk) - call outfld('FSDS_DRF',fsds(:) ,pcols,lchnk) - ftem_1d(1:ncol) = fsds(1:ncol)-fsns(1:ncol) - call outfld('FSUS_DRF',ftem_1d,pcols,lchnk) - call outfld('FSDSCDRF',rd%fsdsc(:) ,pcols,lchnk) - end if - idrf = .false. -#else call aer_rad_props_sw(icall, state, pbuf, nnite, idxnite, & aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f) -#endif - - rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) - rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) - rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) - rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) - -#ifdef OSLO_AERO - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, per_tau, per_tau_w, per_tau_w_g, per_tau_w_f, & - eccf, coszrs, rd%solin, sfac, cam_in%asdir, & - cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & - fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & - rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & - rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, idrf, Nday, Nnite, & ! Note the extra idrf - IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & - E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & - E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) -#else - call rad_rrtmg_sw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - cldfprime, aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & - eccf, coszrs, rd%solin, sfac, cam_in%asdir, & - cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & - fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & - rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & - rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & - cam_out%solld, fns, fcns, Nday, Nnite, & - IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & - E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & - E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) -#endif - - ! Output net fluxes at 200 mb - - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) - if (hist_fld_active('FSNR')) then - do i = 1,ncol - call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) - end do - end if - - if (write_output) call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) - - end if - end do - - end if - -#ifdef OSLO_AERO - !Calculate cloud-free fraction assuming random overlap - !(kind of duplicated from cloud_cover_diags::cldsav) - cloudfree(1:ncol) = 1.0_r8 - cloudfreemax(1:ncol) = 1.0_r8 - !Find cloud-free fraction (note this duplicated code and may not be consistent with cldtot calculated elsewhere) - do k = 1, pver - do i=1,ncol - cloudfree(i) = cloudfree(i) * cloudfreemax(i) - cloudfreemax(i) = min(cloudfreemax(i),1.0_r8-cld(i,k)) - end do - end do - - !Calculate AOD (visible) for cloud free - do i = 1, ncol - clearodvis(i)=cloudfree(i)*aodvis(i) - clearabsvis(i)=cloudfree(i)*absvis(i) - end do - - ! clear-sky AOD and absorptive AOD for visible wavelength close to 0.55 um (0.35-0.64) - ! Note that caodvis and cabsvis output should be devided by dayfoc*cloudfree to give physical (A)AOD values - call outfld('CAODVIS ',clearodvis,pcols,lchnk) - call outfld('CABSVIS ',clearabsvis,pcols,lchnk) - call outfld('CLDFREE ',cloudfree,pcols,lchnk) -#ifdef AEROCOM - if (do_aerocom) then - do i = 1, ncol - clearod440(i)=cloudfree(i)*dod440(i) - clearod550(i)=cloudfree(i)*dod550(i) - clearod870(i)=cloudfree(i)*dod870(i) - clearabs550(i)=cloudfree(i)*abs550(i) - clearabs550alt(i)=cloudfree(i)*abs550alt(i) - end do - call outfld('CDOD440 ',clearod440 ,pcols,lchnk) - call outfld('CDOD550 ',clearod550 ,pcols,lchnk) - call outfld('CDOD870 ',clearod870 ,pcols,lchnk) - call outfld('CABS550 ',clearabs550 ,pcols,lchnk) - call outfld('CABS550A',clearabs550alt,pcols,lchnk) - end if -#endif -#endif - - ! Output aerosol mmr - call rad_cnst_out(0, state, pbuf) - - ! Longwave radiation computation - - if (dolw) then - - call rad_cnst_get_call_list(active_calls) - - ! The climate (icall==0) calculation must occur last. - do icall = N_DIAG, 0, -1 - - if (active_calls(icall)) then - - ! update the conctrations in the RRTMG state object - call rrtmg_state_update( state, pbuf, icall, r_state) - - call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) - - ! for calculation of direct and direct radiative forcing - -#ifdef OSLO_AERO - call rad_rrtmg_lw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - per_lw_abs*0.0_r8, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & - flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & - rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & - lu, ld) - - call outfld('FLNT_DRF',flnt(:) ,pcols,lchnk) - call outfld('FLNTCDRF',rd%flntc(:) ,pcols,lchnk) - - call rad_rrtmg_lw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - per_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & - flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & - rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & - lu, ld) - - ! FLNT_ORG is just for temporary testing vs. FLNT - ftem_1d(1:ncol) = cam_out%flwds(1:ncol) - flns(1:ncol) - call outfld('FLUS ',ftem_1d ,pcols,lchnk) -#else - call rad_rrtmg_lw( & - lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & - aer_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & - flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & - rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & - lu, ld) -#endif - - ! Output fluxes at 200 mb - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) - call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) - if (hist_fld_active('FLNR')) then - do i = 1,ncol - call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fnl(i,:), rd%flnr(i)) - end do - end if - - flntclr(:) = 0._r8 - freqclr(:) = 0._r8 - do i = 1, ncol - if (maxval(cldfprime(i,:)) <= 0.1_r8) then - freqclr(i) = 1._r8 - flntclr(i) = rd%flntc(i) - end if - end do - - if (write_output) call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) - - end if - end do - - end if - - ! deconstruct the RRTMG state object - call rrtmg_state_destroy(r_state) - - if (docosp) then - - ! initialize and calculate emis - emis(:,:) = 0._r8 - emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(rrtmg_lw_cloudsim_band,:ncol,:)) - call outfld('EMIS', emis, pcols, lchnk) - - ! compute grid-box mean SW and LW snow optical depth for use by COSP - gb_snow_tau(:,:) = 0._r8 - gb_snow_lw(:,:) = 0._r8 - if (cldfsnow_idx > 0) then - do i = 1, ncol - do k = 1, pver - if (cldfsnow(i,k) > 0._r8) then - gb_snow_tau(i,k) = snow_tau(rrtmg_sw_cloudsim_band,i,k)*cldfsnow(i,k) - gb_snow_lw(i,k) = snow_lw_abs(rrtmg_lw_cloudsim_band,i,k)*cldfsnow(i,k) - end if - end do - end do - end if - - ! advance counter for this timestep (chunk dimension required for thread safety) - cosp_cnt(lchnk) = cosp_cnt(lchnk) + 1 - - ! if counter is the same as cosp_nradsteps, run cosp and reset counter - if (cosp_nradsteps .eq. cosp_cnt(lchnk)) then - - ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave - ! optical depths are passed. - call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & - cld_swtau_in=cld_tau(rrtmg_sw_cloudsim_band,:,:),& - snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) - cosp_cnt(lchnk) = 0 - end if - end if - - else ! if (dosw .or. dolw) then - - ! convert radiative heating rates from Q*dp to Q for energy conservation - do k =1 , pver - do i = 1, ncol - qrs(i,k) = qrs(i,k)/state%pdel(i,k) - qrl(i,k) = qrl(i,k)/state%pdel(i,k) - end do - end do - - end if ! if (dosw .or. dolw) then + + rd%cld_tau_cloudsim(:ncol,:) = cld_tau(rrtmg_sw_cloudsim_band,:ncol,:) + rd%aer_tau550(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag) + rd%aer_tau400(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag+1) + rd%aer_tau700(:ncol,:) = aer_tau(:ncol,:,idx_sw_diag-1) + + call rad_rrtmg_sw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + cldfprime, aer_tau, aer_tau_w, aer_tau_w_g, aer_tau_w_f, & + eccf, coszrs, rd%solin, sfac, cam_in%asdir, & + cam_in%asdif, cam_in%aldir, cam_in%aldif, qrs, rd%qrsc, & + fsnt, rd%fsntc, rd%fsntoa, rd%fsutoa, rd%fsntoac, & + rd%fsnirt, rd%fsnrtc, rd%fsnirtsq, fsns, rd%fsnsc, & + rd%fsdsc, fsds, cam_out%sols, cam_out%soll, cam_out%solsd, & + cam_out%solld, fns, fcns, Nday, Nnite, & + IdxDay, IdxNite, su, sd, E_cld_tau=c_cld_tau, & + E_cld_tau_w=c_cld_tau_w, E_cld_tau_w_g=c_cld_tau_w_g, & + E_cld_tau_w_f=c_cld_tau_w_f, old_convert=.false.) + + ! Output net fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcns, rd%fsn200c) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fns, rd%fsn200) + if (hist_fld_active('FSNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fns(i,:), rd%fsnr(i)) + end do + end if + + if (write_output) call radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) + + end if + end do + + end if + + ! Output aerosol mmr + call rad_cnst_out(0, state, pbuf) + + ! Longwave radiation computation + + if (dolw) then + + call rad_cnst_get_call_list(active_calls) + + ! The climate (icall==0) calculation must occur last. + do icall = N_DIAG, 0, -1 + + if (active_calls(icall)) then + + ! update the conctrations in the RRTMG state object + call rrtmg_state_update( state, pbuf, icall, r_state) + + call aer_rad_props_lw(icall, state, pbuf, aer_lw_abs) + + call rad_rrtmg_lw( & + lchnk, ncol, num_rrtmg_levs, r_state, state%pmid, & + aer_lw_abs, cldfprime, c_cld_lw_abs, qrl, rd%qrlc, & + flns, flnt, rd%flnsc, rd%flntc, cam_out%flwds, & + rd%flut, rd%flutc, fnl, fcnl, rd%fldsc, & + lu, ld) + + ! Output fluxes at 200 mb + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fnl, rd%fln200) + call vertinterp(ncol, pcols, pverp, state%pint, 20000._r8, fcnl, rd%fln200c) + if (hist_fld_active('FLNR')) then + do i = 1,ncol + call vertinterp(1, 1, pverp, state%pint(i,:), p_trop(i), fnl(i,:), rd%flnr(i)) + end do + end if + + flntclr(:) = 0._r8 + freqclr(:) = 0._r8 + do i = 1, ncol + if (maxval(cldfprime(i,:)) <= 0.1_r8) then + freqclr(i) = 1._r8 + flntclr(i) = rd%flntc(i) + end if + end do + + if (write_output) call radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) + + end if + end do + + end if + + ! deconstruct the RRTMG state object + call rrtmg_state_destroy(r_state) + + if (docosp) then + + ! initialize and calculate emis + emis(:,:) = 0._r8 + emis(:ncol,:) = 1._r8 - exp(-cld_lw_abs(rrtmg_lw_cloudsim_band,:ncol,:)) + call outfld('EMIS', emis, pcols, lchnk) + + ! compute grid-box mean SW and LW snow optical depth for use by COSP + gb_snow_tau(:,:) = 0._r8 + gb_snow_lw(:,:) = 0._r8 + if (cldfsnow_idx > 0) then + do i = 1, ncol + do k = 1, pver + if (cldfsnow(i,k) > 0._r8) then + gb_snow_tau(i,k) = snow_tau(rrtmg_sw_cloudsim_band,i,k)*cldfsnow(i,k) + gb_snow_lw(i,k) = snow_lw_abs(rrtmg_lw_cloudsim_band,i,k)*cldfsnow(i,k) + end if + end do + end do + end if + + ! advance counter for this timestep (chunk dimension required for thread safety) + cosp_cnt(lchnk) = cosp_cnt(lchnk) + 1 + + ! if counter is the same as cosp_nradsteps, run cosp and reset counter + if (cosp_nradsteps .eq. cosp_cnt(lchnk)) then + + ! N.B.: For snow optical properties, the GRID-BOX MEAN shortwave and longwave + ! optical depths are passed. + call cospsimulator_intr_run(state, pbuf, cam_in, emis, coszrs, & + cld_swtau_in=cld_tau(rrtmg_sw_cloudsim_band,:,:),& + snow_tau_in=gb_snow_tau, snow_emis_in=gb_snow_lw) + cosp_cnt(lchnk) = 0 + end if + end if + + else ! if (dosw .or. dolw) then + + ! convert radiative heating rates from Q*dp to Q for energy conservation + do k =1 , pver + do i = 1, ncol + qrs(i,k) = qrs(i,k)/state%pdel(i,k) + qrl(i,k) = qrl(i,k)/state%pdel(i,k) + end do + end do + + end if ! if (dosw .or. dolw) then ! output rad inputs and resulting heating rates call rad_data_write( pbuf, state, cam_in, coszrs ) - ! Compute net radiative heating tendency - call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & - fsnt, flns, flnt, cam_in%asdir, net_flx) - - if (write_output) then - ! Compute heating rate for dtheta/dt - do k = 1, pver - do i = 1, ncol - ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa - end do - end do - call outfld('HR', ftem, pcols, lchnk) - end if + ! Compute net radiative heating tendency + call radheat_tend(state, pbuf, ptend, qrl, qrs, fsns, & + fsnt, flns, flnt, cam_in%asdir, net_flx) - ! convert radiative heating rates to Q*dp for energy conservation - do k = 1, pver - do i = 1, ncol - qrs(i,k) = qrs(i,k)*state%pdel(i,k) - qrl(i,k) = qrl(i,k)*state%pdel(i,k) - end do - end do + if (write_output) then + ! Compute heating rate for dtheta/dt + do k = 1, pver + do i = 1, ncol + ftem(i,k) = (qrs(i,k) + qrl(i,k))/cpair * (1.e5_r8/state%pmid(i,k))**cappa + end do + end do + call outfld('HR', ftem, pcols, lchnk) + end if - cam_out%netsw(:ncol) = fsns(:ncol) + ! convert radiative heating rates to Q*dp for energy conservation + do k = 1, pver + do i = 1, ncol + qrs(i,k) = qrs(i,k)*state%pdel(i,k) + qrl(i,k) = qrl(i,k)*state%pdel(i,k) + end do + end do - if (.not. present(rd_out)) then - deallocate(rd) - end if + cam_out%netsw(:ncol) = fsns(:ncol) - end subroutine radiation_tend + if (.not. present(rd_out)) then + deallocate(rd) + end if - !=============================================================================== +end subroutine radiation_tend - subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) +!=============================================================================== - ! Dump shortwave radiation information to history buffer. +subroutine radiation_output_sw(lchnk, ncol, icall, rd, pbuf, cam_out) - integer , intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: icall - type(rad_out_t), intent(in) :: rd - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(in) :: cam_out + ! Dump shortwave radiation information to history buffer. - ! local variables - real(r8), pointer :: qrs(:,:) - real(r8), pointer :: fsnt(:) - real(r8), pointer :: fsns(:) - real(r8), pointer :: fsds(:) + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out - real(r8) :: ftem(pcols) - !---------------------------------------------------------------------------- + ! local variables + real(r8), pointer :: qrs(:,:) + real(r8), pointer :: fsnt(:) + real(r8), pointer :: fsns(:) + real(r8), pointer :: fsds(:) - call pbuf_get_field(pbuf, qrs_idx, qrs) - call pbuf_get_field(pbuf, fsnt_idx, fsnt) - call pbuf_get_field(pbuf, fsns_idx, fsns) - call pbuf_get_field(pbuf, fsds_idx, fsds) + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- - call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) + call pbuf_get_field(pbuf, qrs_idx, qrs) + call pbuf_get_field(pbuf, fsnt_idx, fsnt) + call pbuf_get_field(pbuf, fsns_idx, fsns) + call pbuf_get_field(pbuf, fsds_idx, fsds) - call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) - call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) + call outfld('SOLIN'//diag(icall), rd%solin, pcols, lchnk) - call outfld('FSNT'//diag(icall), fsnt, pcols, lchnk) - call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) - call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) - call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) + call outfld('QRS'//diag(icall), qrs(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRSC'//diag(icall), rd%qrsc(:ncol,:)/cpair, ncol, lchnk) - ftem(:ncol) = rd%fsntoa(:ncol) - rd%fsntoac(:ncol) - call outfld('SWCF'//diag(icall), ftem, pcols, lchnk) + call outfld('FSNT'//diag(icall), fsnt, pcols, lchnk) + call outfld('FSNTC'//diag(icall), rd%fsntc, pcols, lchnk) + call outfld('FSNTOA'//diag(icall), rd%fsntoa, pcols, lchnk) + call outfld('FSNTOAC'//diag(icall), rd%fsntoac, pcols, lchnk) - call outfld('FSUTOA'//diag(icall), rd%fsutoa, pcols, lchnk) + ftem(:ncol) = rd%fsntoa(:ncol) - rd%fsntoac(:ncol) + call outfld('SWCF'//diag(icall), ftem, pcols, lchnk) - call outfld('FSNIRTOA'//diag(icall), rd%fsnirt, pcols, lchnk) - call outfld('FSNRTOAC'//diag(icall), rd%fsnrtc, pcols, lchnk) - call outfld('FSNRTOAS'//diag(icall), rd%fsnirtsq, pcols, lchnk) + call outfld('FSUTOA'//diag(icall), rd%fsutoa, pcols, lchnk) - call outfld('FSN200'//diag(icall), rd%fsn200, pcols, lchnk) - call outfld('FSN200C'//diag(icall), rd%fsn200c, pcols, lchnk) + call outfld('FSNIRTOA'//diag(icall), rd%fsnirt, pcols, lchnk) + call outfld('FSNRTOAC'//diag(icall), rd%fsnrtc, pcols, lchnk) + call outfld('FSNRTOAS'//diag(icall), rd%fsnirtsq, pcols, lchnk) - call outfld('FSNR'//diag(icall), rd%fsnr, pcols, lchnk) + call outfld('FSN200'//diag(icall), rd%fsn200, pcols, lchnk) + call outfld('FSN200C'//diag(icall), rd%fsn200c, pcols, lchnk) - call outfld('SOLS'//diag(icall), cam_out%sols, pcols, lchnk) - call outfld('SOLL'//diag(icall), cam_out%soll, pcols, lchnk) - call outfld('SOLSD'//diag(icall), cam_out%solsd, pcols, lchnk) - call outfld('SOLLD'//diag(icall), cam_out%solld, pcols, lchnk) + call outfld('FSNR'//diag(icall), rd%fsnr, pcols, lchnk) - call outfld('FSNS'//diag(icall), fsns, pcols, lchnk) - call outfld('FSNSC'//diag(icall), rd%fsnsc, pcols, lchnk) + call outfld('SOLS'//diag(icall), cam_out%sols, pcols, lchnk) + call outfld('SOLL'//diag(icall), cam_out%soll, pcols, lchnk) + call outfld('SOLSD'//diag(icall), cam_out%solsd, pcols, lchnk) + call outfld('SOLLD'//diag(icall), cam_out%solld, pcols, lchnk) - call outfld('FSDS'//diag(icall), fsds, pcols, lchnk) - call outfld('FSDSC'//diag(icall), rd%fsdsc, pcols, lchnk) + call outfld('FSNS'//diag(icall), fsns, pcols, lchnk) + call outfld('FSNSC'//diag(icall), rd%fsnsc, pcols, lchnk) - end subroutine radiation_output_sw + call outfld('FSDS'//diag(icall), fsds, pcols, lchnk) + call outfld('FSDSC'//diag(icall), rd%fsdsc, pcols, lchnk) +end subroutine radiation_output_sw - !=============================================================================== - subroutine radiation_output_cld(lchnk, ncol, rd) +!=============================================================================== - ! Dump shortwave cloud optics information to history buffer. +subroutine radiation_output_cld(lchnk, ncol, rd) - integer , intent(in) :: lchnk - integer, intent(in) :: ncol - type(rad_out_t), intent(in) :: rd - !---------------------------------------------------------------------------- + ! Dump shortwave cloud optics information to history buffer. - call outfld('TOT_CLD_VISTAU', rd%tot_cld_vistau, pcols, lchnk) - call outfld('TOT_ICLD_VISTAU', rd%tot_icld_vistau, pcols, lchnk) - call outfld('LIQ_ICLD_VISTAU', rd%liq_icld_vistau, pcols, lchnk) - call outfld('ICE_ICLD_VISTAU', rd%ice_icld_vistau, pcols, lchnk) - if (cldfsnow_idx > 0) then - call outfld('SNOW_ICLD_VISTAU', rd%snow_icld_vistau, pcols, lchnk) - endif + integer , intent(in) :: lchnk + integer, intent(in) :: ncol + type(rad_out_t), intent(in) :: rd + !---------------------------------------------------------------------------- - end subroutine radiation_output_cld + call outfld('TOT_CLD_VISTAU', rd%tot_cld_vistau, pcols, lchnk) + call outfld('TOT_ICLD_VISTAU', rd%tot_icld_vistau, pcols, lchnk) + call outfld('LIQ_ICLD_VISTAU', rd%liq_icld_vistau, pcols, lchnk) + call outfld('ICE_ICLD_VISTAU', rd%ice_icld_vistau, pcols, lchnk) + if (cldfsnow_idx > 0) then + call outfld('SNOW_ICLD_VISTAU', rd%snow_icld_vistau, pcols, lchnk) + endif - !=============================================================================== +end subroutine radiation_output_cld - subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) +!=============================================================================== - ! Dump longwave radiation information to history buffer +subroutine radiation_output_lw(lchnk, ncol, icall, rd, pbuf, cam_out, freqclr, flntclr) - integer, intent(in) :: lchnk - integer, intent(in) :: ncol - integer, intent(in) :: icall ! icall=0 for climate diagnostics - type(rad_out_t), intent(in) :: rd - type(physics_buffer_desc), pointer :: pbuf(:) - type(cam_out_t), intent(in) :: cam_out - real(r8), intent(in) :: freqclr(pcols) - real(r8), intent(in) :: flntclr(pcols) + ! Dump longwave radiation information to history buffer - ! local variables - real(r8), pointer :: qrl(:,:) - real(r8), pointer :: flnt(:) - real(r8), pointer :: flns(:) + integer, intent(in) :: lchnk + integer, intent(in) :: ncol + integer, intent(in) :: icall ! icall=0 for climate diagnostics + type(rad_out_t), intent(in) :: rd + type(physics_buffer_desc), pointer :: pbuf(:) + type(cam_out_t), intent(in) :: cam_out + real(r8), intent(in) :: freqclr(pcols) + real(r8), intent(in) :: flntclr(pcols) - real(r8) :: ftem(pcols) - !---------------------------------------------------------------------------- + ! local variables + real(r8), pointer :: qrl(:,:) + real(r8), pointer :: flnt(:) + real(r8), pointer :: flns(:) - call pbuf_get_field(pbuf, qrl_idx, qrl) - call pbuf_get_field(pbuf, flnt_idx, flnt) - call pbuf_get_field(pbuf, flns_idx, flns) + real(r8) :: ftem(pcols) + !---------------------------------------------------------------------------- - call outfld('QRL'//diag(icall), qrl(:ncol,:)/cpair, ncol, lchnk) - call outfld('QRLC'//diag(icall), rd%qrlc(:ncol,:)/cpair, ncol, lchnk) + call pbuf_get_field(pbuf, qrl_idx, qrl) + call pbuf_get_field(pbuf, flnt_idx, flnt) + call pbuf_get_field(pbuf, flns_idx, flns) - call outfld('FLNT'//diag(icall), flnt, pcols, lchnk) - call outfld('FLNTC'//diag(icall), rd%flntc, pcols, lchnk) + call outfld('QRL'//diag(icall), qrl(:ncol,:)/cpair, ncol, lchnk) + call outfld('QRLC'//diag(icall), rd%qrlc(:ncol,:)/cpair, ncol, lchnk) - call outfld('FREQCLR'//diag(icall), freqclr, pcols, lchnk) - call outfld('FLNTCLR'//diag(icall), flntclr, pcols, lchnk) + call outfld('FLNT'//diag(icall), flnt, pcols, lchnk) + call outfld('FLNTC'//diag(icall), rd%flntc, pcols, lchnk) - call outfld('FLUT'//diag(icall), rd%flut, pcols, lchnk) - call outfld('FLUTC'//diag(icall), rd%flutc, pcols, lchnk) + call outfld('FREQCLR'//diag(icall), freqclr, pcols, lchnk) + call outfld('FLNTCLR'//diag(icall), flntclr, pcols, lchnk) - ftem(:ncol) = rd%flutc(:ncol) - rd%flut(:ncol) - call outfld('LWCF'//diag(icall), ftem, pcols, lchnk) + call outfld('FLUT'//diag(icall), rd%flut, pcols, lchnk) + call outfld('FLUTC'//diag(icall), rd%flutc, pcols, lchnk) + + ftem(:ncol) = rd%flutc(:ncol) - rd%flut(:ncol) + call outfld('LWCF'//diag(icall), ftem, pcols, lchnk) - call outfld('FLN200'//diag(icall), rd%fln200, pcols, lchnk) - call outfld('FLN200C'//diag(icall), rd%fln200c, pcols, lchnk) + call outfld('FLN200'//diag(icall), rd%fln200, pcols, lchnk) + call outfld('FLN200C'//diag(icall), rd%fln200c, pcols, lchnk) - call outfld('FLNR'//diag(icall), rd%flnr, pcols, lchnk) + call outfld('FLNR'//diag(icall), rd%flnr, pcols, lchnk) - call outfld('FLNS'//diag(icall), flns, pcols, lchnk) - call outfld('FLNSC'//diag(icall), rd%flnsc, pcols, lchnk) + call outfld('FLNS'//diag(icall), flns, pcols, lchnk) + call outfld('FLNSC'//diag(icall), rd%flnsc, pcols, lchnk) - call outfld('FLDS'//diag(icall), cam_out%flwds, pcols, lchnk) - call outfld('FLDSC'//diag(icall), rd%fldsc, pcols, lchnk) + call outfld('FLDS'//diag(icall), cam_out%flwds, pcols, lchnk) + call outfld('FLDSC'//diag(icall), rd%fldsc, pcols, lchnk) - end subroutine radiation_output_lw +end subroutine radiation_output_lw - !=============================================================================== +!=============================================================================== - subroutine calc_col_mean(state, mmr_pointer, mean_value) +subroutine calc_col_mean(state, mmr_pointer, mean_value) - ! Compute the column mean mass mixing ratio. + ! Compute the column mean mass mixing ratio. - type(physics_state), intent(in) :: state - real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) - real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr + type(physics_state), intent(in) :: state + real(r8), dimension(:,:), pointer :: mmr_pointer ! mass mixing ratio (lev) + real(r8), dimension(pcols), intent(out) :: mean_value ! column mean mmr - integer :: i, k, ncol - real(r8) :: ptot(pcols) - !----------------------------------------------------------------------- + integer :: i, k, ncol + real(r8) :: ptot(pcols) + !----------------------------------------------------------------------- - ncol = state%ncol - mean_value = 0.0_r8 - ptot = 0.0_r8 + ncol = state%ncol + mean_value = 0.0_r8 + ptot = 0.0_r8 - do k=1,pver - do i=1,ncol - mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) - ptot(i) = ptot(i) + state%pdeldry(i,k) - end do - end do - do i=1,ncol - mean_value(i) = mean_value(i) / ptot(i) - end do + do k=1,pver + do i=1,ncol + mean_value(i) = mean_value(i) + mmr_pointer(i,k)*state%pdeldry(i,k) + ptot(i) = ptot(i) + state%pdeldry(i,k) + end do + end do + do i=1,ncol + mean_value(i) = mean_value(i) / ptot(i) + end do - end subroutine calc_col_mean +end subroutine calc_col_mean - !=============================================================================== +!=============================================================================== end module radiation + diff --git a/src/physics/rrtmg/radlw.F90 b/src/physics/rrtmg/radlw.F90 index 5d29c2198c..b2b56a751c 100644 --- a/src/physics/rrtmg/radlw.F90 +++ b/src/physics/rrtmg/radlw.F90 @@ -5,7 +5,6 @@ module radlw ! Purpose: Longwave radiation calculations. ! !----------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols, pver, pverp use scamMod, only: single_column, scm_crm_mode @@ -186,7 +185,6 @@ subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & tsfc(:ncol) = r_state%tlev(:ncol,rrtmg_levs+1) taua_lw(:ncol, 1:rrtmg_levs-1, :nbndlw) = aer_lw_abs(:ncol,pverp-rrtmg_levs+1:pverp-1,:nbndlw) - if (associated(lu)) lu(1:ncol,:,:) = 0.0_r8 if (associated(ld)) ld(1:ncol,:,:) = 0.0_r8 @@ -229,16 +227,12 @@ subroutine rad_rrtmg_lw(lchnk ,ncol ,rrtmg_levs,r_state, & fsul(:ncol,pverp-rrtmg_levs+1:pverp)=uflxc(:ncol,rrtmg_levs:1:-1) fsdl(:ncol,pverp-rrtmg_levs+1:pverp)=dflxc(:ncol,rrtmg_levs:1:-1) -#ifndef OSLO_AERO if (single_column.and.scm_crm_mode) then -#endif call outfld('FUL ',ful,pcols,lchnk) call outfld('FDL ',fdl,pcols,lchnk) call outfld('FULC ',fsul,pcols,lchnk) call outfld('FDLC ',fsdl,pcols,lchnk) -#ifndef OSLO_AERO endif -#endif fnl(:ncol,:) = ful(:ncol,:) - fdl(:ncol,:) ! mji/ cam excluded this? diff --git a/src/physics/rrtmg/radsw.F90 b/src/physics/rrtmg/radsw.F90 index 165fa7a931..df222557dd 100644 --- a/src/physics/rrtmg/radsw.F90 +++ b/src/physics/rrtmg/radsw.F90 @@ -5,7 +5,6 @@ module radsw ! Purpose: Solar radiation calculations. ! !----------------------------------------------------------------------- - use shr_kind_mod, only: r8 => shr_kind_r8 use ppgrid, only: pcols, pver, pverp use cam_abortutils, only: endrun @@ -23,6 +22,7 @@ module radsw implicit none private +save real(r8) :: fractional_solar_irradiance(1:nbndsw) ! fraction of solar irradiance in each band real(r8) :: solar_band_irrad(1:nbndsw) ! rrtmg-assumed solar irradiance in each sw band @@ -49,11 +49,7 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & qrs ,qrsc ,fsnt ,fsntc ,fsntoa,fsutoa, & fsntoac ,fsnirtoa ,fsnrtoac ,fsnrtoaq ,fsns , & fsnsc ,fsdsc ,fsds ,sols ,soll , & -#ifdef OSLO_AERO - solsd ,solld ,fns ,fcns ,idrf , & -#else solsd ,solld ,fns ,fcns , & -#endif Nday ,Nnite ,IdxDay ,IdxNite , & su ,sd , & E_cld_tau, E_cld_tau_w, E_cld_tau_w_g, E_cld_tau_w_f, & @@ -164,10 +160,6 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & real(r8), intent(out) :: fns(pcols,pverp) ! net flux at interfaces real(r8), intent(out) :: fcns(pcols,pverp) ! net clear-sky flux at interfaces -#ifdef OSLO_AERO - logical, intent(in) :: idrf -#endif - real(r8), pointer, dimension(:,:,:) :: su ! shortwave spectral flux up real(r8), pointer, dimension(:,:,:) :: sd ! shortwave spectral flux down @@ -312,17 +304,12 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & qrsc(1:ncol,1:pver) = 0.0_r8 fns(1:ncol,1:pverp) = 0.0_r8 fcns(1:ncol,1:pverp) = 0.0_r8 - -#ifndef OSLO_AERO if (single_column.and.scm_crm_mode) then -#endif fus(1:ncol,1:pverp) = 0.0_r8 fds(1:ncol,1:pverp) = 0.0_r8 fusc(:ncol,:pverp) = 0.0_r8 fdsc(:ncol,:pverp) = 0.0_r8 -#ifndef OSLO_AERO endif -#endif if (associated(su)) su(1:ncol,:,:) = 0.0_r8 if (associated(sd)) sd(1:ncol,:,:) = 0.0_r8 @@ -635,28 +622,17 @@ subroutine rad_rrtmg_sw(lchnk,ncol ,rrtmg_levs ,r_state , & end if ! these outfld calls don't work for spmd only outfield in scm mode (nonspmd) - ! Following outputs added for CRM -#ifndef OSLO_AERO if (single_column .and. scm_crm_mode) then -#endif + ! Following outputs added for CRM call ExpDayNite(fus,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) - call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call ExpDayNite(fds,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) + call ExpDayNite(fusc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call ExpDayNite(fdsc,Nday, IdxDay, Nnite, IdxNite, 1, pcols, 1, pverp) call outfld('FUS ', fus, pcols, lchnk) - call outfld('FUSC ', fusc, pcols, lchnk) call outfld('FDS ', fds, pcols, lchnk) + call outfld('FUSC ', fusc, pcols, lchnk) call outfld('FDSC ', fdsc, pcols, lchnk) -#ifndef OSLO_AERO - end if -#endif - -#ifdef OSLO_AERO - if (idrf) then - call outfld('FUSCDRF ', fusc, pcols, lchnk) - call outfld('FDSCDRF ', fdsc, pcols, lchnk) endif -#endif end subroutine rad_rrtmg_sw From abf2e2786b73ea6f6d7cb3495c909bba0f856cfa Mon Sep 17 00:00:00 2001 From: Mariana Vertenstein Date: Tue, 30 Jan 2024 14:06:03 +0100 Subject: [PATCH 71/71] more updates for noresm21 compatibility --- src/NorESM/cam_diagnostics.F90 | 506 +++++++------- src/NorESM/phys_control.F90 | 4 +- src/NorESM/physpkg.F90 | 74 +- src/NorESM/zm_conv_intr.F90 | 3 +- src/physics/cam/diffusion_solver.F90 | 989 +++++++++++++++++++++++++++ src/physics/cam/ndrop.F90 | 56 +- src/physics/spcam/spcam_drivers.F90 | 4 +- 7 files changed, 1290 insertions(+), 346 deletions(-) create mode 100644 src/physics/cam/diffusion_solver.F90 diff --git a/src/NorESM/cam_diagnostics.F90 b/src/NorESM/cam_diagnostics.F90 index f58ca9491f..7537fe8661 100644 --- a/src/NorESM/cam_diagnostics.F90 +++ b/src/NorESM/cam_diagnostics.F90 @@ -104,12 +104,6 @@ module cam_diagnostics integer :: trefmxav_idx = -1, trefmnav_idx = -1 -#ifdef AEROCOM -logical :: do_aerocom = .true. -#else -logical :: do_aerocom = .false. -#endif - contains !============================================================================== @@ -188,16 +182,12 @@ subroutine diag_init_dry(pbuf2d) integer :: k, m integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. -!AL integer :: ixcldni, ixcldnc ! constituent indices for cloud liquid and ice water. -!AL integer :: ierr -!+ AEROCOM beg - character(len=10) :: modeString - character(len=20) :: varname - integer :: i, irh -!+ AEROCOM end + character(len=10) :: modeString ! aerocom + character(len=20) :: varname ! aerocom + integer :: i ! aerocom ! outfld calls in diag_phys_writeout call addfld (cnst_name(1), (/ 'lev' /), 'A', 'kg/kg', cnst_longname(1)) @@ -225,7 +215,8 @@ subroutine diag_init_dry(pbuf2d) call addfld (apcnst(1), (/ 'lev' /), 'A','kg/kg', trim(cnst_longname(1))//' (after physics)') if ( dycore_is('LR') .or. dycore_is('SE') ) then call addfld ('TFIX', horiz_only, 'A', 'K/s', 'T fixer (T equivalent of Energy correction)') -!+tht + + !+tht call addfld ('EBREAK', horiz_only, 'A','W/m2', 'Global-mean energy-nonconservation (W/m2)') call addfld ('PTTEND_DME', (/ 'lev' /), 'A', 'K/s ', & 'T-tendency due to dry mass adjustment at the end of tphysac' ) @@ -233,7 +224,7 @@ subroutine diag_init_dry(pbuf2d) 'Column DSE tendency due to mass adjustment at end of tphysac' ) call addfld ('EFLX ' , horiz_only, 'A','W/m2 ', & 'Material enthalpy flux due to mass adjustment at end of tphysac') -!-tht + !-tht end if call addfld ('TTEND_TOT', (/ 'lev' /), 'A', 'K/s', 'Total temperature tendency') @@ -313,6 +304,7 @@ subroutine diag_init_dry(pbuf2d) call addfld ('ATMEINT', horiz_only, 'A', 'J/m2','Vertically integrated total atmospheric energy ') +#ifdef OSLO_AERO call addfld ('AOD_VIS ',horiz_only, 'A','unitless','Aerosol optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um call addfld ('ABSVIS ',horiz_only, 'A','unitless','Aerosol absorptive optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um call addfld ('AODVVOLC ',horiz_only, 'A','unitless','CMIP6 volcanic aerosol optical depth at 0.442-0.625um') ! CAM4-Oslo: 0.35-0.64um @@ -327,7 +319,6 @@ subroutine diag_init_dry(pbuf2d) call addfld ('EXTVIS ',(/'lev'/), 'A','1/km ','Aerosol extinction') call addfld ('BVISVOLC ',(/'lev'/), 'A','1/km ','CMIP6 volcanic aerosol extinction at 0.442-0.625um') - ! AEROFFL start call addfld ('FSNT_DRF',horiz_only, 'A','W/m^2','Total column absorbed solar flux (DIRind)') call addfld ('FSNTCDRF',horiz_only, 'A','W/m^2','Clear sky total column absorbed solar flux (DIRind)' ) call addfld ('FSNS_DRF',horiz_only, 'A','W/m^2 ','Surface absorbed solar flux (DIRind)' ) @@ -341,9 +332,8 @@ subroutine diag_init_dry(pbuf2d) call addfld ('FSUS_DRF',horiz_only, 'A','W/m^2 ','SW upwelling flux at surface') call addfld ('FSDSCDRF',horiz_only, 'A','W/m^2 ','SW downwelling clear sky flux at surface') call addfld ('FLUS ',horiz_only, 'A','W/m^2 ','LW surface upwelling flux') - ! AEROFFL end - if (do_aerocom) then +#ifdef AEROCOM call addfld ('AKCXS ',horiz_only, 'A','mg/m2 ','Scheme excess aerosol mass burden') call addfld ('PMTOT ',horiz_only, 'A','ug/m3 ','Aerosol PM, all sizes') call addfld ('PM25 ',horiz_only, 'A','ug/m3 ','Aerosol PM2.5') @@ -456,7 +446,7 @@ subroutine diag_init_dry(pbuf2d) call addfld ('DGT_SO4 ',horiz_only, 'A','unitless','SO4 aerosol optical depth 550nm gt05') call addfld ('DGT_POM ',horiz_only, 'A','unitless','OC aerosol optical depth 550nm gt05') call addfld ('DGT_BC ',horiz_only, 'A','unitless','BC aerosol optical depth 550nm gt05') - call addfld ('AIRMASS ',horiz_only, 'A','kg/m2 ','Vertically integrated airmass') !akc6 + call addfld ('AIRMASS ',horiz_only, 'A','kg/m2 ','Vertically integrated airmass') call addfld ('NNAT_0 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 0 number concentration') call addfld ('NNAT_1 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 1 number concentration') call addfld ('NNAT_2 ',(/'lev'/),'A','1/cm3 ','Aerosol mode 2 number concentration') @@ -474,7 +464,7 @@ subroutine diag_init_dry(pbuf2d) call addfld ('BATOTVIS',(/'lev'/),'A','1/km','Aerosol 3d absorption at 0.442-0.625') ! CAM4-Oslo: 0.35-0.64um call addfld ('BATSW13 ',(/'lev'/),'A','1/km','Aerosol 3d SW absorption at 3.077-3.846um') call addfld ('BATLW01 ',(/'lev'/),'A','1/km','Aerosol 3d LW absorption depth at 3.077-3.846um') -#ifdef OSLO_AERO + do i=1,nbmodes modeString=" " write(modeString,"(I2)"),i @@ -489,8 +479,9 @@ subroutine diag_init_dry(pbuf2d) varName = "Cxsrel"//trim(modeString) if(i.ne.3) call addfld(varName, horiz_only, 'A', 'unitless', 'relative exessive added mass column for mode'//modeString) enddo -#endif - end if + +#endif ! AEROCOM +#endif ! OSLO_AERO if (history_amwg) then call add_default ('PHIS ' , 1, ' ') @@ -566,10 +557,6 @@ subroutine diag_init_dry(pbuf2d) call add_default ('PTTEND' , history_budget_histfile_num, ' ') end if -!akc6+ CNVCLD is zero -! call add_default ('CNVCLD ', 1, ' ') -!akc6- - ! create history variables for fourier coefficients of the diurnal ! and semidiurnal tide in T, U, V, and Z3 call tidal_diag_init() @@ -610,23 +597,24 @@ subroutine diag_init_dry(pbuf2d) ! Axial Angular Momentum diagnostics ! call addfld ('MR_pBF', horiz_only, 'A', 'kg*m2/s*rad2',& - 'Total column wind axial angular momentum before energy fixer') + 'Total column wind axial angular momentum before energy fixer') call addfld ('MR_pBP', horiz_only, 'A', 'kg*m2/s*rad2',& - 'Total column wind axial angular momentum before parameterizations') + 'Total column wind axial angular momentum before parameterizations') call addfld ('MR_pAP', horiz_only, 'A', 'kg*m2/s*rad2',& 'Total column wind axial angular momentum after parameterizations') call addfld ('MR_pAM', horiz_only, 'A', 'kg*m2/s*rad2',& 'Total column wind axial angular momentum after dry mass correction') call addfld ('MO_pBF', horiz_only, 'A', 'kg*m2/s*rad2',& - 'Total column mass axial angular momentum before energy fixer') + 'Total column mass axial angular momentum before energy fixer') call addfld ('MO_pBP', horiz_only, 'A', 'kg*m2/s*rad2',& - 'Total column mass axial angular momentum before parameterizations') + 'Total column mass axial angular momentum before parameterizations') call addfld ('MO_pAP', horiz_only, 'A', 'kg*m2/s*rad2',& 'Total column mass axial angular momentum after parameterizations') call addfld ('MO_pAM', horiz_only, 'A', 'kg*m2/s*rad2',& 'Total column mass axial angular momentum after dry mass correction') +#ifdef OSLO_AERO call add_default ('AOD_VIS ', 1, ' ') call add_default ('ABSVIS ', 1, ' ') call add_default ('AODVVOLC', 1, ' ') @@ -636,168 +624,168 @@ subroutine diag_init_dry(pbuf2d) call add_default ('CABSVIS ', 1, ' ') call add_default ('CLDFREE ', 1, ' ') call add_default ('N_AER ', 1, ' ') -!- call add_default ('N_AERORG', 1, ' ') call add_default ('SSAVIS ', 1, ' ') call add_default ('ASYMMVIS', 1, ' ') call add_default ('EXTVIS ', 1, ' ') call add_default ('BVISVOLC', 1, ' ') - call add_default ('FSNT_DRF', 1, ' ') - call add_default ('FSNTCDRF', 1, ' ') - call add_default ('FSNS_DRF', 1, ' ') - call add_default ('FSNSCDRF', 1, ' ') - call add_default ('QRS_DRF ', 1, ' ') - call add_default ('QRSC_DRF', 1, ' ') - call add_default ('FLNT_DRF', 1, ' ') - call add_default ('FLNTCDRF', 1, ' ') - call add_default ('FSUTADRF', 1, ' ') - call add_default ('FSDS_DRF', 1, ' ') - call add_default ('FSUS_DRF', 1, ' ') - call add_default ('FSDSCDRF', 1, ' ') - call add_default ('FLUS ', 1, ' ') - if (do_aerocom) then - call add_default ('AKCXS ', 1, ' ') - call add_default ('PMTOT ', 1, ' ') - call add_default ('PM25 ', 1, ' ') - call add_default ('PM2P5 ', 1, ' ') - call add_default ('MMRPM2P5', 1, ' ') - call add_default ('MMRPM1 ', 1, ' ') - call add_default ('GRIDAREA', 1, ' ') - call add_default ('DAERH2O ', 1, ' ') - call add_default ('MMR_AH2O', 1, ' ') - call add_default ('ECDRYAER', 1, ' ') - call add_default ('ABSDRYAE', 1, ' ') - call add_default ('ECDRY440', 1, ' ') - call add_default ('ABSDR440', 1, ' ') - call add_default ('ECDRY870', 1, ' ') - call add_default ('ABSDR870', 1, ' ') - call add_default ('ASYMMDRY', 1, ' ') - call add_default ('ECDRYLT1', 1, ' ') - call add_default ('ABSDRYBC', 1, ' ') - call add_default ('ABSDRYOC', 1, ' ') - call add_default ('ABSDRYSU', 1, ' ') - call add_default ('ABSDRYSS', 1, ' ') - call add_default ('ABSDRYDU', 1, ' ') - call add_default ('OD550DRY', 1, ' ') - call add_default ('AB550DRY', 1, ' ') - call add_default ('DERLT05 ', 1, ' ') - call add_default ('DERGT05 ', 1, ' ') - call add_default ('DER ', 1, ' ') - call add_default ('DOD440 ', 1, ' ') - call add_default ('ABS440 ', 1, ' ') - call add_default ('DOD500 ', 1, ' ') - call add_default ('ABS500 ', 1, ' ') - call add_default ('DOD550 ', 1, ' ') - call add_default ('ABS550 ', 1, ' ') - call add_default ('ABS550AL', 1, ' ') - call add_default ('DOD670 ', 1, ' ') - call add_default ('ABS670 ', 1, ' ') - call add_default ('DOD870 ', 1, ' ') - call add_default ('ABS870 ', 1, ' ') - call add_default ('DLOAD_MI', 1, ' ') - call add_default ('DLOAD_SS', 1, ' ') - call add_default ('DLOAD_S4', 1, ' ') - call add_default ('DLOAD_OC', 1, ' ') - call add_default ('DLOAD_BC', 1, ' ') - call add_default ('LOADBCAC', 1, ' ') - call add_default ('LOADBC0 ', 1, ' ') - call add_default ('LOADBC2 ', 1, ' ') - call add_default ('LOADBC4 ', 1, ' ') - call add_default ('LOADBC12', 1, ' ') - call add_default ('LOADBC14', 1, ' ') - call add_default ('LOADOCAC', 1, ' ') - call add_default ('LOADOC4 ', 1, ' ') - call add_default ('LOADOC14', 1, ' ') -! - call add_default ('EC550AER', 1, ' ') - call add_default ('ABS550_A', 1, ' ') - call add_default ('BS550AER', 1, ' ') -! - call add_default ('EC550SO4', 1, ' ') - call add_default ('EC550BC ', 1, ' ') - call add_default ('EC550POM', 1, ' ') - call add_default ('EC550SS ', 1, ' ') - call add_default ('EC550DU ', 1, ' ') -! - call add_default ('CDOD440 ', 1, ' ') - call add_default ('CDOD550 ', 1, ' ') - call add_default ('CABS550 ', 1, ' ') - call add_default ('CABS550A', 1, ' ') - call add_default ('CDOD870 ', 1, ' ') - call add_default ('A550_DU ', 1, ' ') - call add_default ('A550_SS ', 1, ' ') - call add_default ('A550_SO4', 1, ' ') - call add_default ('A550_POM', 1, ' ') - call add_default ('A550_BC ', 1, ' ') - call add_default ('D440_DU ', 1, ' ') - call add_default ('D440_SS ', 1, ' ') - call add_default ('D440_SO4', 1, ' ') - call add_default ('D440_POM', 1, ' ') - call add_default ('D440_BC ', 1, ' ') - call add_default ('D500_DU ', 1, ' ') - call add_default ('D500_SS ', 1, ' ') - call add_default ('D500_SO4', 1, ' ') - call add_default ('D500_POM', 1, ' ') - call add_default ('D500_BC ', 1, ' ') - call add_default ('D550_DU ', 1, ' ') - call add_default ('D550_SS ', 1, ' ') - call add_default ('D550_SO4', 1, ' ') - call add_default ('D550_POM', 1, ' ') - call add_default ('D550_BC ', 1, ' ') - call add_default ('D670_DU ', 1, ' ') - call add_default ('D670_SS ', 1, ' ') - call add_default ('D670_SO4', 1, ' ') - call add_default ('D670_POM', 1, ' ') - call add_default ('D670_BC ', 1, ' ') - call add_default ('D870_DU ', 1, ' ') - call add_default ('D870_SS ', 1, ' ') - call add_default ('D870_SO4', 1, ' ') - call add_default ('D870_POM', 1, ' ') - call add_default ('D870_BC ', 1, ' ') - call add_default ('DLT_DUST', 1, ' ') - call add_default ('DLT_SS ', 1, ' ') - call add_default ('DLT_SO4 ', 1, ' ') - call add_default ('DLT_POM ', 1, ' ') - call add_default ('DLT_BC ', 1, ' ') - call add_default ('DGT_DUST', 1, ' ') - call add_default ('DGT_SS ', 1, ' ') - call add_default ('DGT_SO4 ', 1, ' ') - call add_default ('DGT_POM ', 1, ' ') - call add_default ('DGT_BC ', 1, ' ') - call add_default ('NNAT_0 ', 1, ' ') - call add_default ('NNAT_1 ', 1, ' ') - call add_default ('NNAT_2 ', 1, ' ') - call add_default ('NNAT_4 ', 1, ' ') - call add_default ('NNAT_5 ', 1, ' ') - call add_default ('NNAT_6 ', 1, ' ') - call add_default ('NNAT_7 ', 1, ' ') - call add_default ('NNAT_8 ', 1, ' ') - call add_default ('NNAT_9 ', 1, ' ') - call add_default ('NNAT_10 ', 1, ' ') - call add_default ('NNAT_12 ', 1, ' ') - call add_default ('NNAT_14 ', 1, ' ') - call add_default ('AIRMASSL', 1, ' ') !akc6 - call add_default ('AIRMASS ', 1, ' ') !akc6 - call add_default ('BETOTVIS', 1, ' ') - call add_default ('BATOTVIS', 1, ' ') - call add_default ('BATSW13 ', 1, ' ') - call add_default ('BATLW01 ', 1, ' ') -#ifdef OSLO_AERO - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Camrel"//trim(modeString) - if(i.ne.3) call add_default(varName, 1, ' ') - enddo - do i=1,nbmodes - modeString=" " - write(modeString,"(I2)"),i - if(i.lt.10) modeString="0"//adjustl(modeString) - varName = "Cxsrel"//trim(modeString) - if(i.ne.3) call add_default(varName, 1, ' ') - enddo -#endif - end if + call add_default ('FSNT_DRF', 1, ' ') + call add_default ('FSNTCDRF', 1, ' ') + call add_default ('FSNS_DRF', 1, ' ') + call add_default ('FSNSCDRF', 1, ' ') + call add_default ('QRS_DRF ', 1, ' ') + call add_default ('QRSC_DRF', 1, ' ') + call add_default ('FLNT_DRF', 1, ' ') + call add_default ('FLNTCDRF', 1, ' ') + call add_default ('FSUTADRF', 1, ' ') + call add_default ('FSDS_DRF', 1, ' ') + call add_default ('FSUS_DRF', 1, ' ') + call add_default ('FSDSCDRF', 1, ' ') + call add_default ('FLUS ', 1, ' ') +#ifdef AEROCOM + call add_default ('AKCXS ', 1, ' ') + call add_default ('PMTOT ', 1, ' ') + call add_default ('PM25 ', 1, ' ') + call add_default ('PM2P5 ', 1, ' ') + call add_default ('MMRPM2P5', 1, ' ') + call add_default ('MMRPM1 ', 1, ' ') + call add_default ('GRIDAREA', 1, ' ') + call add_default ('DAERH2O ', 1, ' ') + call add_default ('MMR_AH2O', 1, ' ') + call add_default ('ECDRYAER', 1, ' ') + call add_default ('ABSDRYAE', 1, ' ') + call add_default ('ECDRY440', 1, ' ') + call add_default ('ABSDR440', 1, ' ') + call add_default ('ECDRY870', 1, ' ') + call add_default ('ABSDR870', 1, ' ') + call add_default ('ASYMMDRY', 1, ' ') + call add_default ('ECDRYLT1', 1, ' ') + call add_default ('ABSDRYBC', 1, ' ') + call add_default ('ABSDRYOC', 1, ' ') + call add_default ('ABSDRYSU', 1, ' ') + call add_default ('ABSDRYSS', 1, ' ') + call add_default ('ABSDRYDU', 1, ' ') + call add_default ('OD550DRY', 1, ' ') + call add_default ('AB550DRY', 1, ' ') + call add_default ('DERLT05 ', 1, ' ') + call add_default ('DERGT05 ', 1, ' ') + call add_default ('DER ', 1, ' ') + call add_default ('DOD440 ', 1, ' ') + call add_default ('ABS440 ', 1, ' ') + call add_default ('DOD500 ', 1, ' ') + call add_default ('ABS500 ', 1, ' ') + call add_default ('DOD550 ', 1, ' ') + call add_default ('ABS550 ', 1, ' ') + call add_default ('ABS550AL', 1, ' ') + call add_default ('DOD670 ', 1, ' ') + call add_default ('ABS670 ', 1, ' ') + call add_default ('DOD870 ', 1, ' ') + call add_default ('ABS870 ', 1, ' ') + call add_default ('DLOAD_MI', 1, ' ') + call add_default ('DLOAD_SS', 1, ' ') + call add_default ('DLOAD_S4', 1, ' ') + call add_default ('DLOAD_OC', 1, ' ') + call add_default ('DLOAD_BC', 1, ' ') + call add_default ('LOADBCAC', 1, ' ') + call add_default ('LOADBC0 ', 1, ' ') + call add_default ('LOADBC2 ', 1, ' ') + call add_default ('LOADBC4 ', 1, ' ') + call add_default ('LOADBC12', 1, ' ') + call add_default ('LOADBC14', 1, ' ') + call add_default ('LOADOCAC', 1, ' ') + call add_default ('LOADOC4 ', 1, ' ') + call add_default ('LOADOC14', 1, ' ') + ! + call add_default ('EC550AER', 1, ' ') + call add_default ('ABS550_A', 1, ' ') + call add_default ('BS550AER', 1, ' ') + ! + call add_default ('EC550SO4', 1, ' ') + call add_default ('EC550BC ', 1, ' ') + call add_default ('EC550POM', 1, ' ') + call add_default ('EC550SS ', 1, ' ') + call add_default ('EC550DU ', 1, ' ') + ! + call add_default ('CDOD440 ', 1, ' ') + call add_default ('CDOD550 ', 1, ' ') + call add_default ('CABS550 ', 1, ' ') + call add_default ('CABS550A', 1, ' ') + call add_default ('CDOD870 ', 1, ' ') + call add_default ('A550_DU ', 1, ' ') + call add_default ('A550_SS ', 1, ' ') + call add_default ('A550_SO4', 1, ' ') + call add_default ('A550_POM', 1, ' ') + call add_default ('A550_BC ', 1, ' ') + call add_default ('D440_DU ', 1, ' ') + call add_default ('D440_SS ', 1, ' ') + call add_default ('D440_SO4', 1, ' ') + call add_default ('D440_POM', 1, ' ') + call add_default ('D440_BC ', 1, ' ') + call add_default ('D500_DU ', 1, ' ') + call add_default ('D500_SS ', 1, ' ') + call add_default ('D500_SO4', 1, ' ') + call add_default ('D500_POM', 1, ' ') + call add_default ('D500_BC ', 1, ' ') + call add_default ('D550_DU ', 1, ' ') + call add_default ('D550_SS ', 1, ' ') + call add_default ('D550_SO4', 1, ' ') + call add_default ('D550_POM', 1, ' ') + call add_default ('D550_BC ', 1, ' ') + call add_default ('D670_DU ', 1, ' ') + call add_default ('D670_SS ', 1, ' ') + call add_default ('D670_SO4', 1, ' ') + call add_default ('D670_POM', 1, ' ') + call add_default ('D670_BC ', 1, ' ') + call add_default ('D870_DU ', 1, ' ') + call add_default ('D870_SS ', 1, ' ') + call add_default ('D870_SO4', 1, ' ') + call add_default ('D870_POM', 1, ' ') + call add_default ('D870_BC ', 1, ' ') + call add_default ('DLT_DUST', 1, ' ') + call add_default ('DLT_SS ', 1, ' ') + call add_default ('DLT_SO4 ', 1, ' ') + call add_default ('DLT_POM ', 1, ' ') + call add_default ('DLT_BC ', 1, ' ') + call add_default ('DGT_DUST', 1, ' ') + call add_default ('DGT_SS ', 1, ' ') + call add_default ('DGT_SO4 ', 1, ' ') + call add_default ('DGT_POM ', 1, ' ') + call add_default ('DGT_BC ', 1, ' ') + call add_default ('NNAT_0 ', 1, ' ') + call add_default ('NNAT_1 ', 1, ' ') + call add_default ('NNAT_2 ', 1, ' ') + call add_default ('NNAT_4 ', 1, ' ') + call add_default ('NNAT_5 ', 1, ' ') + call add_default ('NNAT_6 ', 1, ' ') + call add_default ('NNAT_7 ', 1, ' ') + call add_default ('NNAT_8 ', 1, ' ') + call add_default ('NNAT_9 ', 1, ' ') + call add_default ('NNAT_10 ', 1, ' ') + call add_default ('NNAT_12 ', 1, ' ') + call add_default ('NNAT_14 ', 1, ' ') + call add_default ('AIRMASSL', 1, ' ') + call add_default ('AIRMASS ', 1, ' ') + call add_default ('BETOTVIS', 1, ' ') + call add_default ('BATOTVIS', 1, ' ') + call add_default ('BATSW13 ', 1, ' ') + call add_default ('BATLW01 ', 1, ' ') + + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Camrel"//trim(modeString) + if(i.ne.3) call add_default(varName, 1, ' ') + enddo + do i=1,nbmodes + modeString=" " + write(modeString,"(I2)"),i + if(i.lt.10) modeString="0"//adjustl(modeString) + varName = "Cxsrel"//trim(modeString) + if(i.ne.3) call add_default(varName, 1, ' ') + enddo + +#endif ! aerocom +#endif ! oslo_aero end subroutine diag_init_dry @@ -815,10 +803,9 @@ subroutine diag_init_moist(pbuf2d) integer :: k, m integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. integer :: ierr - !AL integer :: ixcldnc integer :: ixcldni - !AL + ! column burdens for all constituents except water vapor call constituent_burden_init @@ -859,10 +846,9 @@ subroutine diag_init_moist(pbuf2d) call addfld ('DTCOND_12_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 12hr. sin coeff.') call addfld ('DTCOND_08_COS',(/ 'lev' /), 'A','K/s','T tendency - moist processes 8hr. cos coeff.') call addfld ('DTCOND_08_SIN',(/ 'lev' /), 'A','K/s','T tendency - moist processes 8hr. sin coeff.') -!AL + call cnst_get_ind('NUMLIQ', ixcldnc) call cnst_get_ind('NUMICE', ixcldni) -!AL call addfld ('PRECL', horiz_only, 'A', 'm/s','Large-scale (stable) precipitation rate (liq + ice)' ) call addfld ('PRECC', horiz_only, 'A', 'm/s','Convective precipitation rate (liq + ice)' ) @@ -921,10 +907,8 @@ subroutine diag_init_moist(pbuf2d) if (ixcldice > 0) then call addfld (ptendnam(ixcldice),(/ 'lev' /), 'A', 'kg/kg/s',trim(cnst_name(ixcldice))//' total physics tendency ') end if -!AL call addfld (ptendnam(ixcldnc), (/ 'lev' /), 'A', '#/kg/s ',trim(cnst_name(ixcldnc))//' total physics tendency ') call addfld (ptendnam(ixcldni), (/ 'lev' /), 'A', '#/kg/s ',trim(cnst_name(ixcldni))//' total physics tendency ') -!AL if ( dycore_is('LR') )then call addfld (dmetendnam( 1),(/ 'lev' /), 'A','kg/kg/s', & trim(cnst_name( 1))//' dme adjustment tendency (FV) ') @@ -936,19 +920,15 @@ subroutine diag_init_moist(pbuf2d) call addfld (dmetendnam(ixcldice),(/ 'lev' /), 'A','kg/kg/s', & trim(cnst_name(ixcldice))//' dme adjustment tendency (FV) ') end if -!AL call addfld (dmetendnam(ixcldnc),(/ 'lev' /), 'A','#/kg/s ', & trim(cnst_name(ixcldnc))//' dme adjustment tendency (FV) ') call addfld (dmetendnam(ixcldni),(/ 'lev' /), 'A','#/kg/s ', & trim(cnst_name(ixcldni))//' dme adjustment tendency (FV) ') -!AL end if if ( history_budget ) then -!AL call add_default (ptendnam(ixcldnc), history_budget_histfile_num, ' ') call add_default (ptendnam(ixcldni), history_budget_histfile_num, ' ') -!AL end if ! outfld calls in diag_physvar_ic @@ -982,9 +962,10 @@ subroutine diag_init_moist(pbuf2d) call addfld('a2x_DSTWET4', horiz_only, 'A', 'kg/m2/s', 'wetdep of dust (bin4)') call addfld('a2x_DSTDRY4', horiz_only, 'A', 'kg/m2/s', 'drydep of dust (bin4)') - if (do_aerocom) then +#ifdef AEROCOM call add_default ('RHW ', 1, ' ') end if +#endif ! aerocom ! defaults if (history_amwg) then @@ -1754,24 +1735,22 @@ subroutine diag_phys_writeout_moist(state, pbuf, p_surf_t) call outfld ('RELHUM ',ftem ,pcols ,lchnk ) end if - if (do_aerocom) then - ! We want RHW output always when AEROCOM is on (not only if added to a namelist) - ! RH w.r.t liquid (water) - call qsat_water (state%t(:ncol,:), state%pmid(:ncol,:), & - esl(:ncol,:), ftem(:ncol,:)) - ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 - call outfld ('RHW ',ftem ,pcols ,lchnk ) - end if +#ifdef AEROCOM + ! We want RHW output always when AEROCOM is on (not only if added to a namelist) + ! RH w.r.t liquid (water) + call qsat_water (state%t(:ncol,:), state%pmid(:ncol,:), esl(:ncol,:), ftem(:ncol,:)) + ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 + call outfld ('RHW ',ftem ,pcols ,lchnk ) +#endif if (hist_fld_active('RHW') .or. hist_fld_active('RHI') .or. hist_fld_active('RHCFMIP') ) then - if (.not. do_aerocom) then +#ifndef AEROCOM ! RH w.r.t liquid (water) - call qsat_water (state%t(:ncol,:), state%pmid(:ncol,:), & - esl(:ncol,:), ftem(:ncol,:)) + call qsat_water (state%t(:ncol,:), state%pmid(:ncol,:), esl(:ncol,:), ftem(:ncol,:)) ftem(:ncol,:) = state%q(:ncol,:,1)/ftem(:ncol,:)*100._r8 call outfld ('RHW ',ftem ,pcols ,lchnk ) - end if +#endif ! Convert to RHI (ice) do i=1,ncol @@ -2441,8 +2420,8 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, ds if (dycore_is('LR')) then tmp_t(:ncol,:pver) = (state%t(:ncol,:pver) - tmp_t(:ncol,:pver))/ztodt ! T tendency call outfld('PTTEND_DME', tmp_t, pcols, lchnk ) - if(present(dsema))call outfld('IETEND_DME', dsema, pcols, lchnk) ! dry enthalpy - if(present(eflx) )call outfld('EFLX' , eflx, pcols, lchnk) ! moist enthalpy + if (present(dsema))call outfld('IETEND_DME', dsema, pcols, lchnk) ! dry enthalpy + if (present(eflx) )call outfld('EFLX' , eflx, pcols, lchnk) ! moist enthalpy end if ! Total physics tendency for Temperature @@ -2452,10 +2431,10 @@ subroutine diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, ds call check_energy_get_integrals( heat_glob_out=heat_glob , tedif_glob_out=tedif_glob ) !+tht tedif ftem2(:ncol) = heat_glob/cpair call outfld('TFIX', ftem2, pcols, lchnk ) -!+tht + ftem2(:ncol) = tedif_glob/ztodt call outfld('EBREAK', ftem2, pcols, lchnk ) -!-tht + ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) - heat_glob/cpair else ftem3(:ncol,:pver) = tend%dtdt(:ncol,:pver) @@ -2491,43 +2470,36 @@ subroutine diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & ! Arguments - type(physics_state), intent(in) :: state + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_tend ), intent(in) :: tend + real(r8), intent(in) :: ztodt ! physics timestep + real(r8), intent(inout) :: tmp_q (pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(inout) :: tmp_cldliq(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(inout) :: tmp_cldice(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(inout) :: tmp_cldnc(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(inout) :: tmp_cldni(pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(in ) :: cldncini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in ) :: cldniini (pcols,pver) ! tracer fields at beginning of physics - type(physics_buffer_desc), pointer :: pbuf(:) - type(physics_tend ), intent(in) :: tend - real(r8), intent(in) :: ztodt ! physics timestep - real(r8), intent(inout) :: tmp_q (pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8), intent(inout) :: tmp_cldliq(pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8), intent(inout) :: tmp_cldice(pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics - real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics - real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics -!AL - real(r8) , intent(inout) :: tmp_cldnc(pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8) , intent(inout) :: tmp_cldni(pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8) , intent(in ) :: cldncini (pcols,pver) ! tracer fields at beginning of physics - real(r8) , intent(in ) :: cldniini (pcols,pver) ! tracer fields at beginning of physics -!AL !---------------------------Local workspace----------------------------- - integer :: lchnk ! chunk index integer :: ncol ! number of columns in chunk real(r8) :: ftem3(pcols,pver) ! Temporary workspace for outfld variables real(r8) :: rtdt integer :: ixcldice, ixcldliq! constituent indices for cloud liquid and ice water. -!AL - integer :: ixnumice, ixnumliq! constituent indices for cloud liquid and ice water. -!AL + integer :: ixnumice, ixnumliq! constituent indices for cloud liquid and ice water. lchnk = state%lchnk ncol = state%ncol rtdt = 1._r8/ztodt call cnst_get_ind('CLDLIQ', ixcldliq, abort=.false.) call cnst_get_ind('CLDICE', ixcldice, abort=.false.) -!AL call cnst_get_ind('NUMLIQ', ixnumliq) call cnst_get_ind('NUMICE', ixnumice) -!AL if ( cnst_cam_outfld( 1) ) then call outfld (apcnst( 1), state%q(:,:, 1), pcols, lchnk) @@ -2570,12 +2542,10 @@ subroutine diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & call outfld (dmetendnam(ixcldice), tmp_cldice, pcols, lchnk) end if end if -!AL tmp_cldnc(:ncol,:pver) = (state%q(:ncol,:pver,ixnumliq) - tmp_cldnc(:ncol,:pver))*rtdt tmp_cldni(:ncol,:pver) = (state%q(:ncol,:pver,ixnumice) - tmp_cldni(:ncol,:pver))*rtdt if ( cnst_cam_outfld(ixnumliq) ) call outfld (dmetendnam(ixnumliq), tmp_cldnc, pcols, lchnk) if ( cnst_cam_outfld(ixnumice) ) call outfld (dmetendnam(ixnumice), tmp_cldni, pcols, lchnk) -!AL end if ! Total physics tendency for moisture and other tracers @@ -2596,7 +2566,6 @@ subroutine diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & call outfld (ptendnam(ixcldice), ftem3, pcols, lchnk) end if end if -!AL if ( cnst_cam_outfld(ixnumliq) ) then ftem3(:ncol,:pver) = (state%q(:ncol,:pver,ixnumliq) - cldncini(:ncol,:pver) )*rtdt call outfld (ptendnam(ixnumliq), ftem3, pcols, lchnk) @@ -2606,19 +2575,14 @@ subroutine diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & call outfld (ptendnam(ixnumice), ftem3, pcols, lchnk) end if -!AL - end subroutine diag_phys_tend_writeout_moist !####################################################################### -!AL -! subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & -! tmp_q, tmp_cldliq, tmp_cldice, qini, cldliqini, cldiceini) -!AL - subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt & - , tmp_q, tmp_t, tmp_cldliq, tmp_cldice, tmp_cldnc,tmp_cldni & - , qini, cldliqini, cldiceini,cldncini, cldniini, eflx, dsema) + subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt, & + tmp_q, tmp_t, tmp_cldliq, tmp_cldice, tmp_cldnc,tmp_cldni, & + qini, cldliqini, cldiceini,cldncini, cldniini, eflx, dsema) + !--------------------------------------------------------------- ! ! Purpose: Dump physics tendencies for moisture and temperature @@ -2627,35 +2591,31 @@ subroutine diag_phys_tend_writeout(state, pbuf, tend, ztodt & ! Arguments - type(physics_state), intent(in) :: state - - type(physics_buffer_desc), pointer :: pbuf(:) - type(physics_tend ), intent(in) :: tend - real(r8), intent(in) :: ztodt ! physics timestep - real(r8) , intent(inout) :: tmp_q (pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8) , intent(inout) :: tmp_t (pcols,pver) !tht: holds last physics_updated T (FV) - real(r8), intent(inout) :: tmp_cldliq(pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8), intent(inout) :: tmp_cldice(pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics - real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics - real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics -!AL - real(r8) , intent(inout) :: tmp_cldnc(pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8) , intent(inout) :: tmp_cldni(pcols,pver) ! As input, holds pre-adjusted tracers (FV) - real(r8) , intent(in ) :: cldncini (pcols,pver) ! tracer fields at beginning of physics - real(r8) , intent(in ) :: cldniini (pcols,pver) ! tracer fields at beginning of physics -!AL - real(r8) , intent(in), optional ::eflx (pcols ) !tht: surface sensible heat flux assoc.with mass adj. - real(r8) , intent(in), optional ::dsema(pcols ) !tht: column enthalpy tendency assoc. with mass adj. + type(physics_state), intent(in) :: state + type(physics_buffer_desc), pointer :: pbuf(:) + type(physics_tend ), intent(in) :: tend + real(r8), intent(in) :: ztodt ! physics timestep + real(r8), intent(inout) :: tmp_q (pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(inout) :: tmp_t (pcols,pver) ! tht: holds last physics_updated T (FV) + real(r8), intent(inout) :: tmp_cldliq (pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(inout) :: tmp_cldice (pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(in) :: qini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldliqini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in) :: cldiceini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(inout) :: tmp_cldnc (pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(inout) :: tmp_cldni (pcols,pver) ! As input, holds pre-adjusted tracers (FV) + real(r8), intent(in ) :: cldncini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in ) :: cldniini (pcols,pver) ! tracer fields at beginning of physics + real(r8), intent(in), optional :: eflx (pcols) ! tht: surface sensible heat flux assoc.with mass adj. + real(r8), intent(in), optional :: dsema (pcols) ! tht: column enthalpy tendency assoc. with mass adj. !----------------------------------------------------------------------- - !call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt) call diag_phys_tend_writeout_dry(state, pbuf, tend, ztodt, tmp_t, eflx, dsema) !tht if (moist_physics) then - call diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & - tmp_q, tmp_cldliq, tmp_cldice, tmp_cldnc, tmp_cldni & - ,qini, cldliqini, cldiceini , cldncini, cldniini) + call diag_phys_tend_writeout_moist(state, pbuf, tend, ztodt, & + tmp_q, tmp_cldliq, tmp_cldice, tmp_cldnc, tmp_cldni, & + qini, cldliqini, cldiceini , cldncini, cldniini) end if end subroutine diag_phys_tend_writeout diff --git a/src/NorESM/phys_control.F90 b/src/NorESM/phys_control.F90 index b4ed1199f9..06efcdde10 100644 --- a/src/NorESM/phys_control.F90 +++ b/src/NorESM/phys_control.F90 @@ -237,9 +237,9 @@ subroutine phys_ctl_readnl(nlfile) ! prog_modal_aero determines whether prognostic modal aerosols are present in the run. prog_modal_aero = index(cam_chempkg,'_mam')>0 - ! OSLO_AERO beg +#ifdef OSLO_AERO prog_modal_aero = .FALSE. - ! OSLO_AERO end +#endif end subroutine phys_ctl_readnl !=============================================================================== diff --git a/src/NorESM/physpkg.F90 b/src/NorESM/physpkg.F90 index 8c65907950..053e29d8b1 100644 --- a/src/NorESM/physpkg.F90 +++ b/src/NorESM/physpkg.F90 @@ -15,9 +15,9 @@ module physpkg use spmd_utils, only: masterproc use physconst, only: latvap, latice, rh2o use physics_types, only: physics_state, physics_tend, physics_state_set_grid, & - physics_ptend, physics_tend_init, physics_update, & - physics_type_alloc, physics_ptend_dealloc,& - physics_state_alloc, physics_state_dealloc, physics_tend_alloc, physics_tend_dealloc + physics_ptend, physics_tend_init, physics_update, & + physics_type_alloc, physics_ptend_dealloc,& + physics_state_alloc, physics_state_dealloc, physics_tend_alloc, physics_tend_dealloc use phys_grid, only: get_ncols_p use phys_gmean, only: gmean_mass use ppgrid, only: begchunk, endchunk, pcols, pver, pverp, psubcols @@ -31,11 +31,13 @@ module physpkg use perf_mod use cam_logfile, only: iulog use camsrfexch, only: cam_export + use modal_aero_calcsize, only: modal_aero_calcsize_init, modal_aero_calcsize_diag, modal_aero_calcsize_reg use modal_aero_wateruptake, only: modal_aero_wateruptake_init, modal_aero_wateruptake_dr, modal_aero_wateruptake_reg implicit none private + save ! Public methods public phys_register ! was initindx - register physics methods @@ -83,12 +85,6 @@ module physpkg integer :: snow_sh_idx = 0 integer :: dlfzm_idx = 0 ! detrained convective cloud water mixing ratio. -#ifdef AEROCOM -logical :: do_aerocom = .true. -#else -logical :: do_aerocom = .false. -#endif - !======================================================================= contains !======================================================================= @@ -231,6 +227,7 @@ subroutine phys_register ! Register CLUBB_SGS here if (do_clubb_sgs) call clubb_register_cam() + call pbuf_add_field('PREC_STR', 'physpkg',dtype_r8,(/pcols/),prec_str_idx) call pbuf_add_field('SNOW_STR', 'physpkg',dtype_r8,(/pcols/),snow_str_idx) call pbuf_add_field('PREC_PCW', 'physpkg',dtype_r8,(/pcols/),prec_pcw_idx) @@ -1265,6 +1262,7 @@ subroutine tphysac (ztodt, cam_in, & use waccmx_phys_intr, only: waccmx_phys_ion_elec_temp_tend ! WACCM-X use aoa_tracers, only: aoa_tracers_timestep_tend use physconst, only: rhoh2o, latvap,latice + use aero_model, only: aero_model_drydep use carma_intr, only: carma_emission_tend, carma_timestep_tend use carma_flags_mod, only: carma_do_aerosol, carma_do_emission use check_energy, only: check_energy_chng, calc_te_and_aam_budgets @@ -1285,7 +1283,7 @@ subroutine tphysac (ztodt, cam_in, & use qneg_module, only: qneg4 use co2_cycle, only: co2_cycle_set_ptend use nudging, only: Nudge_Model,Nudge_ON,nudging_timestep_tend - use aero_model, only: aero_model_drydep + ! ! Arguments ! @@ -1711,6 +1709,11 @@ subroutine tphysbc (ztodt, state, & use dadadj_cam, only: dadadj_tend use rk_stratiform, only: rk_stratiform_tend use microp_driver, only: microp_driver_tend +#ifdef OSLO_AERO + use oslo_aero_microp,only: oslo_aero_microp_run +#else + use microp_aero, only: microp_aero_run +#endif use macrop_driver, only: macrop_driver_tend use physics_types, only: physics_state, physics_tend, physics_ptend, & physics_update, physics_ptend_init, physics_ptend_sum, & @@ -1726,6 +1729,7 @@ subroutine tphysbc (ztodt, state, & use check_energy, only: check_tracers_data, check_tracers_init, check_tracers_chng use check_energy, only: calc_te_and_aam_budgets use dycore, only: dycore_is + use aero_model, only: aero_model_wetdep use carma_intr, only: carma_wetdep_tend, carma_timestep_tend use carma_flags_mod, only: carma_do_detrain, carma_do_cldice, carma_do_cldliq, carma_do_wetdep use radiation, only: radiation_tend @@ -1740,13 +1744,10 @@ subroutine tphysbc (ztodt, state, & use subcol, only: subcol_gen, subcol_ptend_avg use subcol_utils, only: subcol_ptend_copy, is_subcol_on use qneg_module, only: qneg3 - use aero_model, only: aero_model_wetdep #ifdef OSLO_AERO - use oslo_aero_microp,only: oslo_aero_microp_run use oslo_aero_share -#else - use microp_aero, only: microp_aero_run #endif + implicit none real(r8), intent(in) :: ztodt ! 2 delta t (model time increment) @@ -1788,16 +1789,16 @@ subroutine tphysbc (ztodt, state, & integer :: i,k,m ! Longitude, level, constituent indices integer :: ixcldice, ixcldliq ! constituent indices for cloud liquid and ice water. - !AL +!AL integer :: ixcldni, ixcldnc ! constituent indices for cloud liquid and ice water. - !AL +!AL ! for macro/micro co-substepping integer :: macmic_it ! iteration variables real(r8) :: cld_macmic_ztodt ! modified timestep - #ifdef OSLO_AERO - integer kcomp ! mode number (1-14) oslo_aero + integer kcomp ! mode number (1-14) #endif + ! physics buffer fields to compute tendencies for stratiform package integer itim_old, ifld real(r8), pointer, dimension(:,:) :: cld ! cloud fraction @@ -1809,10 +1810,10 @@ subroutine tphysbc (ztodt, state, & real(r8), pointer, dimension(:,:) :: cldliqini real(r8), pointer, dimension(:,:) :: cldiceini real(r8), pointer, dimension(:,:) :: dtcore - !AL +!AL real(r8), pointer, dimension(:,:) :: cldncini real(r8), pointer, dimension(:,:) :: cldniini - !AL +!AL real(r8), pointer, dimension(:,:,:) :: fracis ! fraction of transported species that are insoluble real(r8), pointer :: dlfzm(:,:) ! ZM detrained convective cloud water mixing ratio. @@ -1879,10 +1880,10 @@ subroutine tphysbc (ztodt, state, & call pbuf_get_field(pbuf, qini_idx, qini) call pbuf_get_field(pbuf, cldliqini_idx, cldliqini) call pbuf_get_field(pbuf, cldiceini_idx, cldiceini) - !AL +!AL call pbuf_get_field(pbuf, cldncini_idx, cldncini) call pbuf_get_field(pbuf, cldniini_idx, cldniini) - !AL +!AL ifld = pbuf_get_index('DTCORE') call pbuf_get_field(pbuf, ifld, dtcore, start=(/1,1,itim_old/), kount=(/pcols,pver,1/) ) @@ -1943,12 +1944,12 @@ subroutine tphysbc (ztodt, state, & qini (:ncol,:pver) = state%q(:ncol,:pver, 1) cldliqini(:ncol,:pver) = state%q(:ncol,:pver,ixcldliq) cldiceini(:ncol,:pver) = state%q(:ncol,:pver,ixcldice) - !AL +!AL call cnst_get_ind('NUMLIQ', ixcldnc) call cnst_get_ind('NUMICE', ixcldni) cldncini(:ncol,:pver) = state%q(:ncol,:pver,ixcldnc) cldniini(:ncol,:pver) = state%q(:ncol,:pver,ixcldni) - !AL +!AL call outfld('TEOUT', teout , pcols, lchnk ) call outfld('TEINP', state%te_ini, pcols, lchnk ) @@ -2003,8 +2004,8 @@ subroutine tphysbc (ztodt, state, & call pbuf_get_field(pbuf, snow_pcw_idx, snow_pcw ) if (use_subcol_microp) then - call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) - call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, prec_str_idx, prec_str_sc, col_type=col_type_subcol) + call pbuf_get_field(pbuf, snow_str_idx, snow_str_sc, col_type=col_type_subcol) end if ! Check energy integrals, including "reserved liquid" @@ -2146,8 +2147,8 @@ subroutine tphysbc (ztodt, state, & ! ===================================================== call clubb_tend_cam(state, ptend, pbuf, cld_macmic_ztodt,& - cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & - dlf, det_s, det_ice) + cmfmc, cam_in, macmic_it, cld_macmic_num_steps, & + dlf, det_s, det_ice) ! Since we "added" the reserved liquid back in this routine, we need ! to account for it in the energy checker @@ -2167,10 +2168,10 @@ subroutine tphysbc (ztodt, state, & ! Use actual qflux (not lhf/latvap) for consistency with surface fluxes and revised code call check_energy_chng(state, tend, "clubb_tend", nstep, ztodt, & - cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & - flx_cnd(:ncol)/cld_macmic_num_steps, & - det_ice(:ncol)/cld_macmic_num_steps, & - flx_heat(:ncol)/cld_macmic_num_steps) + cam_in%cflx(:ncol,1)/cld_macmic_num_steps, & + flx_cnd(:ncol)/cld_macmic_num_steps, & + det_ice(:ncol)/cld_macmic_num_steps, & + flx_heat(:ncol)/cld_macmic_num_steps) endif @@ -2201,6 +2202,7 @@ subroutine tphysbc (ztodt, state, & call microp_aero_run(state, ptend_aero, cld_macmic_ztodt, pbuf) call t_stopf('microp_aero_run') #endif + call t_startf('microp_tend') if (use_subcol_microp) then @@ -2309,7 +2311,7 @@ subroutine tphysbc (ztodt, state, & call t_stopf('bc_aerosols') - end if + endif !=================================================== ! Moist physical parameteriztions complete: @@ -2339,7 +2341,7 @@ subroutine tphysbc (ztodt, state, & call radiation_tend( & - state, ptend, pbuf, cam_out, cam_in, net_flx) + state, ptend, pbuf, cam_out, cam_in, net_flx) ! Set net flux used by spectral dycores do i=1,ncol @@ -2404,7 +2406,7 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) use iop_forcing, only: scam_use_iop_srf use nudging, only: Nudge_Model, nudging_timestep_init #ifdef OSLO_AERO - use oslo_aero_ocean, only: oslo_aero_ocean_time + use oslo_aero_ocean, only: oslo_aero_ocean_adv #endif implicit none @@ -2440,9 +2442,7 @@ subroutine phys_timestep_init(phys_state, cam_in, cam_out, pbuf2d) call aircraft_emit_adv(phys_state, pbuf2d) call prescribed_volcaero_adv(phys_state, pbuf2d) call prescribed_strataero_adv(phys_state, pbuf2d) - #ifdef OSLO_AERO - ! Ocean_species call oslo_aero_ocean_adv(phys_state, pbuf2d) #endif diff --git a/src/NorESM/zm_conv_intr.F90 b/src/NorESM/zm_conv_intr.F90 index 8c1530cc04..29562892d3 100644 --- a/src/NorESM/zm_conv_intr.F90 +++ b/src/NorESM/zm_conv_intr.F90 @@ -645,8 +645,7 @@ subroutine zm_conv_tend(pblh ,mcon ,cme , & state%t ,state%q(:,:,1), prec ,jctop ,jcbot , & pblh ,state%zm ,state%phis ,state%zi ,ptend_loc%q(:,:,1) , & ptend_loc%s , state%pmid ,state%pint ,state%pdel , & -! .5_r8*ztodt ,mcon ,cme , cape, & - .5_r8*ztodt ,mcon ,cme , cape, eurt,& !+tht eurt + .5_r8*ztodt ,mcon ,cme , cape, eurt,& tpert ,dlf ,pflx ,zdu ,rprd , & mu, md, du, eu, ed, & ! dp, dsubcld, jt, maxg, ideep, & diff --git a/src/physics/cam/diffusion_solver.F90 b/src/physics/cam/diffusion_solver.F90 new file mode 100644 index 0000000000..fd33773066 --- /dev/null +++ b/src/physics/cam/diffusion_solver.F90 @@ -0,0 +1,989 @@ + + module diffusion_solver + + !------------------------------------------------------------------------------------ ! + ! Module to solve vertical diffusion equations using a tri-diagonal solver. ! + ! The module will also apply countergradient fluxes, and apply molecular ! + ! diffusion for constituents. ! + ! ! + ! Public interfaces : ! + ! init_vdiff initializes time independent coefficients ! + ! compute_vdiff solves diffusion equations ! + ! vdiff_selector type for storing fields selected to be diffused ! + ! vdiff_select selects fields to be diffused ! + ! operator(.not.) extends .not. to operate on type vdiff_selector ! + ! any provides functionality of intrinsic any for type vdiff_selector ! + ! ! + !------------------------------------ Code History ---------------------------------- ! + ! Initial subroutines : B. Boville and others, 1991-2004 ! + ! Modularization : J. McCaa, September 2004 ! + ! Most Recent Code : Sungsu Park, Aug. 2006, Dec. 2008, Jan. 2010. ! + !------------------------------------------------------------------------------------ ! + + implicit none + private + save + + integer, parameter :: r8 = selected_real_kind(12) ! 8 byte real + + ! ----------------- ! + ! Public interfaces ! + ! ----------------- ! + + public init_vdiff ! Initialization + public new_fieldlist_vdiff ! Returns an empty fieldlist + public compute_vdiff ! Full routine + public vdiff_selector ! Type for storing fields selected to be diffused + public vdiff_select ! Selects fields to be diffused + public operator(.not.) ! Extends .not. to operate on type vdiff_selector + public any ! Provides functionality of intrinsic any for type vdiff_selector + + ! Below stores logical array of fields to be diffused + + type vdiff_selector + private + logical, allocatable, dimension(:) :: fields + end type vdiff_selector + + ! Below extends .not. to operate on type vdiff_selector + + interface operator(.not.) + module procedure not + end interface + + ! Below provides functionality of intrinsic any for type vdiff_selector + + interface any + module procedure my_any + end interface + + ! ------------ ! + ! Private data ! + ! ------------ ! + + ! Unit number for log output + integer :: iulog = -1 + + real(r8), private :: cpair ! Specific heat of dry air + real(r8), private :: gravit ! Acceleration due to gravity + real(r8), private :: rair ! Gas constant for dry air + + logical, private :: do_iss ! Use implicit turbulent surface stress computation + + ! Parameters used for Turbulent Mountain Stress + + real(r8), parameter :: z0fac = 0.025_r8 ! Factor determining z_0 from orographic standard deviation + real(r8), parameter :: z0max = 100._r8 ! Max value of z_0 for orography + real(r8), parameter :: horomin = 10._r8 ! Min value of subgrid orographic height for mountain stress + real(r8), parameter :: dv2min = 0.01_r8 ! Minimum shear squared + + logical :: am_correction ! logical switch for AM correction + + contains + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + subroutine init_vdiff( kind, iulog_in, rair_in, cpair_in, gravit_in, do_iss_in, & + am_correction_in, errstring ) + + integer, intent(in) :: kind ! Kind used for reals + integer, intent(in) :: iulog_in ! Unit number for log output. + real(r8), intent(in) :: rair_in ! Input gas constant for dry air + real(r8), intent(in) :: cpair_in ! Input heat capacity for dry air + real(r8), intent(in) :: gravit_in ! Input gravitational acceleration + logical, intent(in) :: do_iss_in ! Input ISS flag + logical, intent(in) :: am_correction_in! for angular momentum conservation + character(128), intent(out) :: errstring ! Output status + + errstring = '' + iulog = iulog_in + if( kind .ne. r8 ) then + write(iulog,*) 'KIND of reals passed to init_vdiff -- exiting.' + errstring = 'init_vdiff' + return + endif + + rair = rair_in + cpair = cpair_in + gravit = gravit_in + do_iss = do_iss_in + am_correction = am_correction_in + + end subroutine init_vdiff + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + type(vdiff_selector) pure function new_fieldlist_vdiff(ncnst) + + integer, intent(in) :: ncnst ! Number of constituents + + allocate( new_fieldlist_vdiff%fields( 3 + ncnst ) ) + new_fieldlist_vdiff%fields = .false. + + end function new_fieldlist_vdiff + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + subroutine compute_vdiff( lchnk , & + pcols , pver , ncnst , ncol , tint , & + p , t , rhoi , ztodt , taux , & + tauy , shflx , cflx , & + kvh , kvm , kvq , cgs , cgh , & + zi , ksrftms , dragblj , & + qmincg , fieldlist , fieldlistm , & + u , v , q , dse , & + tautmsx , tautmsy , dtk , topflx , errstring , & + tauresx , tauresy , itaures , cpairv , dse_top, & + do_molec_diff , use_temperature_molec_diff, vd_lu_qdecomp, & + ubc_mmr, ubc_flux, kvt, pmid, & + cnst_mw, cnst_fixed_ubc, cnst_fixed_ubflx, nbot_molec, & + kq_scal, mw_fac) + + !-------------------------------------------------------------------------- ! + ! Driver routine to compute vertical diffusion of momentum, moisture, trace ! + ! constituents and dry static energy. The new temperature is computed from ! + ! the diffused dry static energy. ! + ! Turbulent diffusivities and boundary layer nonlocal transport terms are ! + ! obtained from the turbulence module. ! + !-------------------------------------------------------------------------- ! + +! Used for CAM debugging. +! use phys_debug_util, only : phys_debug_col +! use time_manager, only : is_first_step, get_nstep + + use coords_1d, only: Coords1D + use linear_1d_operators, only : BoundaryType, BoundaryFixedLayer, & + BoundaryData, BoundaryFlux, TriDiagDecomp + use vdiff_lu_solver, only : fin_vol_lu_decomp + use beljaars_drag_cam, only : do_beljaars + ! FIXME: This should not be needed + use physconst, only: rairv + + use phys_control, only : phys_getopts + + ! Modification : Ideally, we should diffuse 'liquid-ice static energy' (sl), not the dry static energy. + ! Also, vertical diffusion of cloud droplet number concentration and aerosol number + ! concentration should be done very carefully in the future version. + + ! --------------- ! + ! Input Arguments ! + ! --------------- ! + + integer, intent(in) :: lchnk + integer, intent(in) :: pcols + integer, intent(in) :: pver + integer, intent(in) :: ncnst + integer, intent(in) :: ncol ! Number of atmospheric columns + integer, intent(in) :: itaures ! Indicator determining whether 'tauresx,tauresy' + ! is updated (1) or non-updated (0) in this subroutine. + + type(Coords1D), intent(in) :: p ! Pressure coordinates [ Pa ] + real(r8), intent(in) :: tint(pcols,pver+1) ! Temperature [ K ] + real(r8), intent(in) :: t(pcols,pver) ! Temperature [ K ] + real(r8), intent(in) :: rhoi(pcols,pver+1) ! Density of air at interfaces [ kg/m3 ] + real(r8), intent(in) :: ztodt ! 2 delta-t [ s ] + real(r8), intent(in) :: taux(pcols) ! Surface zonal stress. + ! Input u-momentum per unit time per unit area into the atmosphere [ N/m2 ] + real(r8), intent(in) :: tauy(pcols) ! Surface meridional stress. + ! Input v-momentum per unit time per unit area into the atmosphere [ N/m2 ] + real(r8), intent(in) :: shflx(pcols) ! Surface sensible heat flux [ W/m2 ] + real(r8), intent(in) :: cflx(pcols,ncnst) ! Surface constituent flux [ kg/m2/s ] + real(r8), intent(in) :: zi(pcols,pver+1) ! Interface heights [ m ] + real(r8), intent(in) :: ksrftms(pcols) ! Surface drag coefficient for turbulent mountain stress. > 0. [ kg/s/m2 ] + real(r8), intent(in) :: dragblj(pcols,pver) ! Drag profile from Beljaars SGO form drag > 0. [ 1/s ] + real(r8), intent(in) :: qmincg(ncnst) ! Minimum constituent mixing ratios from cg fluxes + real(r8), intent(in) :: cpairv(pcols,pver) ! Specific heat at constant pressure + real(r8), intent(in) :: kvh(pcols,pver+1) ! Eddy diffusivity for heat [ m2/s ] + + logical, intent(in) :: do_molec_diff ! Flag indicating multiple constituent diffusivities + logical, intent(in) :: use_temperature_molec_diff! Flag indicating that molecular diffusion should apply to temperature, not + ! dry static energy. + + type(vdiff_selector), intent(in) :: fieldlist ! Array of flags selecting which fields to diffuse + type(vdiff_selector), intent(in) :: fieldlistm ! Array of flags selecting which fields for molecular diffusion + + ! Dry static energy top boundary condition. + real(r8), intent(in) :: dse_top(pcols) + + real(r8), intent(in) :: kvm(pcols,pver+1) ! Eddy viscosity ( Eddy diffusivity for momentum ) [ m2/s ] + real(r8), intent(in) :: kvq(pcols,pver+1) ! Eddy diffusivity for constituents + real(r8), intent(in) :: cgs(pcols,pver+1) ! Counter-gradient star [ cg/flux ] + real(r8), intent(in) :: cgh(pcols,pver+1) ! Counter-gradient term for heat + + ! ---------------------- ! + ! Input-Output Arguments ! + ! ---------------------- ! + + real(r8), intent(inout) :: u(pcols,pver) ! U wind. This input is the 'raw' input wind to + ! PBL scheme without iterative provisional update. [ m/s ] + real(r8), intent(inout) :: v(pcols,pver) ! V wind. This input is the 'raw' input wind to PBL scheme + ! without iterative provisional update. [ m/s ] + real(r8), intent(inout) :: q(pcols,pver,ncnst) ! Moisture and trace constituents [ kg/kg, #/kg ? ] + real(r8), intent(inout) :: dse(pcols,pver) ! Dry static energy [ J/kg ] + + real(r8), intent(inout) :: tauresx(pcols) ! Input : Reserved surface stress at previous time step + real(r8), intent(inout) :: tauresy(pcols) ! Output : Reserved surface stress at current time step + + ! ---------------- ! + ! Output Arguments ! + ! ---------------- ! + + real(r8), intent(out) :: dtk(pcols,pver) ! T tendency from KE dissipation + real(r8), intent(out) :: tautmsx(pcols) ! Implicit zonal turbulent mountain surface stress + ! [ N/m2 = kg m/s /s/m2 ] + real(r8), intent(out) :: tautmsy(pcols) ! Implicit meridional turbulent mountain surface stress + ! [ N/m2 = kg m/s /s/m2 ] + real(r8), intent(out) :: topflx(pcols) ! Molecular heat flux at the top interface + character(128), intent(out) :: errstring ! Output status + + ! ------------------ ! + ! Optional Arguments ! + ! ------------------ ! + + ! The molecular diffusion module will likely change significantly in + ! the future, and this module may directly depend on it after that. + ! Until then, we have these highly specific interfaces hard-coded. + + optional :: vd_lu_qdecomp ! Constituent-dependent molecular diffusivity routine + + interface + function vd_lu_qdecomp( & + pcols , pver , ncol , fixed_ubc , mw , & + kv , kq_scal, mw_facm , dpidz_sq , coords , & + interface_boundary, molec_boundary, & + tint , ztodt , nbot_molec , & + lchnk , t , m , no_molec_decomp) result(decomp) + import + integer, intent(in) :: pcols + integer, intent(in) :: pver + integer, intent(in) :: ncol + integer, intent(in) :: nbot_molec + logical, intent(in) :: fixed_ubc + real(r8), intent(in) :: kv(pcols,pver+1) + real(r8), intent(in) :: kq_scal(pcols,pver+1) + real(r8), intent(in) :: mw + real(r8), intent(in) :: mw_facm(pcols,pver+1) + real(r8), intent(in) :: dpidz_sq(ncol,pver+1) + type(Coords1D), intent(in) :: coords + type(BoundaryType), intent(in) :: interface_boundary + type(BoundaryType), intent(in) :: molec_boundary + real(r8), intent(in) :: tint(pcols,pver+1) + real(r8), intent(in) :: ztodt + integer, intent(in) :: lchnk + real(r8), intent(in) :: t(pcols,pver) + integer, intent(in) :: m + type(TriDiagDecomp), intent(in) :: no_molec_decomp + type(TriDiagDecomp) :: decomp + end function vd_lu_qdecomp + end interface + + real(r8), intent(in), optional :: ubc_mmr(pcols,ncnst) ! Upper boundary mixing ratios [ kg/kg ] + real(r8), intent(in), optional :: ubc_flux(pcols,ncnst) ! Upper boundary flux [ kg/s/m^2 ] + + real(r8), intent(in), optional :: kvt(pcols,pver+1) ! Kinematic molecular conductivity + + ! FIXME: This input should not be needed (and should not be passed in in vertical_diffusion). + real(r8), intent(in), optional :: pmid(pcols,pver) + + real(r8), intent(in), optional :: cnst_mw(ncnst) ! Molecular weight [ kg/kmole ] + logical, intent(in), optional :: cnst_fixed_ubc(ncnst) ! Whether upper boundary condition is fixed + logical, intent(in), optional :: cnst_fixed_ubflx(ncnst) ! Whether upper boundary flux is a fixed non-zero value + + integer, intent(in), optional :: nbot_molec ! Bottom level where molecular diffusivity is applied + + ! kq_fac*sqrt(T)*m_d/rho for molecular diffusivity + real(r8), intent(in), optional :: kq_scal(pcols,pver+1) + ! Local sqrt(1/M_q + 1/M_d) for each constituent + real(r8), intent(in), optional :: mw_fac(pcols,pver+1,ncnst) + + ! --------------- ! + ! Local Variables ! + ! --------------- ! + + integer :: i, k, m ! Longitude, level, constituent indices + logical :: lqtst(pcols) ! Adjust vertical profiles + + ! LU decomposition information. + type(TriDiagDecomp) :: decomp + type(TriDiagDecomp) :: no_molec_decomp + + ! Square of derivative of pressure with height (on interfaces). + real(r8) :: dpidz_sq(ncol,pver+1) + + ! Pressure coordinates over the molecular diffusion range only. + type(Coords1D) :: p_molec + + ! Boundary layer objects + type(BoundaryType) :: interface_boundary + type(BoundaryType) :: molec_boundary + + real(r8) :: tmp1(pcols) ! Temporary storage + real(r8) :: tmpi1(pcols,pver+1) ! Interface KE dissipation + real(r8) :: tmpi2(pcols,pver+1) ! dt*(g*rho)**2/dp at interfaces + real(r8) :: keg_in(pcols,pver) ! KE on entry to subroutine + real(r8) :: keg_out(pcols,pver) ! KE after U and V dissipation/diffusion + real(r8) :: rrho(pcols) ! 1./bottom level density + + real(r8) :: tautotx(pcols) ! Total surface stress ( zonal ) + real(r8) :: tautoty(pcols) ! Total surface stress ( meridional ) + + real(r8) :: dinp_u(pcols,pver+1) ! Vertical difference at interfaces, input u + real(r8) :: dinp_v(pcols,pver+1) ! Vertical difference at interfaces, input v + real(r8) :: dout_u ! Vertical difference at interfaces, output u + real(r8) :: dout_v ! Vertical difference at interfaces, output v + + real(r8) :: qtm(pcols,pver) ! Temporary copy of q + + real(r8) :: ws(pcols) ! Lowest-level wind speed [ m/s ] + real(r8) :: tau(pcols) ! Turbulent surface stress ( not including mountain stress ) + real(r8) :: ksrfturb(pcols) ! Surface drag coefficient of 'normal' stress. > 0. + ! Virtual mass input per unit time per unit area [ kg/s/m2 ] + real(r8) :: ksrf(pcols) ! Surface drag coefficient of 'normal' stress + + ! Surface drag coefficient of 'tms' stress. > 0. [ kg/s/m2 ] + real(r8) :: usum_in(pcols) ! Vertical integral of input u-momentum. Total zonal + ! momentum per unit area in column [ sum of u*dp/g = kg m/s m-2 ] + real(r8) :: vsum_in(pcols) ! Vertical integral of input v-momentum. Total meridional + ! momentum per unit area in column [ sum of v*dp/g = kg m/s m-2 ] + real(r8) :: usum_mid(pcols) ! Vertical integral of u-momentum after adding explicit residual stress + real(r8) :: vsum_mid(pcols) ! Vertical integral of v-momentum after adding explicit residual stress + real(r8) :: usum_out(pcols) ! Vertical integral of u-momentum after doing implicit diffusion + real(r8) :: vsum_out(pcols) ! Vertical integral of v-momentum after doing implicit diffusion + real(r8) :: tauimpx(pcols) ! Actual net stress added at the current step other than mountain stress + real(r8) :: tauimpy(pcols) ! Actual net stress added at the current step other than mountain stress + real(r8) :: ramda ! dt/timeres [ no unit ] + + real(r8) :: taubljx(pcols) ! recomputed explicit/residual beljaars stress + real(r8) :: taubljy(pcols) ! recomputed explicit/residual beljaars stress + + ! Rate at which external (surface) stress damps wind speeds (1/s). + real(r8) :: tau_damp_rate(ncol, pver) + + ! Combined molecular and eddy diffusion. + real(r8) :: kv_total(pcols,pver+1) + + logical :: use_spcam + + !-------------------------------- + ! Variables needed for WACCM-X + !-------------------------------- + real(r8) :: ttemp(ncol,pver) ! temporary temperature array + real(r8) :: ttemp0(ncol,pver) ! temporary temperature array + + ! ------------------------------------------------ ! + ! Parameters for implicit surface stress treatment ! + ! ------------------------------------------------ ! + + real(r8), parameter :: wsmin = 1._r8 ! Minimum sfc wind speed for estimating frictional + ! transfer velocity ksrf. [ m/s ] + real(r8), parameter :: ksrfmin = 1.e-4_r8 ! Minimum surface drag coefficient [ kg/s/m^2 ] + real(r8), parameter :: timeres = 7200._r8 ! Relaxation time scale of residual stress ( >= dt ) [ s ] + + ! ----------------------- ! + ! Main Computation Begins ! + ! ----------------------- ! + + call phys_getopts(use_spcam_out = use_spcam) + + errstring = '' + if( ( diffuse(fieldlist,'u') .or. diffuse(fieldlist,'v') ) .and. .not. diffuse(fieldlist,'s') ) then + errstring = 'diffusion_solver.compute_vdiff: must diffuse s if diffusing u or v' + return + end if + + !--------------------------------------- ! + ! Computation of Molecular Diffusivities ! + !--------------------------------------- ! + + ! Modification : Why 'kvq' is not changed by molecular diffusion ? + + if( do_molec_diff ) then + + if( (.not.present(vd_lu_qdecomp)) .or. (.not.present(kvt)) & + .or. (.not. present(ubc_mmr)) .or. (.not. present(ubc_flux)) ) then + errstring = 'compute_vdiff: do_molec_diff true but vd_lu_qdecomp or kvt missing' + return + endif + + p_molec = p%section([1, ncol], [1, nbot_molec]) + molec_boundary = BoundaryFixedLayer(p%del(:,nbot_molec+1)) + + endif + + ! Boundary condition for a fixed concentration directly on a boundary + ! interface (i.e. a boundary layer of size 0). + interface_boundary = BoundaryFixedLayer(spread(0._r8, 1, ncol)) + + ! Note that the *derivative* dp/dz is g*rho + dpidz_sq = gravit*rhoi(:ncol,:) + dpidz_sq = dpidz_sq * dpidz_sq + + rrho(:ncol) = rair * t(:ncol,pver) / p%mid(:,pver) + + tmpi2(:ncol,1) = ztodt * dpidz_sq(:,1) / ( p%mid(:,1) - p%ifc(:,1) ) + tmpi2(:ncol,2:pver) = ztodt * dpidz_sq(:,2:pver) * p%rdst + + ! FIXME: The following four lines are kept in only to preserve answers; + ! they really should be taken out completely. + if (do_molec_diff) & + tmpi2(:ncol,1) = ztodt * (gravit * rhoi(:ncol,1))**2 / ( pmid(:ncol,1) - p%ifc(:,1) ) + dpidz_sq(:,1) = gravit*(p%ifc(:,1) / (rairv(:ncol,1,lchnk)*t(:ncol,1))) + dpidz_sq(:,1) = dpidz_sq(:,1)*dpidz_sq(:,1) + + tmp1(:ncol) = ztodt * gravit * p%rdel(:,pver) + + !---------------------------- ! + ! Diffuse Horizontal Momentum ! + !---------------------------- ! + + do k = 1, pver + do i = 1, ncol + keg_in(i,k) = 0.5_r8 * ( u(i,k)*u(i,k) + v(i,k)*v(i,k) ) + end do + end do + + if( diffuse(fieldlist,'u') .or. diffuse(fieldlist,'v') ) then + + ! Compute the vertical upward differences of the input u,v for KE dissipation + ! at each interface. + ! Velocity = 0 at surface, so difference at the bottom interface is -u,v(pver) + ! These 'dinp_u, dinp_v' are computed using the non-diffused input wind. + + do i = 1, ncol + dinp_u(i,1) = 0._r8 + dinp_v(i,1) = 0._r8 + dinp_u(i,pver+1) = -u(i,pver) + dinp_v(i,pver+1) = -v(i,pver) + end do + do k = 2, pver + do i = 1, ncol + dinp_u(i,k) = u(i,k) - u(i,k-1) + dinp_v(i,k) = v(i,k) - v(i,k-1) + end do + end do + + ! -------------------------------------------------------------- ! + ! Do 'Implicit Surface Stress' treatment for numerical stability ! + ! in the lowest model layer. ! + ! -------------------------------------------------------------- ! + + if( do_iss ) then + + ! Compute surface drag coefficient for implicit diffusion + ! including turbulent mountain stress. + + do i = 1, ncol + ws(i) = max( sqrt( u(i,pver)**2._r8 + v(i,pver)**2._r8 ), wsmin ) + tau(i) = sqrt( taux(i)**2._r8 + tauy(i)**2._r8 ) + ksrfturb(i) = max( tau(i) / ws(i), ksrfmin ) + end do + ksrf(:ncol) = ksrfturb(:ncol) + ksrftms(:ncol) ! Do all surface stress ( normal + tms ) implicitly + + ! Vertical integration of input momentum. + ! This is total horizontal momentum per unit area [ kg*m/s/m2 ] in each column. + ! Note (u,v) are the raw input to the PBL scheme, not the + ! provisionally-marched ones within the iteration loop of the PBL scheme. + + do i = 1, ncol + usum_in(i) = 0._r8 + vsum_in(i) = 0._r8 + do k = 1, pver + usum_in(i) = usum_in(i) + (1._r8/gravit)*u(i,k)*p%del(i,k) + vsum_in(i) = vsum_in(i) + (1._r8/gravit)*v(i,k)*p%del(i,k) + end do + end do + + ! Add residual stress of previous time step explicitly into the lowest + ! model layer with a relaxation time scale of 'timeres'. + + if (am_correction) then + ! preserve time-mean torque + ramda = 1._r8 + else + ramda = ztodt / timeres + endif + + u(:ncol,pver) = u(:ncol,pver) + tmp1(:ncol)*tauresx(:ncol)*ramda + v(:ncol,pver) = v(:ncol,pver) + tmp1(:ncol)*tauresy(:ncol)*ramda + + ! Vertical integration of momentum after adding explicit residual stress + ! into the lowest model layer. + + do i = 1, ncol + usum_mid(i) = 0._r8 + vsum_mid(i) = 0._r8 + do k = 1, pver + usum_mid(i) = usum_mid(i) + (1._r8/gravit)*u(i,k)*p%del(i,k) + vsum_mid(i) = vsum_mid(i) + (1._r8/gravit)*v(i,k)*p%del(i,k) + end do + end do + + else + + ! In this case, do 'turbulent mountain stress' implicitly, + ! but do 'normal turbulent stress' explicitly. + ! In this case, there is no 'residual stress' as long as 'tms' is + ! treated in a fully implicit way, which is true. + + ! 1. Do 'tms' implicitly + + ksrf(:ncol) = ksrftms(:ncol) + + ! 2. Do 'normal stress' explicitly + + u(:ncol,pver) = u(:ncol,pver) + tmp1(:ncol)*taux(:ncol) + v(:ncol,pver) = v(:ncol,pver) + tmp1(:ncol)*tauy(:ncol) + + end if ! End of 'do iss' ( implicit surface stress ) + + ! --------------------------------------------------------------------------------------- ! + ! Diffuse horizontal momentum implicitly using tri-diagnonal matrix. ! + ! The 'u,v' are input-output: the output 'u,v' are implicitly diffused winds. ! + ! For implicit 'normal' stress : ksrf = ksrftms + ksrfturb, ! + ! u(pver) : explicitly include 'residual normal' stress ! + ! For explicit 'normal' stress : ksrf = ksrftms ! + ! u(pver) : explicitly include 'normal' stress ! + ! Note that in all the two cases above, 'tms' is fully implicitly treated. ! + ! --------------------------------------------------------------------------------------- ! + + ! In most layers, no damping at all. + tau_damp_rate = 0._r8 + + ! Physical interpretation: + ! ksrf is stress per unit wind speed. + ! p%del / gravit is approximately the mass in the layer per unit of + ! surface area. + ! Therefore, gravit*ksrf/p%del is the acceleration of wind per unit + ! wind speed, i.e. the rate at which wind is exponentially damped by + ! surface stress. + + ! Beljaars et al SGO scheme incorporated here. It + ! appears as a "3D" tau_damp_rate specification. + + tau_damp_rate(:,pver) = -gravit*ksrf(:ncol)*p%rdel(:,pver) + do k=1,pver + tau_damp_rate(:,k) = tau_damp_rate(:,k) + dragblj(:ncol,k) + end do + + decomp = fin_vol_lu_decomp(ztodt, p, & + coef_q=tau_damp_rate, coef_q_diff=kvm(:ncol,:)*dpidz_sq) + + call decomp%left_div(u(:ncol,:)) + call decomp%left_div(v(:ncol,:)) + call decomp%finalize() + + ! ---------------------------------------------------------------------- ! + ! Calculate 'total' ( tautotx ) and 'tms' ( tautmsx ) stresses that ! + ! have been actually added into the atmosphere at the current time step. ! + ! Also, update residual stress, if required. ! + ! ---------------------------------------------------------------------- ! + + do i = 1, ncol + + ! Compute the implicit 'tms' using the updated winds. + ! Below 'tautmsx(i),tautmsy(i)' are pure implicit mountain stresses + ! that has been actually added into the atmosphere both for explicit + ! and implicit approach. + + tautmsx(i) = -ksrftms(i)*u(i,pver) + tautmsy(i) = -ksrftms(i)*v(i,pver) + + ! We want to add vertically-integrated Beljaars drag to residual stress. + ! So this has to be calculated locally. + ! We may want to rethink the residual drag calculation performed here on. (jtb) + taubljx(i) = 0._r8 + taubljy(i) = 0._r8 + do k = 1, pver + taubljx(i) = taubljx(i) + (1._r8/gravit)*dragblj(i,k)*u(i,k)*p%del(i,k) + taubljy(i) = taubljy(i) + (1._r8/gravit)*dragblj(i,k)*v(i,k)*p%del(i,k) + end do + + if( do_iss ) then + + ! Compute vertical integration of final horizontal momentum + + usum_out(i) = 0._r8 + vsum_out(i) = 0._r8 + do k = 1, pver + usum_out(i) = usum_out(i) + (1._r8/gravit)*u(i,k)*p%del(i,k) + vsum_out(i) = vsum_out(i) + (1._r8/gravit)*v(i,k)*p%del(i,k) + end do + + ! Compute net stress added into the atmosphere at the current time step. + ! Note that the difference between 'usum_in' and 'usum_out' are induced + ! by 'explicit residual stress + implicit total stress' for implicit case, while + ! by 'explicit normal stress + implicit tms stress' for explicit case. + ! Here, 'tautotx(i)' is net stress added into the air at the current time step. + + tauimpx(i) = ( usum_out(i) - usum_in(i) ) / ztodt + tauimpy(i) = ( vsum_out(i) - vsum_in(i) ) / ztodt + + tautotx(i) = tauimpx(i) + tautoty(i) = tauimpy(i) + + ! Compute residual stress and update if required. + ! Note that the total stress we should have added at the current step is + ! the sum of 'taux(i) - ksrftms(i)*u(i,pver) + tauresx(i)'. + + if( itaures .eq. 1 ) then + tauresx(i) = taux(i) + tautmsx(i) + taubljx(i) + tauresx(i)- tauimpx(i) + tauresy(i) = tauy(i) + tautmsy(i) + taubljy(i) + tauresy(i)- tauimpy(i) + endif + + else + + tautotx(i) = tautmsx(i) + taux(i) + tautoty(i) = tautmsy(i) + tauy(i) + tauresx(i) = 0._r8 + tauresy(i) = 0._r8 + + end if ! End of 'do_iss' if + + end do ! End of 'do i = 1, ncol' loop + + ! ------------------------------------ ! + ! Calculate kinetic energy dissipation ! + ! ------------------------------------ ! + + ! Modification : In future, this should be set exactly same as + ! the ones in the convection schemes + + ! 1. Compute dissipation term at interfaces + ! Note that 'u,v' are already diffused wind, and 'tautotx,tautoty' are + ! implicit stress that has been actually added. On the other hand, + ! 'dinp_u, dinp_v' were computed using non-diffused input wind. + + ! Modification : I should check whether non-consistency between 'u' and 'dinp_u' + ! is correctly intended approach. I think so. + + k = pver + 1 + do i = 1, ncol + tmpi1(i,1) = 0._r8 + tmpi1(i,k) = 0.5_r8 * ztodt * gravit * & + ( (-u(i,k-1) + dinp_u(i,k))*tautotx(i) + (-v(i,k-1) + dinp_v(i,k))*tautoty(i) ) + end do + + do k = 2, pver + do i = 1, ncol + dout_u = u(i,k) - u(i,k-1) + dout_v = v(i,k) - v(i,k-1) + tmpi1(i,k) = 0.25_r8 * tmpi2(i,k) * kvm(i,k) * & + ( dout_u**2 + dout_v**2 + dout_u*dinp_u(i,k) + dout_v*dinp_v(i,k) ) + end do + end do + + if (do_beljaars) then + + ! 2. Add Kinetic Energy change across dissipation to Static Energy + do k = 1, pver + do i = 1, ncol + keg_out(i,k) = 0.5_r8 * ( u(i,k)*u(i,k) + v(i,k)*v(i,k) ) + end do + end do + + do k = 1, pver + do i = 1, ncol + dtk(i,k) = keg_in(i,k) - keg_out(i,k) + dse(i,k) = dse(i,k) + dtk(i,k) ! + dkeblj(i,k) + end do + end do + + else + + ! 2. Compute dissipation term at midpoints, add to dry static energy + do k = 1, pver + do i = 1, ncol + dtk(i,k) = ( tmpi1(i,k+1) + tmpi1(i,k) ) * p%rdel(i,k) + dse(i,k) = dse(i,k) + dtk(i,k) + end do + end do + + end if + + end if ! End of diffuse horizontal momentum, diffuse(fieldlist,'u') routine + + !-------------------------- ! + ! Diffuse Dry Static Energy ! + !-------------------------- ! + + ! Modification : In future, we should diffuse the fully conservative + ! moist static energy,not the dry static energy. + + if( diffuse(fieldlist,'s') ) then + if (.not. use_spcam) then + + ! Add counter-gradient to input static energy profiles + + do k = 1, pver + dse(:ncol,k) = dse(:ncol,k) + ztodt * p%rdel(:,k) * gravit * & + ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgh(:ncol,k+1) & + - rhoi(:ncol,k ) * kvh(:ncol,k ) * cgh(:ncol,k ) ) + end do + endif + ! Add the explicit surface fluxes to the lowest layer + dse(:ncol,pver) = dse(:ncol,pver) + tmp1(:ncol) * shflx(:ncol) + + ! Diffuse dry static energy + + !--------------------------------------------------- + ! Solve for temperature using thermal conductivity + !--------------------------------------------------- + if ( use_temperature_molec_diff ) then + !---------------------------------------------------------------------------------------------------- + ! In Extended WACCM, kvt is calculated rather kvh. This is because molecular diffusion operates on + ! temperature, while eddy diffusion operates on dse. Also, pass in constituent dependent "constants" + !---------------------------------------------------------------------------------------------------- + + ! Boundary layer thickness of "0._r8" signifies that the boundary + ! condition is defined directly on the top interface. + decomp = fin_vol_lu_decomp(ztodt, p, & + coef_q_diff=kvh(:ncol,:)*dpidz_sq, & + upper_bndry=interface_boundary) + + if (.not. use_spcam) then + call decomp%left_div(dse(:ncol,:), & + l_cond=BoundaryData(dse_top(:ncol))) + endif + + call decomp%finalize() + + ! Calculate flux at top interface + + ! Modification : Why molecular diffusion does not work for dry static energy in all layers ? + + topflx(:ncol) = - kvh(:ncol,1) * tmpi2(:ncol,1) / (ztodt*gravit) * & + ( dse(:ncol,1) - dse_top(:ncol) ) + + decomp = fin_vol_lu_decomp(ztodt, p, & + coef_q_diff=kvt(:ncol,:)*dpidz_sq, & + coef_q_weight=cpairv(:ncol,:)) + + ttemp0 = t(:ncol,:) + ttemp = ttemp0 + + ! upper boundary is zero flux for extended model + if (.not. use_spcam) then + call decomp%left_div(ttemp) + end if + + call decomp%finalize() + + !------------------------------------- + ! Update dry static energy + !------------------------------------- + do k = 1,pver + dse(:ncol,k) = dse(:ncol,k) + & + cpairv(:ncol,k)*(ttemp(:,k) - ttemp0(:,k)) + enddo + + else + + if (do_molec_diff) then + kv_total(:ncol,:) = kvh(:ncol,:) + kvt(:ncol,:)/cpair + else + kv_total(:ncol,:) = kvh(:ncol,:) + end if + + ! Boundary layer thickness of "0._r8" signifies that the boundary + ! condition is defined directly on the top interface. + decomp = fin_vol_lu_decomp(ztodt, p, & + coef_q_diff=kv_total(:ncol,:)*dpidz_sq, & + upper_bndry=interface_boundary) + + if (.not. use_spcam) then + call decomp%left_div(dse(:ncol,:), & + l_cond=BoundaryData(dse_top(:ncol))) + end if + + call decomp%finalize() + + ! Calculate flux at top interface + + ! Modification : Why molecular diffusion does not work for dry static energy in all layers ? + + if( do_molec_diff ) then + topflx(:ncol) = - kv_total(:ncol,1) * tmpi2(:ncol,1) / (ztodt*gravit) * & + ( dse(:ncol,1) - dse_top(:ncol) ) + else + topflx(:ncol) = 0._r8 + end if + + endif + + endif + + !---------------------------- ! + ! Diffuse Water Vapor Tracers ! + !---------------------------- ! + + ! Modification : For aerosols, I need to use separate treatment + ! for aerosol mass and aerosol number. + + ! Loop through constituents + + no_molec_decomp = fin_vol_lu_decomp(ztodt, p, & + coef_q_diff=kvq(:ncol,:)*dpidz_sq) + + do m = 1, ncnst + + if( diffuse(fieldlist,'q',m) ) then + if (.not. use_spcam) then + + ! Add the nonlocal transport terms to constituents in the PBL. + ! Check for neg q's in each constituent and put the original vertical + ! profile back if a neg value is found. A neg value implies that the + ! quasi-equilibrium conditions assumed for the countergradient term are + ! strongly violated. + + qtm(:ncol,:pver) = q(:ncol,:pver,m) + + do k = 1, pver + q(:ncol,k,m) = q(:ncol,k,m) + & + ztodt * p%rdel(:,k) * gravit * ( cflx(:ncol,m) * rrho(:ncol) ) * & + ( rhoi(:ncol,k+1) * kvh(:ncol,k+1) * cgs(:ncol,k+1) & + - rhoi(:ncol,k ) * kvh(:ncol,k ) * cgs(:ncol,k ) ) + end do + lqtst(:ncol) = all(q(:ncol,1:pver,m) >= qmincg(m), 2) + do k = 1, pver + q(:ncol,k,m) = merge( q(:ncol,k,m), qtm(:ncol,k), lqtst(:ncol) ) + end do + endif + + ! Add the explicit surface fluxes to the lowest layer + + q(:ncol,pver,m) = q(:ncol,pver,m) + tmp1(:ncol) * cflx(:ncol,m) + + ! Diffuse constituents. + + ! This is for solving molecular diffusion of minor species, thus, for WACCM-X, bypass O and O2 (major species) + ! Major species diffusion is calculated separately. -Hanli Liu + + if( do_molec_diff .and. diffuse(fieldlistm,'q',m)) then + + decomp = vd_lu_qdecomp( pcols , pver , ncol , cnst_fixed_ubc(m), cnst_mw(m), & + kvq , kq_scal, mw_fac(:,:,m) ,dpidz_sq , p_molec, & + interface_boundary, molec_boundary, & + tint , ztodt , nbot_molec , & + lchnk , t , m , no_molec_decomp) + + ! This to calculate the upper boundary flux of H. -Hanli Liu + if ((cnst_fixed_ubflx(m))) then + + ! ubc_flux is a flux of mass density through space, i.e.: + ! ubc_flux = rho_i * dz/dt = q_i * rho * dz/dt + ! For flux of mmr through pressure level, multiply by g: + ! q_i * rho * gravit * dz/dt = q_i * dp/dt + + call decomp%left_div(q(:ncol,:,m), & + l_cond=BoundaryFlux( & + -gravit*ubc_flux(:ncol,m), ztodt, & + p%del(:,1))) + + else + call decomp%left_div(q(:ncol,:,m), & + l_cond=BoundaryData(ubc_mmr(:ncol,m))) + end if + + call decomp%finalize() + + else + + if (.not. use_spcam) then + ! Currently, no ubc for constituents without molecular + ! diffusion (they cannot diffuse out the top of the model). + call no_molec_decomp%left_div(q(:ncol,:,m)) + end if + + end if + + end if + end do + + call no_molec_decomp%finalize() + + end subroutine compute_vdiff + + ! =============================================================================== ! + ! ! + ! =============================================================================== ! + + character(128) function vdiff_select( fieldlist, name, qindex ) + ! --------------------------------------------------------------------- ! + ! This function sets the field with incoming name as one to be diffused ! + ! --------------------------------------------------------------------- ! + type(vdiff_selector), intent(inout) :: fieldlist + character(*), intent(in) :: name + integer, intent(in), optional :: qindex + + vdiff_select = '' + select case (name) + case ('u','U') + fieldlist%fields(1) = .true. + case ('v','V') + fieldlist%fields(2) = .true. + case ('s','S') + fieldlist%fields(3) = .true. + case ('q','Q') + if( present(qindex) ) then + fieldlist%fields(3 + qindex) = .true. + else + fieldlist%fields(4) = .true. + endif + case default + write(vdiff_select,*) 'Bad argument to vdiff_index: ', name + end select + return + + end function vdiff_select + + type(vdiff_selector) function not(a) + ! ------------------------------------------------------------- ! + ! This function extends .not. to operate on type vdiff_selector ! + ! ------------------------------------------------------------- ! + type(vdiff_selector), intent(in) :: a + allocate(not%fields(size(a%fields))) + not%fields = .not. a%fields + end function not + + logical function my_any(a) + ! -------------------------------------------------- ! + ! This function extends the intrinsic function 'any' ! + ! to operate on type vdiff_selector ! + ! -------------------------------------------------- ! + type(vdiff_selector), intent(in) :: a + my_any = any(a%fields) + end function my_any + + logical function diffuse(fieldlist,name,qindex) + ! ---------------------------------------------------------------------------- ! + ! This function reports whether the field with incoming name is to be diffused ! + ! ---------------------------------------------------------------------------- ! + type(vdiff_selector), intent(in) :: fieldlist + character(*), intent(in) :: name + integer, intent(in), optional :: qindex + + select case (name) + case ('u','U') + diffuse = fieldlist%fields(1) + case ('v','V') + diffuse = fieldlist%fields(2) + case ('s','S') + diffuse = fieldlist%fields(3) + case ('q','Q') + if( present(qindex) ) then + diffuse = fieldlist%fields(3 + qindex) + else + diffuse = fieldlist%fields(4) + endif + case default + diffuse = .false. + end select + return + end function diffuse + +end module diffusion_solver diff --git a/src/physics/cam/ndrop.F90 b/src/physics/cam/ndrop.F90 index b6368d18df..81e391c87b 100644 --- a/src/physics/cam/ndrop.F90 +++ b/src/physics/cam/ndrop.F90 @@ -160,7 +160,7 @@ subroutine ndrop_init voltonumbhi_amode(m) = 1._r8 / ( (pi/6._r8)* & (dgnumhi_amode(m)**3._r8)*exp(4.5_r8*alogsig(m)**2._r8) ) end do - + ! Init the table for local indexing of mam number conc and mmr. ! This table uses species index 0 for the number conc. @@ -243,7 +243,7 @@ subroutine ndrop_init end if - + end do end do @@ -261,7 +261,7 @@ subroutine ndrop_init call addfld('NDROPSNK', (/ 'lev' /), 'A', '#/kg/s', 'Droplet number loss by microphysics') call addfld('NDROPCOL', horiz_only, 'A', '#/m2', 'Column droplet number') - ! set the add_default fields + ! set the add_default fields if (history_amwg) then call add_default('CCN3', 1, ' ') endif @@ -411,7 +411,7 @@ subroutine dropmixnuc( & real(r8), allocatable :: fluxn(:) ! number activation fraction flux (cm/s) real(r8), allocatable :: fluxm(:) ! mass activation fraction flux (cm/s) real(r8) :: flux_fullact(pver) ! 100% activation fraction flux (cm/s) - ! note: activation fraction fluxes are defined as + ! note: activation fraction fluxes are defined as ! fluxn = [flux of activated aero. number into cloud (#/cm2/s)] ! / [aero. number conc. in updraft, just below cloudbase (#/cm3)] @@ -485,7 +485,7 @@ subroutine dropmixnuc( & fluxn(ntot_amode), & fluxm(ntot_amode) ) - ! Init pointers to mode number and specie mass mixing ratios in + ! Init pointers to mode number and specie mass mixing ratios in ! intersitial and cloud borne phases. do m = 1, ntot_amode mm = mam_idx(m, 0) @@ -498,7 +498,7 @@ subroutine dropmixnuc( & end do end do - called_from_spcam = (present(from_spcam)) + called_from_spcam = (present(from_spcam)) if (called_from_spcam) then rgas => state%q @@ -597,9 +597,9 @@ subroutine dropmixnuc( & ! droplet nucleation/aerosol activation - ! tau_cld_regenerate = time scale for regeneration of cloudy air + ! tau_cld_regenerate = time scale for regeneration of cloudy air ! by (horizontal) exchange with clear air - tau_cld_regenerate = 3600.0_r8 * 3.0_r8 + tau_cld_regenerate = 3600.0_r8 * 3.0_r8 if (called_from_spcam) then ! when this is called in the MMF part, no cloud regeneration and decay. @@ -652,7 +652,7 @@ subroutine dropmixnuc( & ! alternate formulation ! cldn_tmp = cldn(i,k) * max( 0.0_r8, (1.0_r8-dtmicro/tau_cld_regenerate) ) - ! fraction is also provided. + ! fraction is also provided. if (cldn_tmp < cldo_tmp) then ! droplet loss in decaying cloud !++ sungsup @@ -679,7 +679,7 @@ subroutine dropmixnuc( & ! growing liquid cloud ...................................................... ! treat the increase of cloud fraction from when cldn(i,k) > cldo(i,k) - ! and also regenerate part of the cloud + ! and also regenerate part of the cloud cldo_tmp = cldn_tmp cldn_tmp = lcldn(i,k) @@ -780,7 +780,7 @@ subroutine dropmixnuc( & phase = 1 ! interstitial do m = 1, ntot_amode - ! rce-comment - use kp1 here as old-cloud activation involves + ! rce-comment - use kp1 here as old-cloud activation involves ! aerosol from layer below call loadaer( & state, pbuf, i, i, kp1, & @@ -819,14 +819,14 @@ subroutine dropmixnuc( & ! rce-comment 2 ! code for k=pver was changed to use the following conceptual model ! in k=pver, there can be no cloud-base activation unless one considers - ! a scenario such as the layer being partially cloudy, + ! a scenario such as the layer being partially cloudy, ! with clear air at bottom and cloudy air at top - ! assume this scenario, and that the clear/cloudy portions mix with + ! assume this scenario, and that the clear/cloudy portions mix with ! a timescale taumix_internal = dz(i,pver)/wtke_cen(i,pver) - ! in the absence of other sources/sinks, qact (the activated particle + ! in the absence of other sources/sinks, qact (the activated particle ! mixratio) attains a steady state value given by ! qact_ss = fcloud*fact*qtot - ! where fcloud is cloud fraction, fact is activation fraction, + ! where fcloud is cloud fraction, fact is activation fraction, ! qtot=qact+qint, qint is interstitial particle mixratio ! the activation rate (from mixing within the layer) can now be ! written as @@ -836,8 +836,8 @@ subroutine dropmixnuc( & ! also, d(qact)/dt can be negative. in the code below ! it is forced to be >= 0 ! - ! steve -- - ! you will likely want to change this. i did not really understand + ! steve -- + ! you will likely want to change this. i did not really understand ! what was previously being done in k=pver ! in the cam3_5_3 code, wtke(i,pver) appears to be equal to the ! droplet deposition velocity which is quite small @@ -910,7 +910,7 @@ subroutine dropmixnuc( & do k = top_lev, pver-1 ! rce-comment -- ekd(k) is eddy-diffusivity at k/k+1 interface ! want ekk(k) = ekd(k) * (density at k/k+1 interface) - ! so use pint(i,k+1) as pint is 1:pverp + ! so use pint(i,k+1) as pint is 1:pverp ! ekk(k)=ekd(k)*2.*pint(i,k)/(rair*(temp(i,k)+temp(i,k+1))) ! ekk(k)=ekd(k)*2.*pint(i,k+1)/(rair*(temp(i,k)+temp(i,k+1))) ekk(k) = ekd(k)*csbot(k) @@ -926,10 +926,10 @@ subroutine dropmixnuc( & ! for the layer. for most layers, the activation loss rate ! (for interstitial particles) is accounted for by the loss by ! turb-transfer to the layer above. - ! k=pver is special, and the loss rate for activation within + ! k=pver is special, and the loss rate for activation within ! the layer must be added to tinv. if not, the time step ! can be too big, and explmix can produce negative values. - ! the negative values are reset to zero, resulting in an + ! the negative values are reset to zero, resulting in an ! artificial source. if (k == pver) tinv = tinv + taumix_internal_pver_inv @@ -1013,7 +1013,7 @@ subroutine dropmixnuc( & ! of a layer, and generally higher in the clear portion. (we have/had ! a method for diagnosing the the clear/cloudy mixratios.) the activation ! source terms involve clear air (from below) moving into cloudy air (above). - ! in theory, the clear-portion mixratio should be used when calculating + ! in theory, the clear-portion mixratio should be used when calculating ! source terms do m = 1, ntot_amode mm = mam_idx(m,0) @@ -1157,14 +1157,14 @@ subroutine dropmixnuc( & call outfld('NDROPMIX', ndropmix, pcols, lchnk) call outfld('WTKE ', wtke, pcols, lchnk) - if(called_from_spcam) then + if(called_from_spcam) then call outfld('SPLCLOUD ', cldn , pcols, lchnk ) call outfld('SPKVH ', kvh , pcols, lchnk ) endif call ccncalc(state, pbuf, cs, ccn) do l = 1, psat - call outfld(ccn_name(l), ccn(1,1,l), pcols, lchnk) + call outfld(ccn_name(l), ccn(:,:,l), pcols, lchnk) enddo ! do column tendencies @@ -1331,7 +1331,7 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & ! used for consistency check -- this should match (ekd(k)*zs(k)) ! also, fluxm/flux_fullact gives fraction of aerosol mass flux ! that is activated - + ! optional real(r8), optional, intent(in) :: smax_prescribed ! prescribed max. supersaturation for secondary activation logical, optional, intent(in) :: in_cloud_in ! switch to modify calculations when above cloud base @@ -1652,7 +1652,7 @@ subroutine activate_modal(wbar, sigw, wdiab, wminf, wmaxf, tair, rhoair, & if(wnuc.gt.0._r8)then w=wbar - + if(in_cloud) then if (smax_f > 0._r8) then @@ -1869,7 +1869,7 @@ subroutine loadaer( & type(physics_buffer_desc), pointer :: pbuf(:) integer, intent(in) :: istart ! start column index (1 <= istart <= istop <= pcols) - integer, intent(in) :: istop ! stop column index + integer, intent(in) :: istop ! stop column index integer, intent(in) :: m ! mode index integer, intent(in) :: k ! level index real(r8), intent(in) :: cs(:,:) ! air density (kg/m3) @@ -1965,7 +1965,3 @@ end subroutine loadaer !=============================================================================== end module ndrop - - - - diff --git a/src/physics/spcam/spcam_drivers.F90 b/src/physics/spcam/spcam_drivers.F90 index aad6cd79ac..ebe6507607 100644 --- a/src/physics/spcam/spcam_drivers.F90 +++ b/src/physics/spcam/spcam_drivers.F90 @@ -1189,7 +1189,7 @@ subroutine spcam_radiation_finalize_m2005(cam_in, state, pbuf, rad_avgdata, cam_ call outfld('SOLLD'//' ',rad_avgdata%solld_m(:) ,pcols,lchnk) call outfld('FSN200'//' ',rad_avgdata%fsn200_m(:),pcols,lchnk) call outfld('FSN200C'//' ',rad_avgdata%fsn200c_m(:),pcols,lchnk) - call outfld('SWCF'//' ',rad_avgdata%fsntoa_m(:)-rad_avgdata%fsntoac_m(:) ,ncol,lchnk) + call outfld('SWCF'//' ',rad_avgdata%fsntoa_m(:)-rad_avgdata%fsntoac_m(:) ,pcols,lchnk) call outfld('FSNR'//' ',rad_avgdata%fsnr_m(:) ,pcols,lchnk) do i = 1, nnite @@ -2053,7 +2053,7 @@ subroutine spcam_radiation_finalize_sam1mom(cam_in, state, pbuf, rad_avgdata, ca call outfld('FSN200 ',rad_avgdata%fsn200_m(:),pcols,lchnk) call outfld('FSN200C ',rad_avgdata%fsn200c_m(:),pcols,lchnk) call outfld('FSNR' ,rad_avgdata%fsnr_m(:) ,pcols,lchnk) - call outfld('SWCF ',rad_avgdata%fsntoa_m(:ncol)-rad_avgdata%fsntoac_m(:ncol) ,pcols,lchnk) + call outfld('SWCF ',rad_avgdata%fsntoa_m(:ncol)-rad_avgdata%fsntoac_m(:ncol) ,ncol,lchnk) do i=1, Nday do k=1, pver